FindTh.pas
上传用户:fh681027
上传日期:2022-07-23
资源大小:1959k
文件大小:3k
源码类别:

Delphi控件源码

开发平台:

Delphi

  1. unit FindTh;
  2. interface
  3. uses
  4.   Classes, IdComponent, SysUtils, IdHTTP;
  5. type
  6.   TFindWebThread = class(TThread)
  7.   protected
  8.     Addr, Text, Status: string;
  9.     procedure Execute; override;
  10.     procedure AddToList;
  11.     procedure ShowStatus;
  12.     procedure GrabHtml;
  13.     procedure HtmlToList;
  14.     procedure HttpWork (Sender: TObject;
  15.       AWorkMode: TWorkMode; const AWorkCount: Integer);
  16.   public
  17.     strUrl: string;
  18.     strRead: string;
  19.   end;
  20. implementation
  21. { TFindWebThread }
  22. uses
  23.   WebFindF;
  24. procedure TFindWebThread.AddToList;
  25. begin
  26.   if Form1.ListBox1.Items.IndexOf (Addr) < 0 then
  27.   begin
  28.     Form1.ListBox1.Items.Add (Addr);
  29.     Form1.DetailsList.Add (Text);
  30.   end;
  31. end;
  32. procedure TFindWebThread.Execute;
  33. begin
  34.   GrabHtml;
  35.   HtmlToList;
  36.   Status := 'Done with ' + StrUrl;
  37.   Synchronize (ShowStatus);
  38. end;
  39. procedure TFindWebThread.GrabHtml;
  40. var
  41.   Http1: TIdHTTP;
  42. begin
  43.   Status := 'Sending query: ' + StrUrl;
  44.   Synchronize (ShowStatus);
  45.   Http1 := TIdHTTP.Create (nil);
  46.   try
  47.     Http1.OnWork := HttpWork;
  48.     strRead := Http1.Get (StrUrl);
  49.   finally
  50.     Http1.Free;
  51.   end;
  52. end;
  53. procedure TFindWebThread.HtmlToList;
  54. var
  55.   strAddr, strText: string;
  56.   nText: integer;
  57.   nBegin, nEnd: Integer;
  58. begin
  59.   Status := 'Elaborating data for: ' + StrUrl;
  60.   Synchronize (ShowStatus);
  61.   strRead := LowerCase (strRead);
  62.   repeat
  63.     // find the initial part HTTP reference
  64.     nBegin := Pos ('href=http', strRead);
  65.     if nBegin <> 0 then
  66.     begin
  67.       // get the remaining part of the string, starting with 'http'
  68.       strRead := Copy (strRead, nBegin + 5, 1000000);
  69.       // find the end of the HTTP reference
  70.       nEnd := Pos ('>', strRead);
  71.       strAddr := Copy (strRead, 1, nEnd - 1);
  72.       // move on
  73.       strRead := Copy (strRead, nEnd + 1, 1000000);
  74.       // add the URL if 'google' is not in it
  75.       if Pos ('google', strAddr) = 0 then
  76.       begin
  77.         nText := Pos ('</a>', strRead);
  78.         strText := copy (strRead, 1, nText - 1);
  79.         // remove cached references and duplicates
  80.         if (Pos ('cached', strText) = 0) then
  81.         begin
  82.           Addr := strAddr;
  83.           Text := strText;
  84.           AddToList;
  85.         end;
  86.       end;
  87.     end;
  88.   until nBegin = 0;
  89. end;
  90. procedure TFindWebThread.HttpWork(Sender: TObject; AWorkMode: TWorkMode;
  91.   const AWorkCount: Integer);
  92. begin
  93.   Status := 'Received ' + IntToStr (AWorkCount) + ' for ' + strUrl;
  94.   Synchronize (ShowStatus);
  95. end;
  96. procedure TFindWebThread.ShowStatus;
  97. begin
  98.   Form1.StatusBar1.SimpleText := Status;
  99. end;
  100. end.