httpcli多线程下载的问题 ( 积分: 200 )

  • 主题发起人 主题发起人 coolice823
  • 开始时间 开始时间
C

coolice823

Unregistered / Unconfirmed
GUEST, unregistred user!
小弟使用httpcli多线程下载网页,以下代码单独测试没有问题,但在另一个线程中创建TDownThread后,myGet的状态一直为httpdnslookup,小弟百思不得其解,忘各位高手帮忙。

unit DownThread;

interface

uses
Windows, Messages, Sysutils,Variants, Classes,Graphics, Controls, Forms,
Dialogs, comctrls,stdctrls, shellApi, DB, ADODB, ActiveX,
OverbyteIcsHttpProt, OverbyteIcsWndControl;

type
TOnCompleteEvent = procedure(Sender: TObject; sHtml: String) of object;

TDownThread = class(TThread)
private

FHtml :String;
myGet :THttpCli;
Fcomplete :Boolean;
GetStream : TMemoryStream;
Foncomplete :TOnCompleteEvent;
procedure FreeStream();
protected

public
FPageUrl :String;
procedure Execute; override;//线程函数
constructor Create(sUrl: String);
destructor destroy;override;
property Oncomplete : TOnCompleteEvent read Foncomplete write Foncomplete;
end;

implementation


constructor TDownThread.Create(sUrl: String);
begin
//创建非挂起线程
inherited Create(False);
FreeOnTerminate := True;
FPageUrl := sUrl;
//网页下载初始化设置部分及事件委托
GetStream := TMemoryStream.Create;
myGet := THttpCli.Create(nil);
myGet.Accept := 'text/html,text/xml';
myGet.ContentTypePost := 'application/x-www-form-urlencoded';
myGet.BandwidthLimit := 10000;
myGet.BandwidthSampling := 1000;
myGet.FollowRelocation := true;
myget.LocationChangeMaxCount := 8;
myget.MultiThreaded := true;
myget.NoCache := true;
{
myget.OnDocBegin := HttpCliDocBegin;
myget.OnDocEnd := HttpCliDocEnd;
myget.OnSocksError := HttpCliSocksError;
myget.OnRequestDone := HttpCliRequestDone;
myget.OnStateChange := HttpCliStateChange;
myget.OnDocData := HttpCliDocData;
}
end;


destructor TDownThread.destroy;
begin
myGet.Free;
Freeandnil(GetStream);
Fhtml:='';
inherited destroy;
end;

procedure TDownThread.Execute;
var TempANSI:string;
HasWait :integer;
begin
//----------------------------------------------------------------------------
//在没有被结束的情况下,循环等待下一个网页地址
//----------------------------------------------------------------------------
CoInitialize(nil);

//while (not Terminated) do
//begin
{$ifdef UindexDebugMode}
SendInfo('线程消息循环.'+DateTimeToStr(Now));
{$endif}
if FPageUrl<>'' then
begin
myGet.URL := FPageUrl;
myGet.RcvdStream := GetStream;
myGet.GetASync;
end;
while not (Terminated or Fcomplete) do
begin
if (myGet.State=httpReady) and (FPageUrl<>'') then
begin
if myGet.RcvdStream<>nil then
begin
setlength(Fhtml,myGet.RcvdStream.size);
myGet.RcvdStream.Seek(0, soFromBeginning);
myGet.RcvdStream.Read(Fhtml[1],myGet.RcvdStream.size);
//UiPageLen := Length(Fhtml);
Fcomplete := True;

if assigned(FOncomplete) then FOncomplete(Self, Fhtml);
FreeStream;
end
end
else begin
sleep(10);
end;
end;

//end;
CoUninitialize();
end;

procedure TDownThread.FreeStream;
begin
//注意:这里已经将GetStream释放
if myGet.RcvdStream<>nil then
begin
GetStream.Clear;
myGet.RcvdStream:=nil;
setlength(Fhtml,0);
end;
end;
end.
 
没人知道吗?太奇怪了,我试了两天都没搞清楚
 
后退
顶部