求个delphi 提取网页数据和发送数据到网页 的demo

[hyb2000]

xiexie

[byteh]

你这个东西描述的太笼统了。

[swlilike]

我知道一个 控件 TidHttp 然后用法是 TidHttp.creat(nil).ger('网址')

[hyb2000]

就是差不多要做这么个东西，有人做过么，发个给我瞅瞅。。

[swlilike]

先添加控件 TidHttp，然后 写函数 Tidhttp.Create(nil).get(PChar('http://www.sina.com/'));
注意 这个不能取得 百度等少数几个网站的源代码，不知道为什么

[Rex_love_Burger]

//实现HTML源码的读：
function GetHtml(const WebBrowser:TWebBrowser): string;
const
BufSize = $10000;
var
Size: Int64;
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;

OleCheck(WebBrowser.Document.QueryInterface(IPersistStreamInit, psi));
try
//OleCheck(psi.GetSizeMax(Size));
hHTMLText := GlobalAlloc(GPTR, BufSize);
if 0 = hHTMLText then RaiseLastWin32Error;

OleCheck(CreateStreamOnHGlobal(hHTMLText,True, Stream));
try
OleCheck(psi.Save(Stream, False));
Size := StrLen(PChar(hHTMLText));
SetLength(Result, Size);
CopyMemory(PChar(Result), Pointer(hHTMLText),Size);
finally
Stream := nil;
end;
finally
psi := nil;
end;
end;

/////////////////////////////////////////
Memo1.Text:=UTF8Decode(GetHtml(WebBrowser1));

[heikeyanxi]

楼上的几位已经说明白了

[xmoon1983]

昨天刚写了个从网页源代码中提取特定数据的函数，借宝地贴一下：

function GetStringA2B(const text, A, B: string; offsetA: INT32 = 1; offsetB: INT32 = -1): string;
var
  i, j: INT32;
  s: string;
begin
  Assert(offsetA <> 0);
  Assert(offsetB <> 0);

  i := PosEx(A, text);
  if i = 0 then
  begin
    Result := '';
    Exit;
  end;

  j := PosEx(B, text, i + 1);
  if j = 0 then
  begin
    Result := '';
    Exit;
  end;

  // 计算起点索引
  if offsetA > 0 then
    Inc(i, Length(A) + offsetA - 1)
  else
    Inc(i, offsetA);

  // 计算终点索引
  if offsetB > 0 then
    Inc(j, Length(B) + offsetB - 1)
  else
    Inc(j, offsetB);

  Assert(i < j);

  // copy时包含起点和终点
  Result := Copy(text, i, j - i + 1);
end;

[xmoon1983]

之前type了一下：

type
  INT32 = Integer;
  UINT32 = Cardinal;

[vcboys]

调用方法

function GetStringA2B(const text, A, B: string; offsetA: INT32 = 1; offsetB: INT32 = -1): string;

参数1:文本

参数2：起始字符串位置

参数3：结束字符串位置

另外本人也写了一个例子，效率比这位朋友的高些。。

function GetStr(strText,offset_s1,offset_s2:string):pchar;stdcall;
var
in_star,in_end:integer;
begin
in_star:=AnsiPos(offset_s1,strText)+length(offset_s1);
in_end:=AnsiPos(offset_s2,strtext);
Result:=pchar(copy(strtext,in_star,in_end-in_star));
end;

调用方法

i:integer;
s_temp:string;
begin
for i:= 0 to memo1.Lines.Count -1 do
begin
s_temp:= GetStr(memo1.Lines.Strings[i],'/b','.htm');
if length(s_temp) <> 0 then
begin
listbox1.Items.Add(s_temp);
end;
end;

[rslxy]

借这个帖子，找朋友帮偶优化下下面的代码。因为想写个蜘蛛，下面的代码是用来提取页面里的连接和图片的，对效率有要求：

function THTMLPageMan.GetLinks(Links: TStrings): integer;
var iLen, i: integer;
    sLink: string;
    boHref, boImg, boStart, boOther :Boolean; 
    ch  :char;
    p   :PChar;
    s :array[0..255] of char;
    label addchEnd;
