FindTh.pas
资源名称:delphi.rar [点击查看]
上传用户:fh681027
上传日期:2022-07-23
资源大小:1959k
文件大小:3k
源码类别:
Delphi控件源码
开发平台:
Delphi
- unit FindTh;
- interface
- uses
- Classes, IdComponent, SysUtils, IdHTTP;
- type
- TFindWebThread = class(TThread)
- protected
- Addr, Text, Status: string;
- procedure Execute; override;
- procedure AddToList;
- procedure ShowStatus;
- procedure GrabHtml;
- procedure HtmlToList;
- procedure HttpWork (Sender: TObject;
- AWorkMode: TWorkMode; const AWorkCount: Integer);
- public
- strUrl: string;
- strRead: string;
- end;
- implementation
- { TFindWebThread }
- uses
- WebFindF;
- procedure TFindWebThread.AddToList;
- begin
- if Form1.ListBox1.Items.IndexOf (Addr) < 0 then
- begin
- Form1.ListBox1.Items.Add (Addr);
- Form1.DetailsList.Add (Text);
- end;
- end;
- procedure TFindWebThread.Execute;
- begin
- GrabHtml;
- HtmlToList;
- Status := 'Done with ' + StrUrl;
- Synchronize (ShowStatus);
- end;
- procedure TFindWebThread.GrabHtml;
- var
- Http1: TIdHTTP;
- begin
- Status := 'Sending query: ' + StrUrl;
- Synchronize (ShowStatus);
- Http1 := TIdHTTP.Create (nil);
- try
- Http1.OnWork := HttpWork;
- strRead := Http1.Get (StrUrl);
- finally
- Http1.Free;
- end;
- end;
- procedure TFindWebThread.HtmlToList;
- var
- strAddr, strText: string;
- nText: integer;
- nBegin, nEnd: Integer;
- begin
- Status := 'Elaborating data for: ' + StrUrl;
- Synchronize (ShowStatus);
- strRead := LowerCase (strRead);
- repeat
- // find the initial part HTTP reference
- nBegin := Pos ('href=http', strRead);
- if nBegin <> 0 then
- begin
- // get the remaining part of the string, starting with 'http'
- strRead := Copy (strRead, nBegin + 5, 1000000);
- // find the end of the HTTP reference
- nEnd := Pos ('>', strRead);
- strAddr := Copy (strRead, 1, nEnd - 1);
- // move on
- strRead := Copy (strRead, nEnd + 1, 1000000);
- // add the URL if 'google' is not in it
- if Pos ('google', strAddr) = 0 then
- begin
- nText := Pos ('</a>', strRead);
- strText := copy (strRead, 1, nText - 1);
- // remove cached references and duplicates
- if (Pos ('cached', strText) = 0) then
- begin
- Addr := strAddr;
- Text := strText;
- AddToList;
- end;
- end;
- end;
- until nBegin = 0;
- end;
- procedure TFindWebThread.HttpWork(Sender: TObject; AWorkMode: TWorkMode;
- const AWorkCount: Integer);
- begin
- Status := 'Received ' + IntToStr (AWorkCount) + ' for ' + strUrl;
- Synchronize (ShowStatus);
- end;
- procedure TFindWebThread.ShowStatus;
- begin
- Form1.StatusBar1.SimpleText := Status;
- end;
- end.