这是多线程部分源码
unit Unit_TSearch;interface
uses
Classes,inifiles,MSHTML,IdHTTP,Forms,StdCtrls,Dialogs,Controls,
SysUtils,ShDocVw,Variants,ActiveX,StrUtils,
AllFunction{部分函数};Type
TSearch = class(TThread)
private MyINI:Tinifile;
OldHTML,NewHTML:String; //新源码,旧源码
Links_BBS,Links_All,Links_URLKey:TStringList; URL:String; //搜索URL
SearchKey,SearchType:String; //搜索关键字,类型
SearchStart:Integer; //搜索开始位置 bShowTip:Boolean; //搜索提示
protected
Procedure Search;
Procedure GetURL;
Procedure GetKey(iType:integer);
Procedure OpenURL;
Procedure GetAllLinks;
Procedure GetLinks;
Procedure SaveURLtoFile;
public
constructor Create(sKey,sType:String;CreateSuspended: Boolean);
destructor Destroy;override;
Procedure Execute;override;
End;implementation
{------------------------------------------------------------------------------}
constructor TSearch.Create(sKey,sType:String;CreateSuspended: Boolean);
Begin
SearchKey:=UpperCase(sKey);
SearchType:=UpperCase(sType);
SearchStart:= -10;
MyINI:=Tinifile.Create(GetAppPath+'BBS.ini');
Links_BBS:=TStringList.Create;
Links_All:=TStringList.Create;
Links_URLKey:=TStringList.Create;
inherited Create(CreateSuspended);
Priority := tpIdle;
End;
{------------------------------------------------------------------------------}
destructor TSearch.Destroy;
Begin
MyINI.Free;
Links_BBS.Destroy;
Links_All.Destroy;
Links_URLKey.Destroy;
inherited Destroy;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.Execute;
Begin
while not Terminated do
Begin
Synchronize(Search);
Application.ProcessMessages;
End;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.Search;
Begin
GetURL;
OpenURL;
GetAllLinks;
GetLinks;
//SaveURLtoFile;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.GetURL;
Begin
if (Myini.ReadInteger('Search','Completed',1)=0) and (NOT bShowTip) Then // 0未完成 1完成
Begin
if MessageDlg('上次搜索未完成,是否载入上次搜索进度?',mtInformation,[mbYes,mbNo],0) = mrYes Then
GetKey(0)
Else
GetKey(1);
End
Else
GetKey(1); if SearchType='BAIDU' Then
URL:='http://www.baidu.com/s?lm=0&si=&rn=10&ie=gb2312&ct=0&wd='+URLEncode(SearchKey)+'&pn='+InttoStr(SearchStart)+'&cl=3'
Else if SearchType='GOOGLE' Then
URL:='http://www.google.com/search?q='+URLEncode(SearchKey)+'&hl=zh-CN&lr=&newwindow=1&start='+Inttostr(SearchStart)+'&sa=N';
End;
{------------------------------------------------------------------------------}
Procedure TSearch.GetKey(iType:integer);
Begin
Case iType OF
0:Begin
//载入
SearchKey:=MyINI.ReadString('Search','Key','论坛');
SearchType:=MyINI.ReadString('Search','Type','BAIDU');
SearchStart:=MyINI.ReadInteger('Search','Start',-10);
End;
1:Begin
//不载入
MyINI.WriteString('Search','Key',SearchKey);
MyINI.WriteString('Search','Type',SearchType);
End;
End;
bShowTip:=True;
SearchStart:=SearchStart+10;
Myini.WriteInteger('Search','Start',SearchStart);
Myini.WriteInteger('Search','Completed',0);
End;
{------------------------------------------------------------------------------}
Procedure TSearch.OpenURL;
var
IdHTTP:TidHTTP;
Begin
IdHTTP:=TidHTTP.Create(Application);
Try
NewHTML:=IdHTTP.Get(URL);
Finally
IdHTTP.Free;
End; //判断是否结束
if (Length(NewHTML)>0) and (Length(OldHTML)>0) Then
Begin
if Length(NewHTML)=Length(OldHTML) Then
Begin
MyINI.WriteInteger('Search','Completed',1);
bShowTip:=False;
OldHTML:='';
ShowMessage('搜索完成');
Self.Terminate;
End
Else
OldHTML:=NewHTML;
End
Else
OldHTML:=NewHTML;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.GetAllLinks;
var
IDoc:IHtmlDocument2;
Link:IHTMLElement;
MyVariant:oleVariant;
WB:TWebBrowser;
iTmp,iLinkLength:integer;
sLink:String;
Begin
if Length(NewHTML)<500 Then EXIT; WB:=TWebBrowser.Create(NIL);
WB.Silent:=True; Try
WB.Navigate('about:blank');
IDoc:=WB.Document as IHtmlDocument2; if (Assigned(IDoc)) then
Begin
MyVariant:=VarArrayCreate([0,0],varVariant);
MyVariant[0]:=NewHTML;
IDoc.Write(PSafeArray(TVarData(MyVariant).VArray));
iLinkLength:=IDoc.Links.Length; if iLinkLength<2 Then
Begin
WB.Free;
EXIT;
End; for iTmp:=0 to (iLinkLength - 1) do
Begin
Link:=IDoc.Links.Item(iTmp,0) as IHTMLElement;
sLink:=Link.ToString; if Pos('about:blank',sLink)>0 Then
sLink:=URL+'/'+MidBStr(sLink,12,Length(sLink));
if Pos('javascript',sLink)>0 Then Continue;
Links_All.Add(sLink);
End;
End;
Finally
IDoc.close;
WB.Free;
End;
End;
{------------------------------------------------------------------------------}
Procedure Tsearch.GetLinks;
var
SearchKey1,SearchKey2:String;
i:Integer;
sTmp:String;
Label DELStart;
Begin
if SearchType='BAIDU' then
SearchKey1:='BAIDU'
Else if SearchType='GOOGLE' then
Begin
SearchKey1:='GOOGLE';
SearchKey2:='72.14.235.104';
end; DELStart:
if Links_All.Count<1 then EXIT; For i:=0 to Links_All.Count - 1 DO
Begin
sTmp:=UpperCase(Links_All.Strings[i]);
if Pos(SearchKey1,sTmp)>0 then
Begin
Links_All.Delete(i);
Goto DELStart;
End
Else
Begin
if SearchKey2<>'' then
Begin
if Pos(SearchKey2,sTmp)>0 Then
Begin
Links_All.Delete(i);
Goto DELStart;
End
Else
Begin
RightPos('/',sTmp);
Links_BBS.Add(LowerCase(sTmp));
Links_All.Delete(i);
Goto DELStart;
End;
End
Else
Begin
RightPos('/',sTmp);
Links_BBS.Add(LowerCase(sTmp));
Links_All.Delete(i);
Goto DELStart;
End;
End;
End;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.SaveURLtoFile;
Begin
Links_BBS.SaveToFile(GetAppPath+'SearchBBS.txt');
End;
{------------------------------------------------------------------------------}
end.
主界面调用
procedure TForm1.Button_SerchClick(Sender: TObject);
begin
Button_SearchStop.Enabled:=True;
TMySearch:=TSearch.Create(Edit_SearchKey.Text,ComboBox_Search.Text,False);
end;procedure TForm1.Button_SearchStopClick(Sender: TObject);
begin
if Button_SearchStop.Caption='暂停' Then
Begin
Button_SearchStop.Caption:='继续';
TMySearch.Suspend;
End
Else
Begin
Button_SearchStop.Caption:='暂停';
TMySearch.Resume;
End;
end;
unit Unit_TSearch;interface
uses
Classes,inifiles,MSHTML,IdHTTP,Forms,StdCtrls,Dialogs,Controls,
SysUtils,ShDocVw,Variants,ActiveX,StrUtils,
AllFunction{部分函数};Type
TSearch = class(TThread)
private MyINI:Tinifile;
OldHTML,NewHTML:String; //新源码,旧源码
Links_BBS,Links_All,Links_URLKey:TStringList; URL:String; //搜索URL
SearchKey,SearchType:String; //搜索关键字,类型
SearchStart:Integer; //搜索开始位置 bShowTip:Boolean; //搜索提示
protected
Procedure Search;
Procedure GetURL;
Procedure GetKey(iType:integer);
Procedure OpenURL;
Procedure GetAllLinks;
Procedure GetLinks;
Procedure SaveURLtoFile;
public
constructor Create(sKey,sType:String;CreateSuspended: Boolean);
destructor Destroy;override;
Procedure Execute;override;
End;implementation
{------------------------------------------------------------------------------}
constructor TSearch.Create(sKey,sType:String;CreateSuspended: Boolean);
Begin
SearchKey:=UpperCase(sKey);
SearchType:=UpperCase(sType);
SearchStart:= -10;
MyINI:=Tinifile.Create(GetAppPath+'BBS.ini');
Links_BBS:=TStringList.Create;
Links_All:=TStringList.Create;
Links_URLKey:=TStringList.Create;
inherited Create(CreateSuspended);
Priority := tpIdle;
End;
{------------------------------------------------------------------------------}
destructor TSearch.Destroy;
Begin
MyINI.Free;
Links_BBS.Destroy;
Links_All.Destroy;
Links_URLKey.Destroy;
inherited Destroy;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.Execute;
Begin
while not Terminated do
Begin
Synchronize(Search);
Application.ProcessMessages;
End;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.Search;
Begin
GetURL;
OpenURL;
GetAllLinks;
GetLinks;
//SaveURLtoFile;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.GetURL;
Begin
if (Myini.ReadInteger('Search','Completed',1)=0) and (NOT bShowTip) Then // 0未完成 1完成
Begin
if MessageDlg('上次搜索未完成,是否载入上次搜索进度?',mtInformation,[mbYes,mbNo],0) = mrYes Then
GetKey(0)
Else
GetKey(1);
End
Else
GetKey(1); if SearchType='BAIDU' Then
URL:='http://www.baidu.com/s?lm=0&si=&rn=10&ie=gb2312&ct=0&wd='+URLEncode(SearchKey)+'&pn='+InttoStr(SearchStart)+'&cl=3'
Else if SearchType='GOOGLE' Then
URL:='http://www.google.com/search?q='+URLEncode(SearchKey)+'&hl=zh-CN&lr=&newwindow=1&start='+Inttostr(SearchStart)+'&sa=N';
End;
{------------------------------------------------------------------------------}
Procedure TSearch.GetKey(iType:integer);
Begin
Case iType OF
0:Begin
//载入
SearchKey:=MyINI.ReadString('Search','Key','论坛');
SearchType:=MyINI.ReadString('Search','Type','BAIDU');
SearchStart:=MyINI.ReadInteger('Search','Start',-10);
End;
1:Begin
//不载入
MyINI.WriteString('Search','Key',SearchKey);
MyINI.WriteString('Search','Type',SearchType);
End;
End;
bShowTip:=True;
SearchStart:=SearchStart+10;
Myini.WriteInteger('Search','Start',SearchStart);
Myini.WriteInteger('Search','Completed',0);
End;
{------------------------------------------------------------------------------}
Procedure TSearch.OpenURL;
var
IdHTTP:TidHTTP;
Begin
IdHTTP:=TidHTTP.Create(Application);
Try
NewHTML:=IdHTTP.Get(URL);
Finally
IdHTTP.Free;
End; //判断是否结束
if (Length(NewHTML)>0) and (Length(OldHTML)>0) Then
Begin
if Length(NewHTML)=Length(OldHTML) Then
Begin
MyINI.WriteInteger('Search','Completed',1);
bShowTip:=False;
OldHTML:='';
ShowMessage('搜索完成');
Self.Terminate;
End
Else
OldHTML:=NewHTML;
End
Else
OldHTML:=NewHTML;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.GetAllLinks;
var
IDoc:IHtmlDocument2;
Link:IHTMLElement;
MyVariant:oleVariant;
WB:TWebBrowser;
iTmp,iLinkLength:integer;
sLink:String;
Begin
if Length(NewHTML)<500 Then EXIT; WB:=TWebBrowser.Create(NIL);
WB.Silent:=True; Try
WB.Navigate('about:blank');
IDoc:=WB.Document as IHtmlDocument2; if (Assigned(IDoc)) then
Begin
MyVariant:=VarArrayCreate([0,0],varVariant);
MyVariant[0]:=NewHTML;
IDoc.Write(PSafeArray(TVarData(MyVariant).VArray));
iLinkLength:=IDoc.Links.Length; if iLinkLength<2 Then
Begin
WB.Free;
EXIT;
End; for iTmp:=0 to (iLinkLength - 1) do
Begin
Link:=IDoc.Links.Item(iTmp,0) as IHTMLElement;
sLink:=Link.ToString; if Pos('about:blank',sLink)>0 Then
sLink:=URL+'/'+MidBStr(sLink,12,Length(sLink));
if Pos('javascript',sLink)>0 Then Continue;
Links_All.Add(sLink);
End;
End;
Finally
IDoc.close;
WB.Free;
End;
End;
{------------------------------------------------------------------------------}
Procedure Tsearch.GetLinks;
var
SearchKey1,SearchKey2:String;
i:Integer;
sTmp:String;
Label DELStart;
Begin
if SearchType='BAIDU' then
SearchKey1:='BAIDU'
Else if SearchType='GOOGLE' then
Begin
SearchKey1:='GOOGLE';
SearchKey2:='72.14.235.104';
end; DELStart:
if Links_All.Count<1 then EXIT; For i:=0 to Links_All.Count - 1 DO
Begin
sTmp:=UpperCase(Links_All.Strings[i]);
if Pos(SearchKey1,sTmp)>0 then
Begin
Links_All.Delete(i);
Goto DELStart;
End
Else
Begin
if SearchKey2<>'' then
Begin
if Pos(SearchKey2,sTmp)>0 Then
Begin
Links_All.Delete(i);
Goto DELStart;
End
Else
Begin
RightPos('/',sTmp);
Links_BBS.Add(LowerCase(sTmp));
Links_All.Delete(i);
Goto DELStart;
End;
End
Else
Begin
RightPos('/',sTmp);
Links_BBS.Add(LowerCase(sTmp));
Links_All.Delete(i);
Goto DELStart;
End;
End;
End;
End;
{------------------------------------------------------------------------------}
Procedure TSearch.SaveURLtoFile;
Begin
Links_BBS.SaveToFile(GetAppPath+'SearchBBS.txt');
End;
{------------------------------------------------------------------------------}
end.
主界面调用
procedure TForm1.Button_SerchClick(Sender: TObject);
begin
Button_SearchStop.Enabled:=True;
TMySearch:=TSearch.Create(Edit_SearchKey.Text,ComboBox_Search.Text,False);
end;procedure TForm1.Button_SearchStopClick(Sender: TObject);
begin
if Button_SearchStop.Caption='暂停' Then
Begin
Button_SearchStop.Caption:='继续';
TMySearch.Suspend;
End
Else
Begin
Button_SearchStop.Caption:='暂停';
TMySearch.Resume;
End;
end;
去不去掉Synchronize和主程序停顿没有关系吧??
建议如果工作线程不涉及GUI操作,就不要用Synchronize,或者直接用API创建线程函数执行更方便。
zhoutler
是对的/ 去不去掉Synchronize