downloaddemo_u.pas

EmbeddedWB_D5-D2009_Version_14.67.8 最新版本,开发WEB浏览器.

//*************************************************************************
//                                                                        *
//                       IEDownload Demo 2009                            *                                                      *
//                            by                                          *
//             Eran Bodankin - bsalsa - ([e-mail])               *
//  Updated versions:                                                     *
//               http://www.bsalsa.com                                    *
//*************************************************************************
{LICENSE:
THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
AND DOCUMENTATION. [YOUR NAME] DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. VSOFT SPECIFICALLY
DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.

You may use, change or modify the component under 3 conditions:
1. In your website, add a link to "http://www.bsalsa.com"
2. In your application, add credits to "Embedded Web Browser"
3. Mail me  ([e-mail]) any code change in the unit
   for the benefit of the other users.
4. Please, consider donation in our web site!
{*******************************************************************************}

unit Downloaddemo_U;

interface

uses
  dialogs, Windows, SysUtils, Classes, Forms, UrlMon, StdCtrls,
  Controls, ComCtrls, SHDocVw_EWB, EwbCore, EmbeddedWB, ExtCtrls, OleCtrls,
  IEDownload, IEDownloadAcc, IEDownloadTools;

type
  TForm1 = class(TForm)
    IEDownload1: TIEDownload;
    Panel1: TPanel;
    btnStart: TButton;
    btnStop: TButton;
    Panel3: TPanel;
    Panel4: TPanel;
    ListView: TListView;
    rgBind: TRadioGroup;
    rgBindMethod: TRadioGroup;
    GroupBox1: TGroupBox;
    ProgressBar1: TProgressBar;
    lblProgress: TLabel;
    GroupBox2: TGroupBox;
    edtFile: TEdit;
    GroupBox3: TGroupBox;
    lblState: TLabel;
    GroupBox4: TGroupBox;
    cbOverWrite: TCheckBox;
    cbOpenFolder: TCheckBox;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    EmbeddedWB1: TEmbeddedWB;
    TabSheet4: TTabSheet;
    memPreviewData: TMemo;
    TabSheet9: TTabSheet;
    memPreviewStream: TMemo;
    TabSheet3: TTabSheet;
    Panel5: TPanel;
    memEvents: TMemo;
    TabSheet5: TTabSheet;
    memResponse: TMemo;
    TabSheet6: TTabSheet;
    memProgress: TMemo;
    TabSheet7: TTabSheet;
    memHeaders: TMemo;
    TabSheet8: TTabSheet;
    memErrors: TMemo;
    TabSheet10: TTabSheet;
    memDetails: TMemo;
    TabSheet2: TTabSheet;
    memSession: TMemo;
    memAddress: TMemo;
    btnStopAll: TButton;
    btnGoList: TButton;
    rgFileExists: TRadioGroup;
    cbAsyn: TCheckBox;
    btnToCache: TButton;
    btnToFile: TButton;
    TabSheet11: TTabSheet;
    lvThread: TListView;
    procedure rgBindClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    function IEDownload1Response(Sender: TBSCB; dwResponseCode: Cardinal;
      szResponseHeaders, szRequestHeaders: PWideChar;
      out szAdditionalRequestHeaders: PWideChar): HRESULT;
    procedure IEDownload1Resume(Sender: TBSCB; FileName: string;
      var Action: Cardinal);
    function IEDownload1GetWindow(Sender: TBSCB; const GUIDReason: TGUID;
      out hwnd: Cardinal): HRESULT;
    procedure IEDownload1DataAvailable(Sender: TBSCB; var Buffer: PByte;
      var BufLength: Cardinal);
    function IEDownload1BeginningTransaction(Sender: TBSCB; szURL,
      szHeaders: PWideChar; dwReserved: Cardinal;
      out szAdditionalHeaders: PWideChar): HRESULT;
    procedure btnStopClick(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    function IEDownload1SecurityProblem(Sender: TBSCB; dwProblem: Cardinal;
      Problem: string): HRESULT;
    procedure IEDownload1StartBinding(var Sender: TBSCB; var Cancel: Boolean;
      pib: IBinding);
    procedure IEDownload1GetBindResults(var Sender: TBSCB;
      out clsidProtocol: TGUID; out dwResult: Cardinal; out szResult: PWideChar;
      const stResult: string);
    procedure IEDownload1StateChange(State: TState);
    procedure IEDownload1Authenticate(Sender: TBSCB; var tmpHWND: HWND;
      var szUserName, szPassWord: WideString; var Rezult: HRESULT);
    procedure IEDownload1Error(const ErrorCode: Integer; const stError: string);
    function IEDownload1CodeInstallProblem(Sender: TBSCB;
      ulStatusCode: Cardinal; szDestination, szSource: PWideChar;
      dwReserved: Cardinal; stResult: string): HRESULT;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    function IEDownload1GetRootSecurityId(var SecurityIdBuffer: TByteArray;
      var BufferSize: Cardinal): HRESULT;
    procedure IEDownload1Redirect(Sender: TBSCB; var AbortRedirect: Boolean;
      const FromUrl, DestUrl: string);
    procedure IEDownload1DataAvailableInfo(Sender: TBSCB; grfBSCF: Cardinal;
      Status: string);
    procedure btnStopAllClick(Sender: TObject);
    procedure btnGoListClick(Sender: TObject);
    procedure IEDownload1FileExists(var Action: TFileExistsOption;
      const aFileName: WideString; var NewFileName: WideString);
    procedure IEDownload1StopBinding(Sender: TBSCB; HRESULT: HRESULT;
      szError: PWideChar);
    function IEDownload1GetBindInfo(Sender: TBSCB; out grfBINDF: Cardinal;
      var BindInfo: _tagBINDINFO): HRESULT;
    procedure btnToCacheClick(Sender: TObject);
    procedure btnToFileClick(Sender: TObject);
    procedure IEDownload1Connect(Sender: TBSCB; Res: HRESULT;
      stMessage: string);
    procedure IEDownload1StreamComplete(Sender: TBSCB; Stream: TStream;
      Result: HRESULT);
    procedure IEDownload1Terminate(const Sender: TBSCB; const ThreadId: Integer;
      const aFileName: WideString; var bCancel: Boolean);
    procedure IEDownload1Complete(Sender: TIEDownload; aFileNameAndPath,
      aFileName, aFolderName, aExtension: WideString;
      const ActiveConnections: Integer);
    function IEDownload1GetBindInfoEx(Sender: TBSCB; out grfBINDF: Cardinal;
      pbindinfo: _tagBINDINFO; out grfBINDF2: Cardinal): HRESULT;
    procedure IEDownload1AuthenticateEx(Sender: TBSCB; var tmpHWND: HWND;
      var szUserName, szPassWord: WideString; pauthinfo: _tagAUTHENTICATEINFO;
      var Rezult: HRESULT);
    function IEDownload1GetSerializedClientCertContext(var Sender: TBSCB;
      out ppbCert: Byte; var pcbCert: Cardinal): HRESULT;
    function IEDownload1PutProperty(Sender: TBSCB; mkp: _MONIKERPROPERTY;
      val: PWideChar): HRESULT;
    procedure IEDownload1Progress(Sender: TBSCB; ulProgress, ulProgressMax,
      ulStatusCode, FileSize: Cardinal; szStatusText: PWideChar; Downloaded,
      ElapsedTime, Speed, RemainingTime, Status, Percent: string);
  private
    { Private declarations }
    tmpString: string;
    counter: integer;
    procedure ClearComponents;
    procedure InitialComponents;
    procedure UpdateThreadDetails(aSender: TBSCB);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btnStopAllClick(Sender: TObject);
begin
  IEDownload1.CancelAll;
  counter := 0;
end;

procedure TForm1.btnStopClick(Sender: TObject);
begin
  IEDownload1.Cancel;
  counter := 0;
end;

procedure TForm1.btnToCacheClick(Sender: TObject);
begin
  ClearComponents;
  InitialComponents;
  IEdownload1.UrlDownloadToCacheFile(memAddress.Lines[0]);
end;

procedure TForm1.btnToFileClick(Sender: TObject);
begin
  ClearComponents;
  InitialComponents;
  IEdownload1.UrlDownloadToFile(memAddress.Lines[0]);
end;

procedure TForm1.btnGoListClick(Sender: TObject);
var
  sl: TStrings;
begin
  ClearComponents;
  InitialComponents;
  sl := TStringList.Create;
  try
    with sl do
    begin
      Add('http://www.bsalsa.com/Downloads/2.exe');
      Add('http://www.bsalsa.com/Downloads/2.rar');
      Add('http://www.bsalsa.com/support.html');
    end;
    memAddress.Clear;
    memAddress.Lines := sl;
    IEdownload1.GoList(sl);
  finally
    sl.Free;
  end;
end;

procedure TForm1.btnStartClick(Sender: TObject);
begin
  ClearComponents;
  InitialComponents;
  IEdownload1.Go(memAddress.Lines[0]);
  MemSession.Lines:= IEdownload1.ItemsManager.SessionList;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if IEDownload1.ActiveConnections > 0 then
  begin
  if MessageDlg('Threads active. Do you still want to quit?',
      mtWarning, [mbYes, mbNo], 0) = mrNo then
      CanClose:= False
      else
      IEDownload1.CancelAll;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PageControl1.ActivePageIndex := 0;
  cbOverWrite.Checked := True;
  cbAsyn.Checked := True;
  cbOpenFolder.Checked := True;
  rgBindMethod.ItemIndex := 0;
  rgBind.ItemIndex := 0;
  rgFileExists.ItemIndex := 0;
end;

procedure TForm1.rgBindClick(Sender: TObject);
begin
  cbOpenFolder.Enabled := not (rgBind.ItemIndex = 1);
end;

procedure TForm1.IEDownload1DataAvailable(Sender: TBSCB; var Buffer: PByte;
  var BufLength: Cardinal);
{Use the OnData event to get the data for parsing/editing '
 on the fly'. }
begin
  inc(counter);
  if counter = 1 then {Just so you will not see the event fires several times}
    memEvents.Lines.Add('Data Available Event.');
  memPreviewData.Lines.Add(PChar(Buffer));
  // memPreviewData.Lines.Add(string(AnsiString(Buffer)));
end;

procedure TForm1.IEDownload1DataAvailableInfo(Sender: TBSCB; grfBSCF: Cardinal;
  Status: string);
begin
  if tmpString <> Status then
    {Just so you will not see the event fires several times}
    memEvents.Lines.Add('Data Available Info Event:' + Status);
  tmpString := status;
end;

procedure TForm1.IEDownload1Error(const ErrorCode: Integer;
  const stError: string);
begin
  memEvents.Lines.Add('Error Event.' + stError);
  memErrors.Lines.Add('An error accrued:  ' + stError);
  PageControl1.ActivePageIndex := 8;
end;

procedure TForm1.IEDownload1FileExists(var Action: TFileExistsOption;
  const aFileName: WideString; var NewFileName: WideString);

begin
  memEvents.Lines.Add('File Exists Event: ' + aFileName);
  case rgFileExists.ItemIndex of
    0: Action := feOverWrite;
    1:
      begin
        Action := feRename;
        TimeSeparator := '_';
        NewFileName := Inputbox('IE Downloader - File exist warning',
          'Please type a new file name', TimeToStr(now) + '_' +
          IEDownload1.FileName);
        if NewFileName = '' then
          Action := feSkip;
      end;
    2:
      begin
        showmessage('The file exists. Operation aborted.');
        EmbeddedWb1.LoadFromString('The file exists. Operation aborted.');
        Action := feSkip;
      end;
  end;
end;

procedure TForm1.IEDownload1Authenticate(Sender: TBSCB; var tmpHWND: HWND;
  var szUserName, szPassWord: WideString; var Rezult: HRESULT);
begin
  memEvents.Lines.Add('Authenticate Event.' + #13#10 +
    ResponseCodeToStr(Rezult));
  if (szUserName <> '') or (szPassWord <> '') then
  begin
    memEvents.Lines.Add('UserName : ' + szUserName);
    memEvents.Lines.Add('Password : ' + szPassWord)
  end;
end;

procedure TForm1.IEDownload1AuthenticateEx(Sender: TBSCB; var tmpHWND: HWND;
  var szUserName, szPassWord: WideString; pauthinfo: _tagAUTHENTICATEINFO;
  var Rezult: HRESULT);
begin
  memEvents.Lines.Add('AuthenticateEx Event.' + #13#10 +
    ResponseCodeToStr(Rezult));
  if (szUserName <> '') or (szPassWord <> '') then
  begin
    memEvents.Lines.Add('UserName : ' + szUserName);
    memEvents.Lines.Add('Password : ' + szPassWord)
  end;
end;

function TForm1.IEDownload1BeginningTransaction(Sender: TBSCB; szURL,
  szHeaders: PWideChar; dwReserved: Cardinal;
  out szAdditionalHeaders: PWideChar): HRESULT;
{Use OnBeginningTransaction to add additionally headers to the
 transaction.}
begin