httpgetex.~pas

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

unit HttpGetEx;

interface

uses
  Windows, Messages, SysUtils, Classes,wininet;

const
 HTTPGET_BUFFER_MAX=1024;

type
 TOnHttpNotify=procedure (sender:tobject;indexs:Integer)of object;
 TOnHttpComplete=procedure (sender:tobject;indexs:integer)of object;
 TOnHttpGetFileSize=procedure (sender:tobject;fsize:integer)of object;
 TOnProgressEvent=procedure(sender:tobject;position:integer;max:Integer;indexs:Integer) of object;
 TOnHttpStatusText=procedure(sender:tobject;msg:string;indexs:Integer) of object;

THttpGetThread = class(TThread)
  private
    FIndexs:integer;
    FRepeatcount:integer;
    Buffer:array [0..HTTPGET_BUFFER_MAX+4] of char;
    Fowner:TObject;
    FURL:string;
    FOutFileName:string;
    FHostName:string;
    FDownPath:string;
    FhSession:HINTERNET;
    FhConnect:HINTERNET;
    FhRequest:HINTERNET;
    iFilehandle:integer;
    FFilesize:integer;
    dwStart:DWORD;
    dwTotal:DWORD;
    //FGetBytes:DWORD;
    FSuccess:boolean;
    FConnected:boolean;
    FFromBreakPoint:boolean;
    FOnAbort:TOnHttpNotify;
    FOnError:TOnHttpNotify;
    FOnComplete:TOnHttpComplete;
    FOnGetFileSize:TOnHttpGetFileSize;
    FOnProgress:TOnProgressEvent;
    FOnStatusText:TOnHttpStatusText;
    procedure parseURL;
    procedure StartHttpGet;
    procedure DoHttpGet;
    procedure EndHttpGet;
    procedure DoOnComplete;
    procedure DoOnError;
    procedure DoOnProgress(position:Integer);
    procedure DoOnGetFileSize(size:Integer);
    procedure DoOnStatusText(text:string);
    function OpenOutFile:DWORD;
   protected
    procedure Execute; override;
   public
    constructor create(AOwner:TObject);
    function GetWebFileSize:integer;
    function SetFilePointer:boolean;
   published
    property URL:string read FURL write FURL;
    property OutFileName:string read FOutFileName write FOutFileName;
    property Successed:boolean read FSuccess;
    property Connected:boolean read FConnected;
    property FromBreakPoint:boolean read FFromBreakPoint write FFromBreakPoint;
    property Indexs:Integer read FIndexs write FIndexs;
    property StartPosition:DWORD read dwStart write dwStart;
    property GetBytes:DWORD read dwTotal write dwTotal;
    property OnComplete:TOnHttpComplete read FOnComplete write FOnComplete;
    property OnAbort:TOnHttpNotify read FOnAbort write FOnAbort;
    property OnError:TOnHttpNotify read FOnError write FOnError;
    property OnGetFileSize:TOnhttpGetFileSize read FOnGetFileSize write FOnGetFileSize;
    property OnProgress:TOnProgressEvent read FOnProgress write FOnProgress;
    property OnStatusText:TOnHttpStatusText read FOnStatusText write FOnStatusText;
  end;

 THttpGetEx = class(TComponent)
 private
   httpthreads:array of thttpgetthread;
   OutTempFiles:array of string;
   FSuccess:array of boolean;
   FHttpThreadCreated:boolean;
   FHttpThreadCount:integer;
   FWorking:boolean;
   FFromBreakPoint:boolean;
   FURL:string;
   FOutFileName:string;
   FOnAbort:TNotifyEvent;
   FOnError:TNotifyEvent;
   FOnComplete:TNotifyEvent;
   FOnGetFileSize:TOnHttpGetFileSize;
   FOnProgress:TOnProgressEvent;
   FOnStatusText:TOnHttpStatusText;
   procedure AssignResource;
   procedure ReleaseResource;
   procedure DoOnComplete;
   procedure DoOnError;
   procedure DoOnStatusText(text:string);
   function GetSystemTemp:string;
   procedure SetURL(Value: string);
   procedure filename(Value: string);
   procedure OnThreadError(sender:TObject;indexs:Integer);
   procedure OnThreadComplete(sender:TObject;indexs:Integer);
 protected
   function CreateHttpThread:THttpGetThread;
   procedure createHttpThreads;
 public
   constructor create(AOwner:Tcomponent);override;
   destructor destroy;override;
   procedure StartGet;
   procedure stop;
 published
   property ThreadCount:integer read FHttpThreadCount write FHttpThreadCount;
   property working:boolean read FWorking;
   property FromBreakPoint:boolean read FFromBreakPoint write FFromBreakPoint;
   property URL:string read FURL write FURL;
   property filename:string read FOutFileName write FOutFileName;
   property OnAbort:TNotifyEvent read FOnAbort write FOnAbort;
   property OnError:TNotifyEvent read FOnError write FOnError;
   property OnComplete:TNotifyEvent read FOnComplete write FOnComplete;
   property OnGetFileSize:TOnHttpGetFileSize read FOnGetFileSize write FOnGetFileSize;
   property OnProgress:TOnProgressEvent read FOnProgress write FOnProgress;
   property OnStatusText:TOnHttpStatusText read FOnStatusText write FOnStatusText;
 end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [THttpGetEx]);
end;
procedure SetURL(Value: string);
begin
  FURL := Value;
