多线程问题帮我看看，急， 由代码(0分)

  • 主题发起人 主题发起人 qddmh
  • 开始时间 开始时间
Q

qddmh

Unregistered / Unconfirmed
GUEST, unregistred user!
为什么当一个线程的IDhttp.Get(URL)的URL为坏地址时, 当前线程自动Terminate
并且Execute中的SendMessage(发的信息也不被相应), 应怎样解决此问题???
//帮忙看一下下面程序
//* Memo1: 动态变化的多线程任务列表,当执行完一个就删除 */
//* Memo2: 全部多线程任务列表 */
//* Memo3: 用于显示 */
//* Edit1: 存放线程数 */
//* Edit2: 起始地址 */
//* Http: TIdHttp */
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, Unit2, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP;
const
WM_ThreadDoneMsg = WM_User + 8;
type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
Button1: TButton;
Memo1: TMemo;
Memo2: TMemo;
Button4: TButton;
Memo3: TMemo;
Edit1: TEdit;
Label1: TLabel;
HTTP: TIdHTTP;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure HtmlToListHttp(strFirstUrl: string);
function GetSubString(myString: string;last: integer): string;
procedure ThreadDone(var AMessage : TMessage);
message WM_ThreadDoneMsg;
// Message to be sent back from thread when itsdo
ne
public
{ Public declarations }
CurrentTask: integer;
//当前第几个任务
TotalTask: integer;
// 总共多少个任务, 随线程执行动态变化
end;

var
Form1: TForm1;
FindWeb: Array of TFindWeb;
//多线程数组
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);//创建并执行
var
i: integer;
begin
HtmlToListHttp(Edit2.Text);
//得到Edit2中的起始地址,并将得到的超连接地址存于Memo1, Memo2中
TotalTask := Memo2.Lines.Count;
//总任务数
SetLength(FindWeb, StrToInt(Edit1.Text));
//创建线程
for i := 0 to StrToInt(Edit1.Text) - 1do
begin
FindWeb := TFindWeb.Create(Memo1, Memo3, Statusbar1);
FindWeb.StrUrl := Memo2.Lines.Strings;
if Memo2.Lines.Strings <> '' then
inc(CurrentTask);
FindWeb.Resume ;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Memo1.Lines.SaveToFile('c:/http.txt');
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
//
end;

procedure TForm1.ThreadDone(var AMessage: TMessage);
var
i: integer;
begin
if (CurrentTask >= TotalTask) then
//是否任务都都执行完毕了
begin
for i := 0 to StrToInt(Edit1.Text) - 1do
begin
if ((FindWeb <> nil) and (FindWeb.ThreadID = cardinal(AMessage.WParam))) then
begin
FindWeb.Terminate;
// 执行完毕,终止
end;
end;
end
else
//没执行完所有任务
begin
for i := 0 to StrToInt(Edit1.Text) - 1do
begin
if ((FindWeb <> nil) and (FindWeb.ThreadID = cardinal(AMessage.WParam))) then
begin
FindWeb.StrUrl := Memo2.Lines.Strings[CurrentTask];
//重新赴地址
inc(CurrentTask);
break;
end;
end;
//for
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Self.Close ;
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
// Memo3.Lines.SaveToFile('c:/http1.txt');
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
// Memo5.Lines.SaveToFile('c:/http2.txt');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
CurrentTask := 0;
TotalTask := 0
end;

function TForm1.GetSubString(myString: string;
last: integer): string;
begin
Result := Copy(myString, length(myString) - last + 1, length(myString));
end;

procedure TForm1.GrabHtml;
begin
//
end;

procedure TForm1.HtmlToListHttp(strFirstUrl: string);
//将网页中的超连接分离出来
var
strAddr, strText: string;
nbegin
, nEnd: integer;
TempStr: string;
strRead: string;
begin
// Http.OnWork := HttpWork;
StrRead := Http.get(strFirstUrl);
StrRead := LowerCase(strRead);
if pos('404', strRead) = 0 then
//当读到的不是空
begin
TempStr := StrRead;
repeat
nbegin
:= Pos('href="', TempStr);
if nbegin
<> 0 then
begin
TempStr := Copy(TempStr, nbegin
+ 6, Length(TempStr));
nEnd := Pos('"', TempStr);
strAddr := Copy(TempStr, 1, nEnd - 1);
TempStr := Copy(TempStr, nEnd + 1, Length(TempStr));
if Length(StrAddr) > 4 then
if (pos('.asp', strAddr) <> 0) or (pos('.php', strAddr) <> 0) or (pos('.cgi', strAddr) <> 0) or (pos('.xml', strAddr) <> 0) or (pos('.jsp', strAddr) <> 0) or (pos('.htm', strAddr) <> 0) or (pos('.com', GetSubString(strAddr, 5)) <> 0) or (pos('.net', GetSubString(strAddr, 5)) <> 0) or (pos('.cn', GetSubString(strAddr, 4)) <> 0) or (pos('.js', strAddr) <> 0) or (pos('.edu', GetSubString(strAddr, 4)) <> 0) then
if pos('@', strAddr) = 0 then
if Memo2.Lines.IndexOf(StrAddr) = -1 then
begin
Memo1.Lines.Add(strAddr);
Memo2.Lines.Add(strAddr);
end;
end;
until nbegin
= 0;
end;
//if pos<>0
end;

