unit Url;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ProgressBar1: TProgressBar;
    StaticText1: TStaticText;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TLoadThread = class(TThread)
  protected
    FResult:String;
    procedure Execute; override;
    procedure ShowResult;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  UrlMon,//UrlDownloadToFile
  ActiveX,//PFormatEtc
  CommCtrl;//PBM_SETPOS

type
  TDownload = class(TInterfacedObject,IBindStatusCallBack)
    FWndProgress:HWND;
    FWndStatic:HWND;
///////////////////////////////////////////////////////
    FAbort:Boolean;
///////////////////////////////////////////////////////
    FMsg:String;
    function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
    function GetPriority(out nPriority): 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: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
      stgmed: PStgMedium): HResult; stdcall;
    function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
  end;

var
  dnld:TDownload;


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

function TDownload.GetPriority(out nPriority): HResult; stdcall;
begin
  Result:=E_NOTIMPL;
end;

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

function TDownload.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
  szStatusText: LPCWSTR): HResult; stdcall;
var
  newPos:Integer;
begin
  case ulStatusCode of
    BINDSTATUS_CONNECTING,BINDSTATUS_SENDINGREQUEST,BINDSTATUS_REDIRECTING:
      begin FMsg:='Соединение...'; sleep(1000) end;
    BINDSTATUS_DOWNLOADINGDATA:
      begin FMsg:='Загрузка...'; sleep(1000) end;
    BINDSTATUS_USINGCACHEDCOPY:
      begin FMsg:='Загрузка из кэша...'; sleep(1000) end;
    else FMsg:='';
  end;
  if ulStatusCode=BINDSTATUS_ENDDOWNLOADDATA then newPos:=100
  else if ulProgressMax=0 then newPos:=0
      else newPos:=((ulProgress*100) div ulProgressMax);
  if FWndProgress<>0 then
  begin
    SendMessage(FWndProgress,PBM_SETPOS,newPos,0);
    SendMessage(FWndStatic,WM_SETTEXT,0,Integer(FMsg));
  end;
///////////////////////////////////////////////////////
  if FAbort then
  begin
    FAbort:=False;
    Result:=E_ABORT;
    Exit;
  end;
///////////////////////////////////////////////////////
  Result:=S_OK;
end;

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

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

function TDownload.OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc;
  stgmed: PStgMedium): HResult; stdcall;
begin
  Result:=E_NOTIMPL;
end;

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

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  dnld:=TDownload.Create;
  dnld.FWndProgress:=Form1.ProgressBar1.Handle;
  dnld.FWndStatic:=Form1.StaticText1.Handle;
  try
    Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile),
      0, IBindStatusCallBack(dnld)) = 0;
  except
    Result := False;
  end;
  SendMessage(dnld.FWndProgress,PBM_SETPOS,0,0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  lt:TLoadThread;
begin
  lt:=TLoadThread.Create(False);
  lt.FreeOnTerminate:=True;
  lt.Resume;
end;

procedure TLoadThread.Execute;
const
  SourceFile = 'ftp://adsl.cheb.ru/Firefox_Setup_3.0.8.exe';
  DestFile = 'c:\tmp.exe ';
begin
  if DownloadFile(SourceFile, DestFile) then
    FResult:='Файл загружен!'
  else
    FResult:='Ошибка при загрузке - '+ SourceFile;
  Synchronize(ShowResult);
end;

procedure TLoadThread.ShowResult;
begin
  ShowMessage(FResult);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  dnld.FAbort:=True;
  ShowMessage(dnld.ClassName);
end;

end.