begin
{
下面三个函数中用到而定义在其它地方的变量的说明：
FPageString:  定义在类 THTMLPageMan 中
FHost:        类中已经处理过的当前服务器地址，当前假定为www.baidu.com
FCurDir:      类中已经处理过的当前URL的路径(以'/'结束)，当前假定为www.baidu.com/download/

主要想分解HTML中的下列格式的字符串中提取：
下面5种格式都将提取出 http://www.baidu.com/download/test.rar
<a name='test' href="http://www.baidu.com/download/test.rar">
<a href='http://www.baidu.com/download/test.rar'>
<a href=http://www.baidu.com/download/test.rar>
<a href=/download/test.rar>
<a href=test.rar">

下面格式提取出  http://www.baidu.com/img/baidu_logo.gif
<img width=270 src=http://www.baidu.com/img/baidu_logo.gif height=129 usemap="#mp" id=lg>

}
   
   result := -1;
   Links.Clear;

   iLen := length (FPageString);

   boHref   := False;
   boImg    := False;
   boStart  := False;
   boOther  := False;

   sLink  := '';

   p  := PChar (FPageString);

   i  := -1;

   While True do begin
      Inc (i);
      if i >= iLen - 1 then break;
      ch  := p[i];
      if boOther then begin
         if ch = '>' then begin
            boOther := False;
         end ;
         Continue;
      end;

      if (not boHref) and (not boImg) then begin
         if i + 10 >= iLen then break;
         if p[i] <> '<' then
            continue;

         if p[i+1] in ['A', 'a'] then begin
            if p [i+2] = ' ' then begin
               boHref := True;
               boStart  := False;
               sLink  := '';
               Inc (i, 2);
               Continue;
            end;
         end else

         if p[i+1] in ['I', 'i'] then begin
            StrLCopy ( @s, @p[i], 5);
            s[5]  := #0;

            if SameText (s, '<img ') then begin
               boImg  := True;
               boStart  := False;
               sLink  := '';
               Inc (i, 4);
               Continue;
            end;
         end;

         boOther  := True;
         continue;
      end;

      if ch = '>' then begin
         goto addchEnd;
      end;

      if not BoStart then begin
         if boHref then begin
            StrLCopy ( @s, @p[i], 5);
            s[5]  := #0;
            if SameText (s, 'href=') then begin
               boStart  := True;
               Inc (i, 4);

            end;
         end;
         
         if boImg then begin
            StrLCopy ( @s, @p[i], 4);
            s[4]  := #0;
            if SameText (s, 'src=') then begin
               boStart  := True;
               Inc (i, 3);
            end;
         end;

         continue;
      end;

      if ch in [' ', '"', #39] then begin
         if sLink <> '' then begin

            goto addchEnd;
         end;
         Continue;
      end;

      if (ch = '.') and (p[i+1] = '/') then begin
         Inc (i);
         continue;
      end;

      sLink := sLink  + ch;
      continue;

      addchEnd:
      boHref  := False;
      boImg := False;
      boStart := False;

      if sLink <> '' then begin
            if not SameText ('http://', Copy (sLink, 1, 7)) then
            begin
               if sLink[1] <> '/' then
                  sLink := FCurDir + sLink
               else
                  sLink := FHost + sLink;
            end;
            Links.Add(sLink)
      end;

   end;

   result := Links.Count;
end;

[notebook800]

我写了一个使用wininet.dll发http协议的get请求的程序。把邮箱给我，我发给你。

[notebook800]

SessionThread_u 单元

unit SessionThread_u;

interface

uses Windows, Classes, WebWorld_u, Dialogs;

type
    TSessionThread = class(TThread)
    private
        ww_test: TWebWorld;
        dwFileSize: DWORD;
        dwFilePos: DWORD;
        bSucceed: LongBool;

        FszUrl:String;
    public
        constructor Create(CreateSuspended: Boolean);
        destructor Destroy; override;
    protected
        procedure Execute; override;

        procedure ProBarWork;
        procedure ProBarInit;
        procedure ProBarOver;

        procedure OnOpenWork(Sender: TObject; const dwFileSize: DWORD);
        procedure OnOverWork(Sender: TObject; const dwPosition: DWORD; var bTerminate: LongBool);
        procedure OnCloseWork(Sender: TObject; const bSucceed: LongBool);
    published
        property Url: string read FszUrl write FszUrl;
    end;

implementation

uses Unit1, SysUtils;

constructor TSessionThread.Create(CreateSuspended: Boolean);
begin
    ww_test := TWebWorld.Create;
    ww_test.OnOpenWork := OnOpenWork;
    ww_test.OnOverWork := OnOverWork;
    ww_test.OnCloseWork := OnCloseWork;

    inherited Create(CreateSuspended);
end;

destructor TSessionThread.Destroy;
begin
    if Assigned(ww_test) then ww_test.Free;
    inherited Destroy;
end;

procedure TSessionThread.Execute;
var
    lst: TStringList;
    i: Integer;
    seq: Integer;
begin
    FreeOnTerminate := true;
    lst := TStringList.Create;


    //ww_test.Url := 'http://www.baidu.com/img/baidu_logo.gif';
    ww_test.Url := FszUrl;
    ww_test.Get;

    exit;
    
    seq := 359018;
    for i := 1 to 34 do
    begin
        ww_test.Url := 'http://img9.zol.com.cn/desk_pic/big_360/' + IntToStr(seq) + '.jpg';
        ww_test.Get;
        inc(seq);
    end;
end;

procedure TSessionThread.ProBarWork;
begin
    Form1.ProgressBar1.Position := dwFilePos;
    Form1.Edit1.Text := IntToStr(dwFilePos) + '/' + IntToStr(dwFileSize);
end;

procedure TSessionThread.ProBarInit;
begin
    Form1.ProgressBar1.Max := dwFileSize;
    Form1.ProgressBar1.Min := 0;
    Form1.ProgressBar1.Position := 0;

    Form1.Edit1.Text := IntToStr(dwFilePos) + '/' + IntToStr(dwFileSize);
end;

procedure TSessionThread.ProBarOver;
begin

   // if bSucceed then
     //   ShowMessage('Download Succeed!')
    //else
       // ShowMessage('Download Terminate!');
end;

procedure TSessionThread.OnOpenWork(Sender: TObject; const dwFileSize: DWORD);
begin
    self.dwFileSize := dwFileSize;
    self.dwFilePos := 0;
    Synchronize(ProBarInit);
end;

procedure TSessionThread.OnOverWork(Sender: TObject; const dwPosition: DWORD; var bTerminate: LongBool);
begin
    self.dwFilePos := dwPosition;
    Synchronize(ProBarWork);
    bTerminate := self.Terminated;
end;

procedure TSessionThread.OnCloseWork(Sender: TObject; const bSucceed: LongBool);
begin
    self.bSucceed := bSucceed;
    Synchronize(ProBarOver);
end;

end.

[notebook800]

WebWorld_u 单元

unit WebWorld_u;

interface

uses Windows, Classes, WiniNet;

type
    TWWOpenWorkEvent = procedure(Sender: TObject; const dwFileSize: DWORD) of object;
    TWWOverWorkEvent = procedure(Sender: TObject; const dwPosition: DWORD; var bTerminate: LongBool) of object;
    TWWCloseWorkEvent = procedure(Sender: TObject; const bSucceed: LongBool) of object;

type
    TWebWorld = class
    private
        m_Session: HINTERNET;

        FOnOpenWork: TWWOpenWorkEvent;
        FOnOverWork: TWWOverWorkEvent;
        FOnCloseWork: TWWCloseWorkEvent;

        FURL: string;
        FServerName, FObjectName, FFielName: string;
    protected
        function InternetConnect: HINTERNET;
        function HttpOpenRequest(hConnect: HINTERNET): HINTERNET;
        function HttpSendRequest(hRequest: HINTERNET): LongBool;
        function InternetErrorDlg(hConnect: HINTERNET): DWORD;
        function HttpQueryInfo(hRequest: HINTERNET; var dwFileSize: DWORD): LongBool;
        function InternetReadFile(hRequest: HINTERNET; var dwPosition: DWORD; var dwBytesRead: DWORD; var lpBuffer: Pointer): LongBool;
        procedure SetUrl(const aUrl: string);
    published
        property OnOpenWork: TWWOpenWorkEvent read FOnOpenWork write FOnOpenWork;
        property OnOverWork: TWWOverWorkEvent read FOnOverWork write FOnOverWork;
        property OnCloseWork: TWWCloseWorkEvent read FOnCloseWork write FOnCloseWork;
        property Url: string read FURL write SetUrl;
    public
        constructor Create;
        destructor Destroy; override;

        procedure Get;
    end;

implementation

uses SysUtils;

constructor TWebWorld.Create;
var
    dwError: DWORD;
begin
    m_Session := InternetOpen(pChar('CV-BOM'), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
    dwError := GetLastError();

    if dwError <> 0 then ;
end;

destructor TWebWorld.Destroy;
begin
    InternetCloseHandle(m_Session);
end;

function TWebWorld.InternetConnect: HINTERNET;
var
    szServerName: string;
    hConnect: HINTERNET;
begin
    //szServerName := 'www.cosmoscape.com';
    //szServerName := 'topic.csdn.net';

    szServerName := FServerName;

    hConnect := WiniNet.InternetConnect(m_Session, pChar(szServerName),
        INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
    result := hConnect;
end;

function TWebWorld.HttpOpenRequest(hConnect: HINTERNET): HINTERNET;
var
    szVerb: string;
    szObjectName: string;
    szAcceptType: array[0..1] of pChar;

    hRequest: HINTERNET;
begin
    szVerb := 'GET';

    //szObjectName := 'content/download/solarsys.exe';
    //szObjectName := 't/20021116/12/1181472.html';

    szObjectName := FObjectName;


    szAcceptType[0] := pChar('*/*');
    szAcceptType[1] := nil;

    hRequest := WiniNet.HttpOpenRequest(hConnect, pChar(szVerb), pChar(szObjectName), HTTP_VERSION,
        nil, @szAcceptType, INTERNET_FLAG_DONT_CACHE or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_RELOAD or INTERNET_FLAG_EXISTING_CONNECT, 1);

    result := hRequest;
end;

function TWebWorld.HttpSendRequest(hRequest: HINTERNET): LongBool;
var
    szHeaders: string;
    dwHeadersLength: DWORD;

    bResponse: LongBool;
begin
    szHeaders := 'Content-Type: image/jpeg';
    dwHeadersLength := Length(szHeaders);
    bResponse := WiniNet.HttpSendRequest(hRequest, pChar(szHeaders), dwHeadersLength, nil, 0);

    result := bResponse;
end;

function TWebWorld.InternetErrorDlg(hConnect: HINTERNET): DWORD;
var
    vData: Pointer;
begin
    vData := nil;

    result := WiniNet.InternetErrorDlg(
        GetDesktopWindow, hConnect,
        ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED,
        FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_GENERATE_DATA or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS, //
        vData);
end;

function TWebWorld.HttpQueryInfo(hRequest: HINTERNET; var dwFileSize: DWORD): LongBool;
var
    dwBufferSize: DWORD;
    dwIndex: DWORD;

    InfoBuffer: array[1..32] of Byte;

    Info: string;
    bQuery: LongBool;
begin
    dwBufferSize := 32;
    dwIndex := 0;

    bQuery := WiniNet.HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, @InfoBuffer, dwBufferSize, dwIndex);

    if bQuery then
    begin
        Info := pChar(@InfoBuffer);
        dwFileSize := SysUtils.StrToInt(Info);
    end;

    result := bQuery;
end;

function TWebWorld.InternetReadFile(hRequest: HINTERNET; var dwPosition: DWORD; var dwBytesRead: DWORD; var lpBuffer: Pointer): LongBool;
var
    bRead: LongBool;

    Buffer: array[1..4096] of Byte;
begin
    result := false;
    bRead := WiniNet.InternetReadFile(hRequest, @Buffer, 4096, dwBytesRead);
    if not bRead then exit;
    inc(dwPosition, dwBytesRead);
    lpBuffer := @Buffer;
    result := true;
end;

procedure TWebWorld.Get;
var
    hConnect: HINTERNET;
    hRequest: HINTERNET;

    dwFileSize: DWORD;
    dwError: DWORD;
    dwPosition: DWORD;
    dwBytesRead: DWORD;

    bTerminate: LongBool;
    bSucceed: LongBool;

    lpBuffer: Pointer;

    f: file;
begin
    hConnect := InternetConnect;
    hRequest := HttpOpenRequest(hConnect);

    while not HttpSendRequest(hRequest) do
    begin
        dwError := GetLastError();
        if (dwError = ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED) and
            (InternetErrorDlg(hConnect) = ERROR_SUCCESS) then
            Continue;

        InternetCloseHandle(hRequest);
        InternetCloseHandle(hConnect);
        exit;
    end;

    if not HttpQueryInfo(hRequest, dwFileSize) then exit;


    try
        AssignFile(f, FFielName);
        Rewrite(f, 1);
        dwPosition := 0; //启始位置

        if Assigned(FOnOpenWork) then FOnOpenWork(self, dwFileSize);

        bSucceed := false;
        bTerminate := false;

        while true do
        begin
            if Assigned(FOnOverWork) then FOnOverWork(self, dwPosition, bTerminate);
            if bTerminate then Break;
            if not InternetReadFile(hRequest, dwPosition, dwBytesRead, lpBuffer) then Break;
            if dwBytesRead = 0 then
            begin
                bSucceed := true;
                Break;
            end;
            BlockWrite(f, lpBuffer^, dwBytesRead);
        end;
        if Assigned(FOnCloseWork) then FOnCloseWork(self, bSucceed);
        CloseFile(f);

    finally
        InternetCloseHandle(hRequest);
        InternetCloseHandle(hConnect);
    end;
end;

procedure TWebWorld.SetUrl(const aUrl: string);
var
    ls_Url: string;
begin
    self.FURL := aUrl;
    ls_Url := aUrl;
    if pos('http://', ls_Url) = 1 then System.Delete(ls_Url, 1, 7);

    self.FServerName := copy(ls_Url, 1, pos('/', ls_Url) - 1);
    System.Delete(ls_Url, 1, pos('/', ls_Url));
    self.FObjectName := ls_Url;
    self.FFielName := ExtractFileName(StringReplace(ls_Url, '/', '\', [rfReplaceAll]));
end;

end.

[wmjlt092965]

我也想要这方面的东西，上面的回帖看了有点晕