程式師世界 >> 編程語言 >> 更多編程語言 >> Delphi >> 一個多線程後台掃描的程序和源代碼

一個多線程後台掃描的程序和源代碼

編輯：Delphi

　　界面是防明小子的那個掃描工具寫的，算是學習多線程的一個例子把
　　
　　界面圖示：

　　http://www.wrsky.com/attachment/3_1875.jpg
　　
　　程序和源代碼：

　　http://downloads.2ccc.com/general/internet_lan/hnxyy_scan.rar

　　使用D7編寫，主要部分代碼：
　　
　　
　　//主界面部分
　　unit1.pas
　　
　　unit Unit1;
　　
　　interface
　　
　　uses
　　Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
　　Dialogs, StdCtrls, Tabs, ExtCtrls, ComCtrls, IdHTTP, Unit2;
　　
　　type
　　TForm1 = class(TForm)
　　 Label1: TLabel;
　　 Edit1: TEdit;
　　 Button1: TButton;
　　 TabSet1: TTabSet;
　　 StatusBar1: TStatusBar;
　　 ProgressBar1: TProgressBar;
　　 Panel1: TPanel;
　　 GroupBox1: TGroupBox;
　　 Memo1: TMemo;
　　 Edit2: TEdit;
　　 Button2: TButton;
　　 Button3: TButton;
　　 Button4: TButton;
　　 GroupBox2: TGroupBox;
　　 Memo2: TMemo;
　　 GroupBox3: TGroupBox;
　　 Memo3: TMemo;
　　 Button5: TButton;
　　 OpenDialog1: TOpenDialog;
　　 procedure TabSet1Click(Sender: TObject);
　　 procedure Button5Click(Sender: TObject);
　　 procedure Button2Click(Sender: TObject);
　　 procedure Button1Click(Sender: TObject);
　　 procedure Button4Click(Sender: TObject);
　　 procedure Button3Click(Sender: TObject);
　　private
　　 { Private declarations }
　　 //彈出信息框
　　 procedure MsgBox(strMsg: string);
　　 procedure ThreadExit(sender: TObject);
　　public
　　 { Public declarations }
　　end;
　　
　　var
　　Form1: TForm1;
　　Thread1: array of T1; // 定義線程數組
　　n: integer = 0;
　　bool: boolean = True;
　　
　　implementation
　　
　　{$R *.dfm}
　　
　　procedure TForm1.TabSet1Click(Sender: TObject);
　　begin
　　if TabSet1.TabIndex = 0 then
　　begin
　　 GroupBox2.Visible :=true;
　　 GroupBox3.Visible :=true;
　　 GroupBox1.Visible :=false;
　　 Panel1.Visible :=False;
　　end else
　　begin
　　 GroupBox2.Visible :=false;
　　 GroupBox3.Visible :=false;
　　 GroupBox1.Visible :=true;
　　 Panel1.Visible :=true;
　　end;
　　
　　end;
　　
　　procedure TForm1.Button5Click(Sender: TObject);
　　var
　　i:integer;
　　url:string;
　　begin
　　if Edit1.Text='' then
　　begin
　　 MsgBox('請輸入要檢測的網站地址！');
　　 exit;
　　end;
　　Memo3.Clear;
　　Memo2.Clear;
　　ProgressBar1.Min :=0;
　　ProgressBar1.Max :=Memo1.Lines.Count;
　　ProgressBar1.Step :=1;
　　ProgressBar1.Position :=0;
　　for i:=0 to Memo1.Lines.Count - 1 do
　　begin
　　 url :=trim(Edit1.Text)+Memo1.Lines;
　　 Memo3.Lines.Add(url);
　　 GroupBox3.Caption :='信息：已檢測'+inttostr(Memo3.Lines.Count)+'個頁面';
　　 ProgressBar1.StepIt;
　　 if CheckUrl(url) then
　　 begin
　　 Memo2.Lines.Add('該URL存在! - '+url);
　　 GroupBox2.Caption :='存在：共找到'+inttostr(Memo2.Lines.Count)+'條路徑';
　　 end;
　　end;
　　end;
　　
　　procedure TForm1.MsgBox(strMsg: string);
　　begin
　　Application.MessageBox(pchar(strMsg), '提示信息', mb_iconinformation);
　　end;
　　
　　procedure TForm1.Button2Click(Sender: TObject);
　　begin
　　if trim(Edit2.Text)<>'' then
　　 Memo1.Lines.Add(trim(Edit2.Text));
　　end;
　　
　　procedure TForm1.Button1Click(Sender: TObject);
　　var
　　i: integer;
　　Sum:integer;
　　begin
　　if bool then
　　begin
　　 Memo3.Clear;
　　 Memo2.Clear;
　　 n :=0;
　　 Sum :=Memo1.lines.count;
　　 SetLength(Thread1,Sum); // 動態設置線程的數量
　　 ProgressBar1.Min :=0;
　　 ProgressBar1.Max :=sum;
　　 ProgressBar1.Step :=1;
　　 ProgressBar1.Position :=0;
　　 for i := 0 to Sum - 1 do
　　 begin
　　 Thread1 := T1.Create(Memo1,Memo2,Memo3,i);
　　 Thread1.OnTerminate := ThreadExit;
　　 //ProgressBar1.StepIt;
　　 //sleep(30);
　　 end;
　　end;
　　bool := False; // 關閉開關
　　end;
　　
　　procedure TForm1.ThreadExit(sender: TObject);
　　begin
　　ProgressBar1.StepIt;
　　Memo3.Lines.Add(trim(Edit1.Text)+Memo1.Lines[n]);
　　GroupBox3.Caption :='信息：已檢測'+inttostr(Memo3.Lines.Count)+'個頁面';
　　inc(n); // 線程結束後自增1
　　if N = Memo1.lines.count then
　　begin
　　 bool := true; // 打開開關
　　 exit;
　　end;
　　end;
　　
　　procedure TForm1.Button4Click(Sender: TObject);
　　begin
　　if OpenDialog1.Execute then
　　 Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
　　end;
　　
　　procedure TForm1.Button3Click(Sender: TObject);
　　begin
　　Memo1.Lines.Delete(Memo1.Lines.Count-1);
　　end;
　　
　　end.
　　
　　//處理線程部分
　　unit2.pas
　　
　　
　　unit Unit2;
　　
　　interface
　　
　　uses
　　Classes,StdCtrls,Windows,SysUtils,wininet,IdHTTP;
　　
　　var
　　CS:TRTLCriticalSection; //定義全局臨界區
　　
　　type
　　T1 = class(TThread)
　　private
　　 TmpM1,TmpM2,TmpM3: TMemo;
　　 TmpNum: integer;
　　 Str :string;
　　 procedure DataMemo;
　　protected
　　 procedure Execute; override;
　　public
　　 constructor Create(M1,M2,M3: TMemo; Num: integer);
　　end;
　　
　　function Get(URL: string): boolean;
　　function CheckUrl(url: string; TimeOut: integer = 5000): boolean;
　　
　　implementation
　　
　　uses Unit1;
　　
　　{ T1 }
　　
　　constructor T1.Create(M1,M2,M3: TMemo; Num: integer);
　　begin
　　TmpNum := Num; // 傳遞參數
　　TmpM1 :=M1; // 綁定控件
　　TmpM2 :=M2;
　　TmpM3 :=M3;
　　FreeOnTerminate := True; // 自動刪除
　　InitializeCriticalSection(CS); //初始化臨界區
　　inherited Create(False); // 直接運行
　　end;
　　
　　function Get(URL: string): boolean;
　　var
　　IDHTTP: TIDHttp;
　　ss: String;
　　begin
　　Result:= False;
　　IDHTTP:= TIDHTTP.Create(nil);
　　try
　　 try
　　 idhttp.HandleRedirects:= true; //必須支持重定向否則可能出錯
　　 idhttp.ReadTimeout:= 30000; //超過這個時間則不再訪問
　　 ss:= IDHTTP.Get(URL);
　　 if IDHTTP.ResponseCode=200 then
　　 Result :=true;
　　 except
　　 end;
　　finally
　　 IDHTTP.Free;
　　end;
　　end;
　　
　　//====================== 判斷網址是否存在的函數 =======================
　　function CheckUrl(url: string; TimeOut: integer = 5000): 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;
　　
　　function GetBackSpaceCount(str:string):string;
　　var i,iCount:integer;
　　begin
　　 iCount :=50-length(str);
　　 for i:=0 to iCount-1 do
　　 begin
　　 Result :=Result+' ';
　　 end;
　　end;
　　
　　procedure T1.DataMemo;
　　begin
　　TmpM2.Lines.Add(str+GetBackSpaceCount(str)+'線程'+inttostr(TmpNum+1)+'檢測結果');
　　Form1.GroupBox2.Caption :='存在：共找到'+inttostr(TmpM2.Lines.Count)+'條路徑';
　　end;
　　
　　procedure T1.Execute;
　　begin
　　Str :=trim(Form1.Edit1.Text) + TmpM1.Lines[TmpNum];
　　EnterCriticalSection(cs); //進入臨界區
　　if CheckUrl(Str) then
　　begin
　　 Synchronize(DataMemo); // 同步
　　end;
　　LeaveCriticalSection(CS); //退出臨界區
　　//sleep(20); // 線程掛起;
　　end;
　　
　　end.
　　