INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Networking

A http file downloader component by Glenn9999
Posted: 28 Jul 11 (Edited 14 Sep 11)

I wanted to share this file downloading component.  It should be relatively self-explanatory to use.  Plug in the URL and then run DownloadFile, use the events to update progress, set where the file is saved, and detect when the call is completed (it's asynchronous, unless you call "WaitForDownload" afterwards).  There are a few other options which can be useful.  The unit in FAQ102-7493: WinHTTP Access Unit will satisfy the "winhttp" uses statement.

CODE

unit http_download;

{ http downloading component. }
// issue: User wants to cancel out from a file prompt?  How to stop this?

interface
  uses forms, classes, windows, messages, sysutils, winhttp, dialogs;

  {$R HTTP_RES.DCR}

const
  WM_WEBFILE = WM_APP + $20;
  WM_WEBPROGRESS = WM_APP + $21;
  WM_WEBFINISHED = WM_APP + $22;

type
  DWord = Longint;
  int64 = comp;
  TWebDownloader = class(TThread)
    private
      szBuffer: array[1..32768] of byte;
      FSizeRead: DWord;
      hConnect, hRequest, hSession: HInternet;
      LocalFName: string;

      procedure CleanUp;
      function FileSizeEx(savefile: string): Int64;
      function GetSaveFile(inURL: string): String;
      function GetContentLength(URLHandle: HINTERNET): Int64;
      function GetFullURL(URLHandle: HINTERNET; fURL: string): String;
      function GetStatusText(URLHandle: HINTERNET): string;
      function GetStatusCode(URLHandle: HINTERNET): integer;
      function GetURLHost(inURL: string): string;
      function GetURLPath(inURL: string): String;
      function GetRangeString: string;
   public
      PropEvent: THandle;
      Win_Handle: THandle;
      DownloadSize: Int64;
      StatusCode: integer;
      StatusText: string;
      UserAgent: string;
      URL: string;
      SaveFilePath: string;
      UseDownloadRanges: boolean;
      ResumeDownload: Boolean;
      HighRange, LowRange: Int64;
   protected
      procedure Execute; override;
   end;

  TDownloadProgressEvent = procedure (Sender: TObject; DownloadUnit: DWord; DownloadSize: Comp) of object;
  TFilePromptEvent = procedure (Sender: TObject; var LocalFilePath, LocalFileName: string) of object;
  THttpDownload = class(TComponent)
    private
      FUserAgent: string;
      FLowRange: Int64;
      FHighRange: Int64;
      FURL: string;
      FSaveFilePath: string;
      FUseDownloadRanges: Boolean;
      FResumeDownload: boolean;
      FHandle: THandle;

      FOnProgress: TDownloadProgressEvent;
      FOnFilePrompt: TFilePromptEvent;
      FOnCompleted: TNotifyEvent;

      FDownloader: TWebDownloader;
    public
      DownloadSize: Int64;
      StatusCode: integer;
      StatusText: string;

      procedure DownloadFile;
      procedure DownloadCancel;
      procedure DownloadPause;
      procedure DownloadResume;
      procedure WaitForDownload;

      Constructor Create(AOwner: TComponent); override;
      Destructor Destroy; override;
    protected
      procedure Loaded; override;
      procedure Window_Handler(var msg: TMessage); virtual;
    published
      property URL: string read FURL write FURL;
      property SaveFilePath: string read FSaveFilePath write FSaveFilePath;
      property UseDownloadRanges: boolean read FUseDownloadRanges
          write FUseDownloadRanges default false;
      property ResumeDownload: boolean read FResumeDownload
          write FResumeDownload default false;
      property LowRange: Int64 read FLowRange write FLowRange;
      property HighRange: Int64 read FHighRange write FHighRange;
      property UserAgent: string read FUserAgent write FUserAgent;
      property OnProgress: TDownloadProgressEvent read FOnProgress write FOnProgress;
      property OnFilePrompt: TFilePromptEvent read FOnFilePrompt write FOnFilePrompt;
      property OnCompleted: TNotifyEvent read FOnCompleted write FOnCompleted;
  end;

function timeGetTime: DWord; stdcall; external 'winmm.dll' name 'timeGetTime';

procedure Register;

implementation

// THttpDownload methods follow
Constructor THttpDownload.Create(AOwner: TComponent);
  begin
    FHandle := AllocateHWnd(Window_Handler);
    inherited create(aowner);
  end;

function GetCurrFilePath: string;
  var
    filelen: integer;
  begin
    SetLength(Result, MAX_PATH);
    filelen := GetModuleFileName(0, PChar(Result), MAX_PATH);
    SetLength(Result, filelen);
    Result := ExtractFilePath(Result);
  end;

procedure THttpDownload.Loaded;
  { initializations of the control }
  begin
    inherited loaded;
    // enforce defaults
    if (csDesigning in ComponentState) then
    else
      begin
        if FSaveFilePath = '' then
          FSaveFilePath := GetCurrFilePath;
        if UserAgent = '' then
          UserAgent := 'Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.1; Trident/4.0)';
      end;
  end;

Destructor THttpDownload.Destroy;
  begin
    DeallocateHWnd(FHandle);
    Inherited;
  end;

procedure THttpDownload.Window_Handler(var msg: TMessage);
  begin
    case Msg.Msg of
      WM_WEBPROGRESS:
        begin
          if Assigned(FOnProgress) then
             FOnProgress(Self, Msg.WParam, DownloadSize)
        end;
      WM_WEBFILE:
        begin
          if Assigned(FOnFilePrompt) then
            begin
              FOnFilePrompt(Self, String(Pointer(Msg.WParam)^),
                                  String(Pointer(Msg.LParam)^));
            end;
        end;
      WM_WEBFINISHED:
        begin
          FDownloader.Free;
          if Assigned(FOnCompleted) then
            FOnCompleted(Self);
        end;
    else
      DefWindowProc(FHandle, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

procedure THttpDownload.DownloadCancel;
  begin
    FDownloader.Terminate;
  end;

procedure THttpDownload.DownloadPause;
  begin
    FDownloader.Suspend;
  end;

procedure THttpDownload.DownloadResume;
  begin
    FDownloader.Resume;
  end;

procedure THttpDownload.WaitForDownload;
  begin
    repeat
      Application.ProcessMessages;
    until WaitForSingleObject(FDownloader.Handle, 20) = WAIT_OBJECT_0;
  end;

procedure THttpDownload.DownloadFile;
  var
    test: DWord;
  begin
    FDownloader := TWebDownloader.Create(True);
    FDownloader.FreeOnTerminate := false;
    FDownloader.Priority := tpTimeCritical;

    FDownloader.URL := URL;
    FDownloader.SaveFilePath := FSaveFilePath;
    FDownloader.UserAgent := FUserAgent;
    FDownloader.UseDownloadRanges := FUseDownloadRanges;
    FDownloader.ResumeDownload := FResumeDownload;
    FDownloader.HighRange := FHighRange;
    FDownloader.LowRange := FLowRange;
    FDownloader.Win_Handle := FHandle;
    FDownloader.PropEvent := CreateEvent(nil, True, False, nil);
    FDownloader.Resume;
// probably need better way to do this so OnFilePrompt can fire in this
    // period, but can't think of good way without going to a lot of trouble.
    repeat
      test := WaitForSingleObject(FDownloader.PropEvent, 200);
      Application.ProcessMessages;
    until test = WAIT_OBJECT_0;
    DownloadSize := FDownloader.DownloadSize;
    URL := FDownloader.URL;
    StatusCode := FDownloader.StatusCode;
    StatusText := FDownloader.StatusText;
  end;

// **********************************************************************
// TWebDownloader methods follow
// **********************************************************************
function TWebDownloader.GetSaveFile(inURL: string): String;
// pulls the file name off the URL and removes all escape characters
  var
    UrlComp: URL_COMPONENTS;
    outpath: array[1..200] of WideChar;
    sz: string;
    i: integer;
  begin
    Result := '';
    FillChar(URLComp, Sizeof(Urlcomp), 0);
    Urlcomp.dwStructSize := Sizeof(URlComp);
    UrlComp.dwUrlPathLength := 400;
    UrlComp.lpszUrlPath := @outpath[1];
    if WinHttpCrackURL(PWideChar(WideString(inURL)), 0, ICU_DECODE, URLComp) then
      begin
        sz := String(outpath);
        SetLength(sz, UrlComp.dwURLPathLength);
        i := length(sz);
        while sz[i] <> '/' do dec(i);
        Result := copy(sz, i+1, 2000);
      end;
  end;

function TWebDownloader.GetContentLength(URLHandle: HINTERNET): Int64;
// returns the expected download size.  Returns -1 if one not provided
  var
    SBuffer: Array[1..20] of WideChar;
    sbufstring: string;
    SBufferSize: Integer;
  begin
    SBufferSize := 40;
    if WinHttpQueryHeaders(URLHandle, WINHTTP_QUERY_CONTENT_LENGTH,
      WINHTTP_HEADER_NAME_BY_INDEX, @SBuffer[1], SBufferSize,
      WINHTTP_NO_HEADER_INDEX) then
      begin
        sbufstring := WideString(Sbuffer);
        Result := StrToFloat(SBufString);
      end
    else
      Result := -1;
  end;

function TWebDownloader.GetFullURL(URLHandle: HINTERNET; fURL: string): String;
  // returns the real URL in case the given URL is a redirect.
  var
    sbuffer: Array[1..1000] of Widechar;
    sbuffersize: integer;
  begin
  // get real URL and save it back to fURL
    SBufferSize := 1000;
    WinHttpQueryOption(URLHandle, WINHTTP_OPTION_URL, @sbuffer[1], sbuffersize);
    Result := String(WideString(SBuffer));
    SetLength(Result, SBufferSize div 2);
  end;

function TWebDownloader.GetStatusText(URLHandle: HINTERNET): string;
  var
    sbuffersize: integer;
    sbuffer: array[1..1000] of WideChar;
  begin
    Sbuffersize := 1000;
    WinHttpQueryHeaders(URLHandle, WINHTTP_QUERY_STATUS_TEXT,
      WINHTTP_HEADER_NAME_BY_INDEX, @sbuffer[1], sbuffersize,
      WINHTTP_NO_HEADER_INDEX);
    Result := String(WideString(SBuffer));
    SetLength(Result, SbufferSize div 2);
  end;

function TWebDownloader.GetStatusCode(URLHandle: HINTERNET): integer;
  var
    sbuffersize: integer;
  begin
  // return status of transaction
    SBufferSize := Sizeof(Longint);
    WinHttpQueryHeaders(URLHandle,
       WINHTTP_QUERY_STATUS_CODE or WINHTTP_QUERY_FLAG_NUMBER,
       WINHTTP_HEADER_NAME_BY_INDEX, @Result, SBufferSize,
       WINHTTP_NO_HEADER_INDEX);
  end;

function TWebDownloader.getURLHost(inURL: string): string;
// returns the host part of a URL presented
  var
    s1, s2: integer;
  begin
    s1 := pos('//', inURL);
    s2 := s1+2;
    while inURL[s2] <> '/' do
      inc(s2);
    Result := copy(inURL, s1+2, s2-s1-2);
  end;

function TWebDownloader.getURLPath(inURL: string): String;
// returns the path part of a URL presented
  var
    s1: integer;
  begin
    s1 := pos('//', inURL);
    while inURL[s1+2] <> '/' do inc(s1);
    Result := copy(inURL, s1+2, 20000);
  end;

function TWebDownloader.GetRangeString: string;
  // returns a range string based on the low and high ranges inputted.
  var
    outrange: string;
  begin
  // check for stock errors in calling this function, given values are in design
    if not UseDownloadRanges then
      raise EInvalidOp.Create('Invalid function call for settings made.');
    if (HighRange = 0) and (LowRange = 0) then
      raise EInvalidOp.Create('Values must be specified for this function call.');
  // if HighRange not specified then specify lower range & exit
    if HighRange = 0 then
      outrange := 'Range: bytes=' + FloatToStr(LowRange) + '-'
    else
      outrange := 'Range: bytes=' + FloatToStr(LowRange) + '-' + FloatToStr(HighRange);
    Result := OutRange;
  end;

function TWebDownloader.FileSizeEx(savefile: string): Int64;
  // extended file size function.
  type
    QWord = packed record
      Low: DWord;
      High: DWord;
    end;
  var
    SizeOfFile: QWord;
    shandle: THandle;
  begin
    SHandle := CreateFile(PChar(SaveFile), GENERIC_READ or GENERIC_WRITE,
               FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    try
      SizeOfFile.Low := GetFileSize(shandle, @SizeOfFile.High);
      Result := Int64(SizeOfFile);
    finally
      CloseHandle(SHandle);
    end;
  end;

procedure TWebDownloader.CleanUp;
  begin
    if hSession <> nil then WinHttpCloseHandle(hSession);
    if hConnect <> nil then WinHttpCloseHandle(hConnect);
    if hRequest <> nil then WinHttpCloseHandle(hRequest);
    SendMessage(Self.Win_Handle, WM_WEBFINISHED, 0, 0);
  end;

procedure TWebDownloader.Execute;
  var
    dwContext: DWord;
    BytesRead, BytesWritten: dWord;
    SHandle: THandle;
    SaveFile: String;
    siteid, sitepath: string;
    rangestr: string;
    FTimer: DWord;

    ua: WideString;
  begin
    hConnect := nil;
    hRequest := nil;
    ua := UserAgent;
    hSession := WinHttpOpen(PWideChar(ua), WINHTTP_ACCESS_TYPE_DEFAULT_PROXY,
           WINHTTP_NO_PROXY_NAME, WINHTTP_NO_PROXY_BYPASS, 0);
    if Assigned(hSession) then
      begin
        siteid := getURLHost(URL);
        sitepath := getURLPath(URL);
        if hSession <> nil then
          hConnect := WinHttpConnect(hSession, PWideChar(WideString(siteid)), INTERNET_DEFAULT_HTTP_PORT, 0);
        if hConnect <> nil then
          hRequest :=  WinHttpOpenRequest( hConnect, 'GET', PWideChar(WideString(sitepath)), nil,
              WINHTTP_NO_REFERER, WINHTTP_DEFAULT_ACCEPT_TYPES, 0);
        if Assigned(hRequest) then
          begin
            // SaveFilePath needs a '\' on the end if it is not already there
            if SaveFilePath[Length(SaveFilePath)] <> '\' then
              SaveFilePath := SaveFilePath + '\';
          // if download resume, prompt for file now, and set download ranges
            if ResumeDownload then
              begin
                SendMessage(Self.Win_Handle, WM_WEBFILE,
                           Integer(@SaveFilePath), Integer(@LocalFName));
                if LocalFName = '' then
                  begin
                    CleanUp;
                    SetEvent(PropEvent);
                    exit;
                  end;
                SaveFile := SaveFilePath + LocalFName;
                UseDownloadRanges := true;
                LowRange := FileSizeEx(SaveFile);
                HighRange := 0;
              end;
          // this stuff to set range request header
          if UseDownloadRanges then
            begin
              rangestr := GetRangeString;
              WinHttpAddRequestHeaders(hRequest, PWideChar(WideString(rangestr)),
                     Length(rangestr), WINHTTP_ADDREQ_FLAG_ADD_IF_NEW);
            end;
          if not WinHttpSendRequest( hRequest, WINHTTP_NO_ADDITIONAL_HEADERS,
               0, WINHTTP_NO_REQUEST_DATA, 0, 0, dwContext) then
            begin
              StatusCode := GetLastError;
              StatusText := WinHttpSysErrorMessage(StatusCode);
              CleanUp;
              SetEvent(PropEvent);
              exit;
            end;
          if not WinHttpReceiveResponse(hRequest, nil) then
            begin
              StatusCode := GetLastError;
              StatusText := WinHttpSysErrorMessage(StatusCode);
              CleanUp;
              SetEvent(PropEvent);
              exit;
            end;
// all the service routines are here and results need written out
          URL := GetFullURL(hRequest, URL);
          DownloadSize := GetContentLength(hRequest);
          StatusText := GetStatusText(hRequest);
          StatusCode := GetStatusCode(hRequest);
          SetEvent(PropEvent);
          if not ResumeDownload then
            begin
              LocalFName := GetSaveFile(URL);
              SendMessage(Self.Win_Handle, WM_WEBFILE,
                            Integer(@SaveFilePath), Integer(@LocalFName));
              if LocalFName = '' then
                 begin
                   CleanUp;
                   exit;
                 end;
               SaveFile := SaveFilePath + LocalFName;
            end;
          FSizeRead := 0;
          FTimer := timeGetTime;
          if ResumeDownload then
            begin
              SHandle := CreateFile(PChar(SaveFile),
                      GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil,
                      OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
              SetFilePointer(SHandle, 0, nil, FILE_END);
            end
          else
            begin
              SHandle := CreateFile(PChar(SaveFile),
                      GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil,
                      CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
            end;
          FillChar(szBuffer, SizeOf(szBuffer), 0);
          if not WinHttpReadData(hRequest, @szbuffer, sizeof(szbuffer), BytesRead) then
            begin
              StatusCode := GetLastError;
              StatusText := WinHttpSysErrorMessage(StatusCode);
              CleanUp;
              CloseHandle(SHandle);
              exit;
            end;
          while (bytesread > 0) and (not Terminated) do
            begin
              WriteFile(SHandle, szBuffer, BytesRead, BytesWritten, nil);
              FSizeRead := FSizeRead + BytesRead;
              if (timeGetTime - FTimer) > 1000 then
                begin
                  PostMessage(Self.Win_Handle, WM_WEBPROGRESS, FSizeRead, 0);
    //            SendMessage(Self.Win_Handle, WM_WEBPROGRESS, FSizeRead, 0);
                  FSizeRead := 0;
                  FTimer := timeGetTime;
                end;
              FillChar(szBuffer, SizeOf(szBuffer), 0);
              if not WinHttpReadData(hRequest, @szbuffer, sizeof(szbuffer), BytesRead) then
                begin
                  StatusCode := GetLastError;
                  StatusText := WinHttpSysErrorMessage(StatusCode);
                  CleanUp;
                  CloseHandle(SHandle);
                  exit;
                end;
            end;
          SendMessage(Self.Win_Handle, WM_WEBPROGRESS, FSizeRead, 0);
          CloseHandle(SHandle);
          if hConnect <> nil then WinHttpCloseHandle(hConnect);
          if hRequest <> nil then WinHttpCloseHandle(hRequest);
        end
      else
        raise Exception.CreateFmt('Cannot open URL %s', [Url]);
      if hSession <> nil then WinHttpCloseHandle(hSession);
    end
  else
    { NetHandle is not valid. Raise an exception }
    raise Exception.Create('Unable to initialize Winhttp');
  PostMessage(Self.Win_Handle, WM_WEBFINISHED, 0, 0);
end;


procedure Register;
begin
  RegisterComponents('Samples', [THttpDownload]);
end;


end.

Back to Embarcadero: Delphi FAQ Index
Back to Embarcadero: Delphi Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close