end.



/**************************线程部分**********************************************/
unit Unit2;
interface
uses
windows, SysUtils, Dialogs, Classes, idComponent, idHttp, StdCtrls, ComCtrls;
type
TFindWeb = class(TThread)
private
{ Private declarations }
Status: string;
//当前此线程的状态
FHttpMemo: TMemo;
//用于存放得到的超连接地址
// FHttpMemoBak: TMemo;
FMailMemo: TMemo;
//在此仅用于显示
FStatusBar: TStatusBar;
//状态条
FStrUrl: string;
//此时线程分配的网址
StrRead: string;
//读到的网页内容
FCount: integer;
//暂时没用
protected
procedure SetUrl(Value: string);
procedure SetCount(Value: Integer);
procedure AddToList;
procedure AddToMailMemo;
procedure AddToHttpMemo;
procedure ShowStatus;
procedure GrabHtml;
procedure HtmlToListHttp;
//分离超连接地址
procedure HtmlToListMail;
procedure FoundMail;
procedure DisplayMes;
procedure OnThreadTerm(Sender: TObject);
procedure HttpWork(Sender: TObject;
AWorkMode: TWorkMode;
const AWorkCount : integer);
procedure Execute;
override;
public
constructor Create(HttpMemo: TMemo;
MailMemo: TMemo;MyStatusBar: TStatusBar);
property StrUrl: string read FStrUrl write SetUrl;
property Count: integer read FCount write SetCount default 1;
end;

implementation
uses Unit1;
{ Important: Methods and properties of objects in VCL or CLX can only be used
in a method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure TFindWeb.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end;
}
{ TFindWeb }
procedure TFindWeb.AddToHttpMemo;
begin
//
end;

procedure TFindWeb.AddToList;
begin
//
end;

procedure TFindWeb.AddToMailMemo;
begin
//
end;
constructor TFindWeb.Create(HttpMemo, MailMemo: TMemo;
MyStatusBar: TStatusBar);
begin
FHttpMemo := HttpMemo;
FMailMemo := MailMemo;
// FHttpMemoBak := HttpMemoBak;
FStatusBar := MyStatusBar;
FCount := 1;
inherited Create(True);
FreeOnTerminate := True;
OnTerminate := Self.OnThreadTerm;
//Resume;
end;

procedure TFindWeb.DisplayMes;
begin
Showmessage('fksdfklsdj');
end;

procedure TFindWeb.Execute;
begin
{ Place thread code here }
while not Terminateddo
begin
// Inc(Fcount);
FMailMemo.Lines.Add(Self.StrUrl);
Synchronize(DisplayMes);
GrabHtml;
HtmlToListHttp;
// PostMessage(form1.Handle,wm_ThreadDoneMsg,self.ThreadID,0);
//不要用PostMessage
SendMessage(form1.Handle, wm_ThreadDoneMsg, self.ThreadID, 0);
//遇到的问题应该是此处,没有像Form1(主窗体)发送信息, why?
end;
end;

procedure TFindWeb.FoundMail;
begin
//
end;

procedure TFindWeb.GrabHtml;
//读取网页内容
var
Http: TIdHttp;
begin
Status := 'Sending query: ' + StrUrl;
Synchronize(ShowStatus);
Http := TIdHttp.Create(nil);
try
Http.OnWork := HttpWork;
StrRead := Http.get(StrUrl);
finally
Http.Free ;
end;
end;

