Delphi实现解析百度搜索结果link？url=-木庄网络博客

本文整理自网络，侵删。
 unit uMain;
{
   Created at 2012/01/19
   微博 http://weibo.com/yinyongyou
   博客 http://blog.csdn.net/MichaelJScofield
}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,WinSock, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdHTTP;

type
  TfrmBaiduURLDecode = class(TForm)
    lblSrcUrl: TLabel;
    edtEncode: TEdit;
    lblDstURL: TLabel;
    edtDecode: TEdit;
    btnFuck: TButton;
    mmo1: TMemo;
    procedure btnFuckClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
const
  HttpLine = #13#10#13#10;

var
  frmBaiduURLDecode: TfrmBaiduURLDecode;
  WSAData: TWSAData;

implementation

{$R *.dfm}

{ 获取http返回头部 }
function GetHTTPResponseHeader(URL:String;var lpHeader:string):String;
const
  BufLenth = 1024;
  INTERNET_DEFAULT_HTTP_PORT = 80;
var
  Buf:array[0..1023] of AnsiChar;
  t: linger;
  hSocket:integer;
  hSend,hRet,hConnect:Integer;
  iHost:Integer;
  TimeOut:integer;
  dwPort,dwRecv:DWORD;
  HostIP:PHostEnt;
  Addr:sockaddr_in;
  BufSend,BufRev:PChar;
  lpHttpHead,lpRecvStr:String;
  szHostName,szHostPort,szFileName:String;
  procedure ParseURL(URL: string; var HostName, FileName: string);
    procedure ReplaceChar(c1, c2: Char; var St: string);
    var
      p: Integer;
    begin
      while True do
      begin
        p := Pos(c1, St);
        if p = 0 then Break
        else St[p] := c2;
      end;
    end;
  var
    i: Integer;
  begin
    if Pos(UpperCase('http://'), UpperCase(URL)) <> 0 then System.Delete(URL, 1, 7);
    i := Pos('/', URL);
    HostName := Copy(URL, 1, i);
    FileName := Copy(URL, i, Length(URL) - i + 1);
    if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
      SetLength(HostName, Length(HostName) - 1);
  end;
begin
  Result:='';
  ParseURL(URL, szHostName, szFileName);
  iHost := Pos(':',szHostName);
  if iHost <> 0 then
  begin
    szHostPort := Copy(szHostName, iHost+1, Length(szHostName)-iHost);
    szHostName := Copy(szHostName, 1, iHost-1);
    dwPort := StrToIntDef(szHostPort, INTERNET_DEFAULT_HTTP_PORT);
  end
  else dwPort := INTERNET_DEFAULT_HTTP_PORT;
  hSocket:=Socket(AF_INET,SOCK_STREAM,IPPROTO_IP); //IPPROTO_IP IPPROTO_TCP
  Try
    if hSocket = INVALID_SOCKET then Exit;
    HostIP:=GetHostByName(PChar(szHostName));
    FillChar(Addr,SizeOf(Addr),#0);
    Addr.sin_family:=AF_INET;
    Addr.sin_addr.S_addr:=PDWORD(PDWORD(HostIP.h_addr)^)^;
    Addr.sin_port:=htons(dwPort);
    hConnect:=Connect(hSocket,Addr,SizeOf(Addr));
    if WSAGetLastError() = 10060 then hConnect:=Connect(hSocket,Addr,SizeOf(Addr));
    if hConnect = SOCKET_ERROR then
    begin
      CloseSocket(hSocket);
      Exit;
    end;
    lpHttpHead := 'GET ' + szFileName + ' HTTP/1.1' + #13#10 +
                  'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*'+ #13#10+
                  'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)'+ #13#10 +
                  'Host: ' + szHostName + #13#10 +
                  'Referer: ' + URL + #13#10 +
                  'Accept-Language: zh-cn' + #13#10 +
                  'Cache-Control: no-cache' + #13#10 +
                  'Connection: close' + #13#10 +
                  'Cookie: ' + 'iscookies=0; ASPSESSIONIDACRQTBCS=OGALDEBDBBIGMLOHFKMOJFKO' + #13#10 +
                  #13#10#13#10;
    GetMem(BufSend, Length(lpHttpHead) + 1);
    Try
      ZeroMemory(BufSend, Length(lpHttpHead) + 1);
      StrPCopy(BufSend, lpHttpHead);
      hSend:=Send(hSocket, BufSend^, Length(BufSend), 0);
      if hSend = SOCKET_ERROR then
      begin
        CloseSocket(hSocket);
        Exit;
      end;
      FillChar(Buf, SizeOf(Buf), #00);
      while Recv(hSocket, Buf, SizeOf(Buf), 0) > 0 do
      begin
        lpRecvStr:='';
        SetString(lpRecvStr, Buf, SizeOf(Buf));
        Result := Result + lpRecvStr;
        FillChar(Buf, SizeOf(Buf), #00);
        if Pos(HttpLine,Result)>0 then break;
      end;
      lpHeader := Copy(Result,1,Pos(HttpLine,Result)-1);
    finally
      FreeMem(BufSend);
    end;   
    t.l_onoff:=1;
    t.l_linger:=0;
    SetSockopt(hSocket, SOL_SOCKET, SO_LINGER, @t, SizeOf(t));
  finally
    CloseSocket(hSocket);
  end;
end;

{ 获取真实地址 }
function GetRealURL(sUrl:string):string;
var
  lpHeader: string;
begin
  GetHTTPResponseHeader(sUrl,lpHeader);
  frmBaiduURLDecode.mmo1.Text := lpHeader;
  if (Pos('301',lpHeader)>0) or (Pos('302',lpHeader)>0) then
  begin
    Delete(lpHeader,1,Pos('Location:',lpHeader)+Length('Location:'));
    Result := Copy(lpHeader,1,Pos(#13,lpHeader));
  end;
end;

{ 提取真实地址 }
procedure TfrmBaiduURLDecode.btnFuckClick(Sender: TObject);
begin
  edtDecode.Text := GetRealURL(edtEncode.Text);
end;

initialization
  WSAStartUp($202, WSAData);

finalization
  WSACleanup;
end.
Delphi实现解析百度搜索结果link？url=

相关推荐

评论
