开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
FindTh.pas
资源名称：delphi.rar　[点击查看]
上传用户：fh681027
上传日期：2022-07-23
资源大小：1959k
文件大小：3k
源码类别：

Delphi控件源码

开发平台：

Delphi

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