{
  --------------   線程部分   ----------------
   程序制作:明小子
   使用工具: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.