procedure TFindWeb.HtmlToListHttp;
//得到超连接地址
var
strAddr, strText: string;
nText: integer;
nbegin
, nEnd: integer;
TempStr: string;
begin
//
Status := 'Elaborating Http data for: ' + StrUrl;
Synchronize(ShowStatus);
strRead := LowerCase(strRead);
TempStr := StrRead;
repeat
nbegin
:= Pos('href=', TempStr);
if nbegin
<> 0 then
begin
strRead := Copy(TempStr, nbegin
+ 5, Length(TempStr));
nEnd := Pos('>', TempStr);
strAddr := Copy(TempStr, 1, nEnd - 1);
TempStr := Copy(TempStr, nEnd + 1, Length(TempStr));
if FHttpMemo.Lines.IndexOf(StrAddr) = -1 then
FHttpMemo.Lines.Add(strAddr);
//将新的到的地址加入,此处后面改,此处应不影响
end;
until nbegin
= 0;
end;

procedure TFindWeb.HtmlToListMail;
//此函数还没用
var
strAddr, strText: string;
// nText: integer;
nbegin
, nEnd: integer;
TempStr1: string;
TempStr2: string;
TempStr: string;
Str1, Str2: string;
begin
//
Status := 'Elaborating Mail data for: ' + StrUrl;
Synchronize(ShowStatus);
strRead := LowerCase(strRead);
TempStr := StrRead;
repeat
nbegin
:= Pos('@', TempStr);
if nbegin
<> 0 then
begin
Tempstr1 := Copy(StrRead, 1, nbegin
- 1);
Tempstr2 := Copy(StrRead, nbegin
+ 1, Length(StrRead));
nEnd := Pos('>', TempStr);
//将Mail取出
strAddr := Copy(TempStr, 1, nEnd - 1);
TempStr := Copy(TempStr, nEnd + 1, Length(TempStr));
{ if Pos('google', strAddr) = 0 then
begin
nText := Pos('</a>', strRead);
strText := Copy(strRead, 1, nText - 1);
if(Pos('cached', strText) = 0) then
begin
Addr := strAddr;
Text := strText;
AddToList;
end;
end;
}
if FHttpMemo.Lines.IndexOf(StrAddr) = -1 then
FHttpMemo.Lines.Add(strAddr);
end;
until nbegin
= 0;
end;

procedure TFindWeb.HttpWork(Sender: TObject;
AWorkMode: TWorkMode;
const AWorkCount: integer);
begin
status := 'Received ' + IntToStr(AWorkCount) + ' For ' + strUrl;
Synchronize(ShowStatus);
end;

procedure TFindWeb.OnThreadTerm(Sender: TObject);
begin
FMailmemo.Lines.Add('termined');
//标记此线程结束
end;

procedure TFindWeb.SetCount(Value: Integer);
begin
if Value <> FCount then
FCount := Value;
end;

procedure TFindWeb.SetUrl(Value: string);
begin
if Value <> FStrUrl then
FStrUrl := Value;
end;

procedure TFindWeb.ShowStatus;
begin
FStatusBar.SimpleText := Status;
end;

end.

没分了， 晴帮忙
 
好长啊~~~~
看不进去。。。
 
其实很简单， 你考到delphi中是一下， 主要问题就是
当在一个线程中idhttp.get(url)得到的是空页面，也就是没内容
时，此线程自动Terminate, 但我并没有让它Terminate, 我需要
它人存在。
帮忙看一下， 谢谢！
 
当任务列表中的连接地址都是好的地址时， 好用
也就是idhttp.get(url)不出措时好用。
看看吧！
 
挺急的, 看看吧, 拜托
 
我知道了，
FHttpMemo.Lines.Add(strAddr);
//将新的到的地址加入,此处后面改,此处应不影响
后面没有将总数加一
但还有问题是： 任务列表中的任务在线程中总是隔一个执行一个
为什么？
 
太多了看不进去，不过可以告诉你的是：当返回404 405等错误是IDHTTP会激发异常，所以线程就退出Execute了。
解决的方法是Try ....except ...end
 
不好意思
 
Try ....except ...end
这样好解决..
 
您必须登录或注册才可回复。

Similar threads

H
帮我看看这段代码，该如何做。有关多线程的。谢谢(50分)
回复
2
查看
303
resun
R
Q
多线程问题，请教。(50分)
回复
4
查看
356
穿越沦陷的爱
穿
Y
请大家帮忙看看这段有关多线程的代码(100分)
回复
5
查看
305
yyk518
Y
B
IDFTP的多线程扫描问题？（200分相送）(100分)
回复
4
查看
403
bamfk1023
B
S
线程在网络编程应用中遇到的问题！！大家一起研究研究！ (30分)
回复
7
查看
329
sailorhdx
S
后退
顶部