unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls, XPMan, ExtCtrls, ActnMan, ActnColorMaps,
IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP,unit2;
type
TForm1 = class(TForm)
Panel1: TPanel;
Edit1: TEdit;
Label1: TLabel;
XPManifest1: TXPManifest;
Button1: TButton;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
RadioGroup1: TRadioGroup;
Memo1: TMemo;
RadioGroup2: TRadioGroup;
Memo2: TMemo;
Panel2: TPanel;
Memo3: TMemo;
Edit2: TEdit;
Button2: TButton;
Button3: TButton;
Button4: TButton;
IdHTTP1: TIdHTTP;
ProgressBar1: TProgressBar;
StatusBar1: TStatusBar;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Button5: TButton;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
{ Private declarations }
procedure ThreadExit(sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
Thread1:array of ScanThread;
n:integer=0;
bool:boolean=true;
implementation
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject);
begin
if trim(edit2.Text)<>'' then
Memo3.Lines.Add(trim(edit2.Text));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
Sum:integer;
begin
if edit1.Text='' then
begin
messagebox(handle,'URL不能为空','提示',MB_OK);
exit;
end
else
if bool then
begin
Memo1.Clear;
Memo2.Clear;
n :=0;
Sum :=Memo3.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[i] := scanthread.Create(Memo3,Memo2,Memo1,i);
Thread1[i].OnTerminate := ThreadExit;
end;
end;
bool := False;
end;
procedure TForm1.ThreadExit(sender: TObject);
begin
ProgressBar1.StepIt;
Memo1.Lines.Add(trim(Edit1.Text)+Memo3.Lines[n]);
inc(n);
if N = Memo3.lines.count then
begin
bool := true;
exit;
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
if opendialog1.Execute then
begin
Memo3.Lines.LoadFromFile(Opendialog1.FileName);
end;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
if savedialog1.Execute then
Memo2.Lines.SaveToFile(savedialog1.FileName);
end;
end.
unit Unit2;
interface
uses
Classes,StdCtrls,Windows,SysUtils,wininet,IdHTTP;
var
CS:TRTLCriticalSection; //定义全局临界区
type
ScanThread = class(TThread)
private
{ Private declarations }
TM1,TM2,Tm3:TMemo;
TMNum:Integer;
str:string;
protected
procedure Execute; override;
procedure datamemo;
public
constructor Create(M1,M2,M3:TMemo;num:integer);
end;
function CheckUrl(url: string; TimeOut: integer = 5000): boolean;
function Get(Url:string):boolean;
implementation
{ Important: Methods and properties of objects in visual components can only be
used in a method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure ScanThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end; }
{ ScanThread }
uses unit1;
constructor ScanThread.Create(M1,M2,M3:TMemo;Num:integer);
begin
TM1:=M1;
TM2:=M2;
TM3:=M3;
TMNum:=Num;
FreeonTerminate:=True; //直接删除线程
InitializeCriticalSection(CS); //初始化临界区
inherited Create(False); // 直接运行
end;
function get(Url:string):boolean;
var
IdHttp:TIdHttp;
URLData:String;
begin
Result:=false;
IdHttp:=Tidhttp.Create(nil);
try
try
IdHttp.HandleRedirects:=True; //支持重定向
IdHttp.ReadTimeout:=30000; //访问延时，超过这个时间便不再访问
UrlData:=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); //创建intenet连接会话对象
//设置超时
if assigned(hsession) then //判断hsession是否为nil,为nil返回false
begin
j := 1;
while true do
begin
hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);//建立intenet连接
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 scanthread.datamemo;
begin
TM2.Lines.Add(str+GetBackSpaceCount(str)+'存在');
Form1.Radiogroup2.Caption :='存在：共找到'+inttostr(TM2.Lines.Count)+'条路径';
end;
procedure ScanThread.Execute;
begin
{ Place thread code here }
Str :=trim(Form1.Edit1.Text) + TM1.Lines[TmNum];
EnterCriticalSection(cs); //进入临界区
if CheckUrl(Str) then
begin
Synchronize(DataMemo); // 同步
end;
LeaveCriticalSection(CS); //退出临界区
end;
end.