end;
procedure filename(Value: string);
begin
  FOutFileName:=Value;
end;
constructor THttpGetThread.create(aowner:tobject);
begin
  FreeOnTerminate:=true;
  FRepeatCount:=5;
  FIndexs:=0;
  FOwner:=AOwner;
  FFromBreakPoint:=false;
  FSuccess:=false;
  FConnected:=false;
  FFileSize:=-2;
  ifilehandle:=-1;
  dwStart:=0;
  dwTotal:=0;
  inherited create(false);
end;

procedure THttpGetThread.parseURL ;
var
 url:string;
 i:integer;
begin
 url:=furl;
 i:=pos('http://',url);
 if i>0 then
  begin
   url:=copy(url,8,length(url));
   i:=pos('/',url);
   FHostName:=copy(url,1,i-1);
   FDownPath:=copy(url,i+1,length(url));
  end;
end;

procedure THttpGetThread.StartHttpGet;
var
 FAcceptTypes:string;
begin
 if FConnected then exit;   //原文是return,
 parseURL;
 FAcceptTypes:='*/*';
 try
  FhSession:=InternetOpen('httpgetdemo',INTERNET_OPEN_TYPE_PRECONFIG,'','',0);
  if FhSession=nil then raise exception.Create('Error:InterOpen');
  DoOnStatustext('ok:Interopen');
  FhConnect:=InternetConnect(FhSession,pchar(FHostName),INTERNET_DEFAULT_HTTP_PORT,'','',INTERNET_SERVICE_HTTP,0,0);
  if FhConnect=nil then raise exception.Create('Error:InterConnect');
  DoOnStatustext('ok:InternetConnect');
  FhRequest:=HttpOpenRequest(FhConnect,'get',pchar(FDownpath),'HTTP/1.0','',@FAcceptTypes,INTERNET_FLAG_RELOAD,0);
  if FhRequest=nil then raise exception.Create('Error:HttpOpenRequest');
  DoOnStatusText('ok:HttpOpenRequest');
  HttpSendRequest(FhRequest,'',0,nil,0);
  DoOnStatusText('ok:HttpSendRequest');
  FConnected:=true;
 except
  on e:exception do
   begin
    EndHttpGet;
    DoOnStatusText(e.message);
   end;
 end;
end;

function THttpGetThread.GetWebFileSize ;
var
 BufLen:DWORD;
 dwIndex:DWORD;
 RetQueryInfo:boolean;
 begin
  if FFileSize>-2 then
   begin
    result:=FFileSize;
    exit;
   end;
   FFilesize:=-1;
   if not FConnected then StartHttpGet;
   if not Fconnected then
    begin
     result:=FFileSize;
     exit;
    end;
   try
    BufLen:=HTTPGET_BUFFER_MAX;
    dwIndex:=0;
    RetQueryInfo:=HttpQueryInfo(FhRequest,HTTP_QUERY_CONTENT_LENGTH,@buffer,BufLen,dwindex);
    if not RetQueryInfo then raise exception.Create('Error:HttpQueryInfo');
    DoOnStatusText('ok:HttpQueryInfo');
    FFileSize:=strtoint(strpas(Buffer));
    DoOnGetFileSize(FFileSize);
    result:=FFileSize;
   except                               
    on e:exception do
     begin
      DoOnStatusText(e.message);
      result:=FFileSize;
     end;
   end;
 end;


function THttpGetThread.SetFilePointer ;
var
 size:integer;
 ReadReturn:integer;
begin
 size:=GetWebFileSize;
 if size<0 then
  begin
   result:=false;
   exit;
  end;
 if dwStart=0 then
  begin
   result:=true;
   exit;
  end;
 try
   ReadReturn:=InternetSetFilePointer(FhRequest,dwstart,nil,FILE_BEGIN,0);
   if readReturn=-1 then raise exception.Create('Error:InternetSetFilePointer');
   DoOnStatusText('ok:InternetSetFilePointer');
   result:=true;
 except
  On E:exception do
   begin
    DoOnStatusText(e.message);
    result:=false;
   end;
 end;
end;

function THttpGetThread.OpenOutFile:DWORD;
var
 dwCount:DWORD;
 f:file;
begin
 try
  if FileExists(FOutFileName) then
   begin
    if FFromBreakPoint then
     begin
      assignfile(F,FOutFileName);
      reset(F);
      dwCount:=filesize(F);
      closefile(F);
      if dwCount>0 then
       begin
        iFileHandle:=FileOpen(FOutFileName,fmOpenWrite);
        fileseek(iFileHandle,0,2);
        if iFileHandle=-1 then raise exception.Create('Error:FileCreate');
        DoOnStatusText('ok:OpenFile');
        result:=dwCount;
        exit;
      end;
     end;
    DeleteFile(FOutFileName);
  end;
  iFileHandle:=FileCreate(FOutFileName);
  if iFileHandle=-1 then raise exception.create('Error:FileCreate');
  DoOnstatustext('ok:CreateFile');
  result:=0;
 except
  On E:exception do
   begin
    DoOnStatusText(e.message);
    result:=0;
   end;
 end;
end;

procedure THttpGetThread.DoHttpGet;
var
 dwCount:DWORD;
 dwRequest:DWORD;
 dwRead:DWORD;
 ReadReturn:boolean;
begin
  if not FConnected then exit;
  dwcount:=OpenOutFile;
  if dwCount>0 then
   begin
    dwStart:=dwStart+dwCount;