unit2.pas

明小子旁注Domain3.0和Domain2.2两个版本源码

{
  --------------   线程部分   ----------------
   程序制作:明小子
   使用工具:Delphi 7.0
   程序原本于11.16日编写完毕,之后因为检测速度的问题
   所以代码重新写了一遍,同时采用了多线的程检测方式!
  ---------------------------------------------
}
unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, Psock, NMHttp, StdCtrls, OleCtrls, SHDocVw, ComCtrls,
  TFlatListBoxUnit, TFlatCheckBoxUnit, TFlatComboBoxUnit, TFlatEditUnit,
  ExtCtrls, TFlatSpeedButtonUnit, TFlatPanelUnit, TFlatSplitterUnit,
  Buttons, TFlatRadioButtonUnit, ImgList, Menus, TFlatProgressBarUnit,
  CheckLst,shellapi,wininet;

type
  T1 = class(TThread)
  private
    Num1:integer;           //记录线程

    ReSum:integer;          //记录查询结果数量
    procedure UpDateResult; //线程同步
  protected
    procedure Execute; override;
  public
    constructor create(Num:integer);

  end;

implementation


uses Unit1;

var
  CS:TRTLCriticalSection;    //定义全局临界区
  FlagTH:INTEGER=0;
  FlagTH2:INTEGER=0;

//=========================== 构造线程函数 ============================
constructor T1.create(Num:integer);
begin
     FlagTH:=0;
     FlagTH2:=0;
  Num1:=Num;                     //传递参数值
  FreeonTerminate:=True;         //运行完毕自己删除
  InitializeCriticalSection(CS); //初始化临界区
  inherited Create(false);       //创建后直接运行
end;//----------------------------- END -------------------------------

//====================== 判断网址是否存在的函数 =======================
function CheckUrl(url: string; TimeOut: integer = 50): boolean;
var
  hSession, hfile, hRequest: hInternet;
  dwindex, dwcodelen: dword;
  dwcode: array[1..20] of char;
  res: pchar;
  re: integer;
  Err1: integer;
  j: integer;
begin
  if pos('http://', lowercase(url)) = 0 then
    url := 'http://' + url;
  Result := false;
  InternetSetOption(hSession, Internet_OPTION_CONNECT_TIMEOUT, @TimeOut, 4);
  hSession := InternetOpen('Mozilla/4.0', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
   //设置超时
  if assigned(hsession) then
  begin
    j := 1;
    while true do
    begin
      hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
   if hfile = nil then
      begin
        j := j + 1;
        Err1 := GetLastError;
        if j > 5 then break;
        if (Err1 <> 12002) or (Err1 <> 12152) then break;
        sleep(2);
      end
      else begin
        break;
      end;
    end;
    dwIndex := 0;
    dwCodeLen := 10;
    HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
    res := pchar(@dwcode);
    re := strtointdef(res, 404);
    case re of
      400..450: result := false;
    else result := true;
    end;
    if assigned(hfile) then
      InternetCloseHandle(hfile);
      InternetCloseHandle(hsession);
    end;
end;//------------------------------ END ------------------------------

procedure T1.UpDateResult;                                //提示部分
begin
With Form1.ListView1.Items.Add do
  begin
   Caption:=Form1.Lsb_Site.Items[Num1];
   SubItems.Add('该URL存在! - '+inttostr(Form1.ListView1.Items.Count));
  end; //With
end;

//============================= 主要执行部分 ==========================
procedure T1.Execute;
var
 Str:String;
 x:integer;
begin
Try
   Str:='';
   X:=0;                                                        //每次创建时初始化
   Str:=Form1.Lsb_Site.items[Num1];                             //保存对应索引的值
   EnterCriticalSection(cs);                                    //进入临界区
   for X := 0 to Form1.CLBox.Items.Count -1 do                  //循环CLBox的个数
      begin
          if Form1.CLBox.Checked[X]=True then                   //是否被选中
          begin
          Form1.Lsb_Site.Items[Num1]:=Str+Form1.CLBox.Items[X]; //组合起来
          if CheckUrl(Form1.Lsb_Site.Items[Num1]) then          //是否存在
          begin
          Synchronize(UpDateResult);                            //线程同步
          end;  //if 2
          end;  //if 1

          LeaveCriticalSection(CS);                             //退出临界区
          Sleep(20); //挂起
      end; //for
Except
End;
     Sleep(5); //挂起
     FreeOnTerminate:=True;
     if FreeOnTerminate=True then
     begin
     FlagTH:=FlagTH+1;
     FlagTH2:=Form1.Lsb_Site.Items.Count-FlagTH;
     Form1.Label6.Caption:='  -- 目前还有'+inttostr(FlagTH2)+'个线程未检测完毕! --';
     if (FlagTH2=0) or (FlagTh>Form1.Lsb_Site.Items.Count-2) then
     begin
     Form1.Ani.Stop;
     Form1.Ani.Visible:=False;
     Form1.Label6.Caption:='        -- 已全部检测完毕! --';
     end;
     end;


     if (Form1.Lsb_Site.Items.Count=1) and (FreeOnTerminate=True) then
     begin
     Form1.Ani.Stop;
     Form1.Ani.Visible:=False;
     Form1.Label6.Caption:='        -- 已全部检测完毕! --';
     end;

end;//------------------------------ END ------------------------------
end.