Fórum Colocar progressbar na função UrlDownloadToFile #255721

program Project1;

uses
  Forms,
  Unit1 in ´Unit1.pas´ ,
  Unit2 in ´Unit2.pas´;

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DateUtil, StdCtrls, ComCtrls, UrlMon, Unit2;

type
  TForm1 = class(TForm)
    btnDownload: TButton;
    ProgressBar1: TProgressBar;
    procedure FormCreate(Sender: TObject);
    procedure btnDownloadClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    fProgresso: LongInt;
    BSC: TBindStatusCallback;
    function DownloadFile(Source, Dest: String): Boolean;
    procedure SetProgresso(Value: LongInt);
    procedure SetProgressoMaximo(Value: LongInt);
  public
    { Public declarations }
    property Progresso: LongInt read fProgresso write SetProgresso;
    property ProgressoMaximo: LongInt write SetProgressoMaximo;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  BSC := TBindStatusCallback.Create;
end;

function TForm1.DownloadFile(Source, Dest: string): Boolean;
begin
  try
    Result:= UrlDownloadToFile(nil, PChar(source),PChar(Dest), 0, BSC) = 0;
  except
    Result:= False;
  end;
end;

procedure TForm1.SetProgresso(Value: LongInt);
begin
  fProgresso := Value;
  ProgressBar1.Position := Value;
end;

procedure TForm1.SetProgressoMaximo(Value: LongInt);
begin
  if ProgressBar1.Position <> Value then
     ProgressBar1.Max := Value;
end;

procedure TForm1.btnDownloadClick(Sender: TObject);
begin
  ProgressBar1.Position := 0;
  if DownloadFile(´http://www.marcocantu.com/code/md5.zip´, ´C:\md5.zip´) then
     MessageDlg(´OK.´,mtInformation,[mbOK],0)
  else
     MessageDlg(´Erro.´,mtInformation,[mbOK],0);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  BSC.Free;
  BSC := nil;
//  FreeAndNil(BSC);
end;

end.

unit Unit2;

interface

uses
  SysUtils, Windows, UrlMon, ActiveX;

type
  // Implementation of TBindStatusCallback
  TBindStatusCallback = class(TObject, IBindStatusCallback)
  protected
    FRefCount: Integer;
    // IUnknown
    function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    // IBindStatusCallback
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority: Longint): HResult; stdcall;
    function OnLowResource(reserved: DWORD): HResult; stdcall;
    function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
      szStatusText: LPCWSTR): HResult; stdcall;
    function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function OnDataAvailable(grfBSCF: Longint; dwSize: Longint;
      var pformatetc: TFormatEtc; var pstgmed: TSTGMEDIUM): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; const punk: IUnknown): HResult;
      stdcall;
  end;

implementation

uses Unit1;

{ TBindStatusCallback }

function TBindStatusCallback.QueryInterface(const IID: TGUID; out Obj): Integer;
begin
  if GetInterface(IID, Obj) then
     Result := S_OK
  else
     Result := E_NOINTERFACE;
end;

function TBindStatusCallback._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TBindStatusCallback._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

function TBindStatusCallback.GetBindInfo(out grfBINDF: DWORD;
  var bindinfo: TBindInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.GetPriority(out nPriority: Longint): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnDataAvailable(grfBSCF: Longint; dwSize: Longint;
  var pformatetc: TFormatEtc; var pstgmed: TSTGMEDIUM): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnLowResource(reserved: DWORD): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnObjectAvailable(const iid: TGUID;
  const punk: IUnknown): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnStartBinding(dwReserved: DWORD;
  pib: IBinding): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnStopBinding(hresult: HResult;
  szError: LPCWSTR): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBindStatusCallback.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult;
begin
  Form1.ProgressoMaximo := ulProgressMax;
  Form1.Progresso := ulProgress;
  Result := S_OK;
end;

end.