分享
 
 
 

一个多线程后台扫描的程序和源代码

王朝delphi·作者佚名  2006-01-31
窄屏简体版  字體: |||超大  

界面是防明小子的那个扫描工具写的,算是学习多线程的一个例子把

界面图示:

http://www.wrsky.com/attachment/3_1875.jpg

程序和源代码:

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

使用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.

界面是防明小子的那个扫描工具写的,算是学习多线程的一个例子把

界面图示:

[url=http://www.wrsky.com/attachment/3_1875.jpg]http://www.wrsky.com/attachment/3_1875.jpg

程序和源代码:

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

使用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.

界面是防明小子的那个扫描工具写的,算是学习多线程的一个例子把

界面图示:

[url=http://www.wrsky.com/attachment/3_1875.jpg]http://www.wrsky.com/attachment/3_1875.jpg

程序和源代码:

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

使用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.

界面是防明小子的那个扫描工具写的,算是学习多线程的一个例子把

界面图示:

[url=http://www.wrsky.com/attachment/3_1875.jpg]http://www.wrsky.com/attachment/3_1875.jpg

程序和源代码:

http://downloads.2ccc.com/general/internet_lan/hnxyy_scan.rar[url=http://www.wrsky.com/job.php?action=download&pid=tpc&tid=9410&aid=1876][/url]

使用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.

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有