httpgetex.pas

一套非常好用的delphi控件,方便程序员工作

    if not SetFilePointer then
     begin
      fileSeek(ifilehandle,0,0);
      dwCount:=0;         //added by charles
     end;
   end ;
  try
   DoOnStatusText('StartGet:InterReadFile');
   dwRequest:=HTTPGET_BUFFER_MAX;
   while true do
    begin
    // application.processmessages;
     if dwtotal>0 then
       begin
        if dwRequest+dwCount>dwTotal then dwRequest:=dwTotal-dwCount;
       end;
     readreturn:=InternetReadFile(FhRequest,@buffer,dwRequest,dwread);
     if not ReadReturn then break;
     if dwread=0 then break;
    // Buffer[dwread]:='\0';
     FileWrite(ifilehandle,Buffer,dwRead);
     dwCount:=dwCount+dwRead;
     DoOnProgress(dwCount);
     if dwTotal>0 then
      begin
       if dwCount>=dwTotal then break;
      end;
    end;  
   except
     On e:exception do DoOnStatusText(e.message);
   end;  
   FileClose(ifilehandle);
   DoOnStatusText('End:InternetReadFile');
   if dwCount=dwTotal then FSuccess:=true;
end;

procedure THttpGetThread.DoOnComplete;
begin
  if assigned(FOnComplete) then FOnComplete(FOwner,FIndexs);
end;

procedure THttpGetThread.DoOnError;
begin
  if assigned(FOnError) then FOnError(FOwner,FIndexs);
end;

procedure THttpGetThread.DoOnGetFileSize(size: Integer);
begin
 if assigned(FOnGetFileSize) then FOnGetFileSize(FOwner,size);
end;

procedure THttpGetThread.DoOnProgress(position: Integer);
begin
 if assigned(FOnProgress) then FOnProgress(FOwner,Position,dwTotal,FIndexs);
end;

procedure THttpGetThread.DoOnStatusText(text: string);
begin
 if assigned(FOnStatusText) then FOnStatusText(FOwner,Text,FIndexs);
end;

procedure THttpGetThread.EndHttpGet;
begin
 if FConnected then
  begin
   DoOnStatusText('closing:InternetConnect');
   try
    InternetCloseHandle(FhRequest);
    InternetCloseHandle(FhConnect);
    InternetCloseHandle(FhSession);
  except
   FhSession:=nil;
   FhConnect:=nil;
   FhRequest:=nil;
   FConnected:=false;
   DoOnStatusText('closed:InternetConnect');
  end;
 end;
end; 

procedure THttpGetThread.Execute;
var
 i:integer;
begin
  { Place thread code here }
   for i:=0 to FRepeatCount-1 do
    begin
     StartHttpGet;
     GetWebFileSize;
     SetFilePointer;
     DoHttpGet;
     EndHttpGet;
     if FSuccess then break;
    end;
  if FSuccess then DoOnComplete else DoOnError;
end;

constructor THttpGetEx.create(AOwner:TComponent); 
begin
 inherited create(AOwner);
 FHttpThreadCount:=3;
 FHttpThreadcreated:=false;
 FWorking:=false;
 FFromBreakPoint:=false;
end;

destructor THttpGetEx.destroy;
 begin
// httpthreads:=nil;
 inherited destroy;
end;

function THttpgetEx.GetSystemTemp:string;
 var
  temp:array [0..1024] of char;
begin
  if gettemppath(1024,temp)>0 then result:=temp;
end;

function THttpGetEx.CreateHttpThread: THttpGetThread;
var
 httpthread:THttpGetThread;
 begin
  httpthread:=THttpGetThread.create(self);
  httpthread.FromBreakPoint:=FFromBreakPoint;
  httpthread.URL:=FURL;
  httpthread.OnAbort:=OnThreadError;
  httpthread.OnError:=OnThreadError;
  httpthread.OnComplete:=OnThreadComplete;
  httpthread.OnGetFileSize:=FOnGetFileSize;
  httpthread.OnProgress:=FOnProgress;
  httpthread.OnstatusText:=FOnStatusText;
  result:=httpthread;
 end;

procedure THttpGetEx.createHttpThreads;
var
 httpthread:THttpGetThread;
 FileSize:integer;
 AvgSize:integer;
 Starts:array of integer;
 Bytes:array of integer;
 CanMulti:boolean;
 i:integer;
begin
 if FHttpThreadCreated then exit;
 FHttpThreadCreated:=true;
 AssignResource;
 httpthread:=CreateHttpThread;
 FileSize:=httpthread.GetWebFileSize;
 AvgSize:=FileSize div FHttpThreadCount;
 setlength(Starts,FHttpThreadCount);
 setlength(Bytes,FHttpThreadCount);
 for i:=0 to FHttpThreadCount-1 do
  begin
   Starts[i]:=i*AvgSize;
   Bytes[i]:=AvgSize;
  end;
 Bytes[FHttpThreadcount-1]:=AvgSize+(FileSize-AvgSize*FHttpThreadCount);
 httpthread.StartPosition:=Starts[FHttpThreadCount-1];
 httpthread.GetBytes:=Bytes[FHttpThreadCount-1];
 CanMulti:=httpthread.SetFilePointer ;
 if not CanMulti then
  begin
   setlength(httpthreads,1);
   FHttpThreadCount:=1;
   httpthreads[FHttpThreadCount-1]:=httpthread;
   httpthread.StartPosition:=0;
   httpthread.GetBytes :=FileSize;
   httpthread.Indexs:=0;
   httpthread.OutFileName :=outtempFiles[0];
  end
 else
  begin
   setlength(HttpThreads,FHttpThreadCount);
   for i:=0 to FHttpThreadCount-1 do
    begin
     HttpThreads[i]:=thttpgetthread.create(self);
     HttpThreads[i].StartPosition :=Starts[i];
     HttpThreads[i].GetBytes :=Bytes[i] ;
     HttpThreads[i].OutFileName :=OutTempFiles[i];
     HttpThreads[i].Indexs :=i;
    end;
  end;
  starts:=nil;
  bytes:=nil;
end;



procedure THttpGetEx.DoOnComplete;
var
 Hd:integer;
 hs:integer;
 bufsize:integer;
 buf:array [0..HTTPGET_BUFFER_MAX*4+4] of char;
 reads:Integer;
 i:integer;
begin
 bufsize:=0;
  if Assigned(FOnComplete) then
   begin
    DoOnStatusText('download complete');
    DoOnStatusText('merge all parts');
    copyfile(pchar(OutTempFiles[0]),pchar(FOutFileName),false);
    hd:=fileopen(FOutFileName,fmOpenWrite);
    FileSeek(hd,0,2);
    if hd=-1 then
     begin
       DoOnError;
       exit;
     end;
    for i:=1 to FHttpThreadCount-1 do
     begin
       hs:=fileopen(OutTempFiles[i],fmopenread);
       reads:=Fileread(hs,buf,bufsize);
       while reads>0 do
        begin
         filewrite(hd,buf,bufsize);
         reads:=fileRead(hs,buf,bufsize);
        end;
       fileclose(hs);
     end;
    fileclose(hd);
    DoOnStatusText('all complete');
    FOnComplete(self);
   end;
end;

procedure THttpGetEx.DoOnError;
begin
  if assigned(FOnError) then FOnError(self);
end;

procedure THttpGetEx.DoOnStatusText(text: string);
begin
 if assigned(FOnStatusText) then FOnStatusText(self,text,-1);
end;

procedure THttpGetEx.OnThreadComplete(sender: TObject; indexs: Integer);
var
 hmutex:thandle;
 err:dword;
 s:boolean;
 i:integer;
begin
 s:=true;
 hMutex:=createMutex(nil,false,'httpgetMutex');
 err:=getlasterror;
 if err=ERROR_ALREADY_EXISTS then
  begin
   waitforSingleObject(hMutex,INFINITE);
   hMutex:=createMutex(nil,false,'httpgetMutex');
  end;
 FSuccess[indexs]:=true;
 for i:=0 to FHttpThreadCount-1 do   s:=s and fsuccess[i];
 releaseMutex(hMutex);
 if s then DoOnComplete;

end;


procedure THttpGetEx.OnThreadError(sender: TObject; indexs: Integer);
begin
 stop;
 DoOnError;
end;

procedure THttpGetEx.ReleaseResource;
begin
  HttpThreads:=nil;
  FSuccess:=nil;
  OutTempFiles:=nil;
  FHttpThreadCreated:=false;
end;

procedure THttpGetEx.StartGet;
var
 i:integer;
begin
 if (FURL='') or (FOutFileName='') then exit;
 CreateHttpThreads;
 for i:=0 to FHttpThreadcount-1 do
  begin
   if HttpThreads[i].Suspended then HttpThreads[i].Resume ;
  end;
end;

procedure THttpGetEx.stop;
var
 i:integer;
begin
  if not FWorking then exit;
  for i:=0 to FHttpThreadCount-1 do  HttpThreads[i].Terminate;
  ReleaseResource;
  fworking:=false;
end;


procedure THttpGetEx.AssignResource;
var
 i:integer;
 shortname:string;
 path:string;
begin
 setlength(FSuccess,FHttpThreadCount);
 for i:=0 to FHttpThreadCount-1 do FSuccess[i]:=false;
 setlength(OutTempFiles,FHttpThreadCount);
 shortname:=extractfilename(FOutFileName);
 path:=GetSystemTemp;
 for i:=0 to FHttpThreadCount-1 do
  OutTempFiles[i]:=path+shortname+'-'+inttostr(i)+'.hpt';
 setlength(HttpThreads,FHttpThreadCount); 
end;


//end.

end.