//************************************************************************* // * // IEDownload 2009 * // IEDownload is a UrlMon wrapper with a build-in Callback * // * // Freeware Component * // for Delphi by * // Eran Bodankin * // and Per Lindsų Larsen * // * // * // 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. BSALSA PRODUCTIONS 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. BSALSA PRODUCTIONS SPECIFICALLY DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE. You may use, change or modify the component under 4 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 (bsalsa@gmail.com) any code change in the unit for the benefit of the other users. 4. Please, consider donation in our web site! {*******************************************************************************} //$Id: IEDownload.pas,v 1.6 2009/02/25 11:56:31 bsalsa Exp $ unit IEDownload; {To use the MSHTML, just remove the dot in the line below like {$DEFINE USE_MSHTML}{ and re-compile the package.} {$DEFINE USE_MSHTML} interface {$I EWB.inc} uses Dialogs, IEDownloadAcc, Controls, Shellapi, IEConst, ActiveX, Contnrs, ExtCtrls, Windows, WinInet, UrlMon, Classes, SysUtils {$IFDEF DELPHI5}, FileCtrl{$ENDIF}{$IFDEF USE_MSHTML}, MSHTML_EWB{$ENDIF}; const WAIT_BSCB = WAIT_OBJECT_0 + 1; {$IFNDEF UNICODE} type RawByteString = AnsiString; {$ENDIF UNICODE} type TProxySettings = class(TPersistent) private FPort: Integer; FServer: string; FAutoLoadProxy: Boolean; public function SetProxy(const FullUserAgent, ProxyServer: string): Boolean; published property AutoLoadProxy: Boolean read FAutoLoadProxy write FAutoLoadProxy default False; property Port: Integer read FPort write FPort default 80; property Server: string read FServer write FServer; end; TCustomIEDownload = class; TInfoData = class(TList) public infAdditionalHeader: TStrings; infBindF_Value: Cardinal; infBindF2_Value: Cardinal; infBindInfoF_Value: Cardinal; infBindInfoOptions_Value: Cardinal; infBindVerb_Value: Cardinal; infCodePage_Value: Cardinal; infCustomVerb: string; infDescriptor: RawByteString; infDownloadFolder: string; infExtraInfo: string; infFileExt: string; infFileName: string; infFileSize: Cardinal; infHost: string; infIndex: Integer; infInheritHandle: Boolean; infPassword: string; infPostData: string; infPutFileName: string; infRangeBegin: Cardinal; infRangeEnd: Integer; infSender: TCustomIEDownload; infTimeOut: Integer; infUrl: PWideChar; infUserAgent: string; infUserName: string; Sender: TObject; public constructor Create; destructor Destroy; override; end; TThreadStatus = (tsRunning, tsSuspended, tsWaiting, tsTerminated); TState = (sBusy, sReady, sStopped); TBSCB = class(TThread, IAuthenticate, {$IFDEF DELPHI6_UP} IAuthenticateEx, IMonikerProp, {$ENDIF} IBindHost, IWindowForBindingUI, IBindStatusCallback, IBindStatusCallbackEx, ICodeInstall, IHttpNegotiate, IHttpNegotiate2, IHttpNegotiate3, IHTTPSecurity, {$IFDEF USE_MSHTML} IPropertyNotifySink, {$ENDIF} IServiceProvider, IUnknown) private Frequency: Int64; TimeStarted: Int64; TimeNow: Int64; FSender: TCustomIEDownload; FBindCtx: IBindCtx; FBSCBTimer: TTimer; FDataSize: Integer; FGlobalData: HGLOBAL; FMoniker: IMoniker; FRedirect: Boolean; fOutStream: IStream; FTimedOut: Boolean; FTotalRead: Cardinal; m_pPrevBSCB: IBindStatusCallback; fsOutputFile: TFileStream; function GetSerializedClientCertContext(out ppbCert: Byte; var pcbCert: DWORD): HResult; stdcall; {$IFDEF DELPHI6_UP} function AuthenticateEx(out phwnd: HWND; out pszUsername, pszPassword: LPWSTR; var pauthinfo: AUTHENTICATEINFO): HResult; stdcall; {IMonikerProp Interface} function PutProperty(mkp: MONIKERPROPERTY; val: LPCWSTR): HResult; stdcall; {$ENDIF} {IBindStatusCallbackEx} function GetBindInfoEx(out grfBINDF: DWORD; var pbindinfo: BINDINFO; out grfBINDF2: DWORD; out pdwReserved: DWORD): HResult; stdcall; {$IFDEF USE_MSHTML} {IPropertyNotifySink Interface} function OnChanged(dispId: TDispId): HRESULT; stdcall; function OnRequestEdit(dispId: TDispId): HRESULT; stdcall; {$ENDIF} {IHttpNegotiate2 Interface} function GetRootSecurityId(var SecurityIdBuffer: TByteArray; var BufferSize: DWord; dwReserved: DWORD): HResult; stdcall; {IBindStatusCallback Interface} function GetBindInfo(out grfBINDF: DWORD; var BindInfo: TBindInfo): HRESULT; stdcall; function GetPriority(out nPriority): HRESULT; stdcall; function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; FormatEtc: PFormatEtc; stgmed: PStgMedium): HRESULT; stdcall; function OnLowResource(Reserved: DWORD): HRESULT; stdcall; function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG; szStatusText: LPCWSTR): HRESULT; stdcall; function OnObjectAvailable(const IID: TGUID; punk: IUnknown): HRESULT; stdcall; function OnStartBinding(dwReserved: DWORD; pib: IBinding): HRESULT; stdcall; function OnStopBinding(HRESULT: HRESULT; szError: LPCWSTR): HRESULT; stdcall; function OnSecurityProblem(dwProblem: DWORD): HRESULT; stdcall; {IHTTPNegotiate methods} function OnResponse(dwResponseCode: DWORD; szResponseHeaders, szRequestHeaders: LPCWSTR; out szAdditionalRequestHeaders: LPWSTR): HRESULT; stdcall; function BeginningTransaction(szURL, szHeaders: LPCWSTR; dwReserved: DWORD; out szAdditionalHeaders: LPWSTR): HRESULT; stdcall; {IUnknown Interface} function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; {IWindowForBindingUI methods} function GetWindow(const GUIDReason: TGUID; out hwnd): HRESULT; stdcall; {IAuthenticate Interface} function Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR): HResult; stdcall; {ICodeInstall Interface} function OnCodeInstallProblem(ulStatusCode: ULONG; szDestination, szSource: LPCWSTR; dwReserved: DWORD): HResult; stdcall; {IBindHost Interface} function CreateMoniker(szName: POLEStr; BC: IBindCtx; out mk: IMoniker; dwReserved: DWORD): HResult; stdcall; function MonikerBindToStorage(Mk: IMoniker; BC: IBindCtx; BSC: IBindStatusCallback; const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult; stdcall; function MonikerBindToObject(Mk: IMoniker; BC: IBindCtx; BSC: IBindStatusCallback; const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult; stdcall; {IServiceProvider Interface} function QueryService(const rsid, iid: TGUID; out Obj): HRESULT; stdcall; function GetBindResult(out clsidProtocol: TCLSID; out dwResult: DWORD; out szResult: POLEStr): HRESULT; private function CheckCancelState: Integer; procedure ClearAll; procedure TimerExpired(Sender: TObject); procedure DoConnect; procedure DoDownloadToFile; procedure DoDownloadToCache; procedure ReceiveData; procedure ReturnData; procedure GetData(aSender: TCustomIEDownload); procedure SetComponents; protected procedure Execute; override; procedure Suspend; procedure Terminate; procedure Resume; public Stream: TStream; Binding: IBinding; BscbInfo: TInfoData; ThreadStatus: TThreadStatus; constructor Create(aSender: TCustomIEDownload; const pmk: IMoniker; const pbc: IBindCtx; CreateSuspended: boolean); destructor Destroy; override; function QueryInfoFileName: HRESULT; function DoSaveFileAs: string; function QueryInfo(dwOption: DWORD; var Info: Cardinal): Boolean; overload; function QueryInfo(dwOption: DWORD; var Info: string): Boolean; overload; function QueryInfo(dwOption: DWORD; var Info: TDateTime): Boolean; overload; function IsRunning: Boolean; function GetDisplayName: PWideChar; function GetFileNameFromUrl(Url: string): string; function AbortBinding: Hresult; function MkParseDisplayName(var DisplayName: PWideChar): IMoniker; end; TBSCBList = class(TObjectList) {by Jury Gerasimov} private function GetItem(Index: Integer): TBSCB; procedure SetItem(Index: Integer; Value: TBSCB); public SessionList: TStrings; constructor Create; destructor Destroy; override; property Items[Index: Integer]: TBSCB read GetItem write SetItem; default; function byURL(Url: string): TBSCB; end; TSecurity = class(TPersistent) private FInheritHandle: Boolean; FDescriptor: RawByteString; published property InheritHandle: boolean read FInheritHandle write FInheritHandle default False; property Descriptor: RawByteString read FDescriptor write FDescriptor; end; TRange = class(TPersistent) private FRangeBegin: Integer; FRangeEnd: Integer; published property RangeBegin: Integer read FRangeBegin write FRangeBegin default 0; property RangeEnd: Integer read FRangeEnd write FRangeEnd default 0; end; {http://msdn.microsoft.com/en-us/library/ms775130(VS.85).aspx} TBindF = (Asynchronous, AsyncStorage, NoProgressiveRendering, OfflineOperation, GetNewestVersion, NoWriteCache, NeedFile, PullData, IgnoreSecurityProblem, Resynchronize, AllowHyperlink, No_UI, SilentOperation, Pragma_No_Cache, GetClassObject, Reserved_1, Free_Threaded, DirectReadIgnoreSize, HandleAsFormsSubmit, GetFromCacheIfNetFail, FromUrlmon, FisrtTryCache, PreferDefaultHandler, RestrictedSitesZone); TBindF_Options = set of TBindF; TBindF2 = (DisableBasicAuth, DisableAutoCookie, DisableRedirectUnlessSID, ReadDataOver4GB, Reserved_2, Reserved_11); TBindF2_Options = set of TBindF2; TBindInfoF = (PostData, ExtraInfo); TBindInfoF_Options = set of TBindInfoF; TBindInfoOption = (UseBindInfoOptions, EnableUtf8, DisableUtf8, UseIE_Encoding, BindToObject, SecurityOptOut, IgnoreMimeTextPlain, UseBindStrCredentials, IgnoreHttp2HttpsRedirect, IgnoreSslErrOnce, WpcDownloadBlocked, WpcLoggingEnabled, DisableAutoRedirect, ShDocVw_Reserved, AllowConnectMessages); TBindInfoOptions_Options = set of TBindInfoOption; TBindVerb = (Get, Post, Put, Custom); TCodePageOption = ( Ansi, {default to ANSI code page} OEM, {default to OEM code page} Mac, {default to MAC code page} ThreadsAnsi, {Current thread's ANSI code page} Symbol, {Symbol code page (42)} UTF7, {Translate using UTF-7} UTF8); {Translate using UTF-8} TDownloadTo = (dtNormal, dtDownloadToFile, dtDownloadToCache, dtMoniker); TDownloadMethod = (dmStream, dmFile); {Set download to a file or astream} TFileExistsOption = (feOverWrite, feSkip, feRename); {If file exsits then..} TQueryInterfaceEvent = function(const IID: TGUID; out Obj): HRESULT of object; TAuthenticateEvent = procedure(Sender: TBSCB; var tmpHWND: HWnd; var szUserName, szPassWord: WideString; var Rezult: HRESULT) of object; {$IFDEF DELPHI6_UP} TAuthenticateExEvent = procedure(Sender: TBSCB; var tmpHWND: HWnd; var szUserName, szPassWord: WideString; pauthinfo: AUTHENTICATEINFO; var Rezult: HRESULT) of object; TOnPutPropertyEvent = function(Sender: TBSCB; mkp: MONIKERPROPERTY; val: LPCWSTR): HResult of object; {$ENDIF} TOnCodeInstallProblemEvent = function(Sender: TBSCB; ulStatusCode: ULONG; szDestination, szSource: LPCWSTR; dwReserved: DWORD; stResult: string): HRESULT of object; TStateChangeEvent = procedure(const State: TState) of object; TErrorEvent = procedure(const ErrorCode: integer; const stError: string) of object; TOnConnectEvent = procedure(Sender: TBSCB; Res: HRESULT; stMessage: string) of object; TOnGetBindInfoEvent = function(Sender: TBSCB; out grfBINDF: DWORD; var BindInfo: TBindInfo): HRESULT of object; TOnGetBindInfoExEvent = function(Sender: TBSCB; out grfBINDF: DWORD; pbindinfo: BINDINFO; out grfBINDF2: DWORD): HRESULT of object; TRedirect = procedure(Sender: TBSCB; var AbortRedirect: boolean; const FromUrl: string; const DestUrl: string) of object; TBeginningTransactionEvent = function(Sender: TBSCB; szURL, szHeaders: LPCWSTR; dwReserved: DWORD; out szAdditionalHeaders: LPWSTR): HRESULT of object; TOnResponseEvent = function(Sender: TBSCB; dwResponseCode: DWORD; szResponseHeaders, szRequestHeaders: LPCWSTR; out szAdditionalRequestHeaders: LPWSTR): HRESULT of object; TOnSecurityProblemEvent = function(Sender: TBSCB; dwProblem: DWORD; Problem: string): HRESULT of object; TFileExistsEvent = procedure(var Action: TFileExistsOption; const aFileName: WideString; var NewFileName: WideString) of object; TOnProgressEvent = procedure(Sender: TBSCB; ulProgress, ulProgressMax, ulStatusCode, FileSize: ULONG; szStatusText: LPCWSTR; Downloaded, ElapsedTime, Speed, RemainingTime, Status, Percent: string) of object; TOnDataAvailableEvent = procedure(Sender: TBSCB; var Buffer: PByte; var BufLength: Cardinal) of object; TOnDataAvailableInfoEvent = procedure(Sender: TBSCB; grfBSCF: DWORD; Status: string {; FormatEtc: PFormatEtc}) of object; TOnCompleteEvent = procedure(Sender: TCustomIEDownload; aFileNameAndPath, aFileName, aFolderName, aExtension: WideString; const ActiveConnections: Integer) of object; TOnStreamCompleteEvent = procedure(Sender: TBSCB; Stream: TStream; Result: HRESULT) of object; TOnResumeEvent = procedure(Sender: TBSCB; FileName: string; var Action: Cardinal) of object; TGetWindowEvent = function(Sender: TBSCB; const GUIDReason: TGUID; out hwnd: LongWord): HRESULT of object; TOnStartBindingEvent = procedure(Sender: TBSCB; var Cancel: Boolean; pib: IBinding; const FileName: WideString; const FileSize: integer) of object; TOnStopBindingEvent = procedure(Sender: TBSCB; HRESULT: HRESULT; szError: LPCWSTR) of object; TOnGetBindResultsEvent = procedure(var Sender: TBSCB; out clsidProtocol: TCLSID; out dwResult: DWORD; out szResult: POLEStr; const stResult: string) of object; TOnGetClientCertEvent = function(var Sender: TBSCB; out ppbCert: Byte; var pcbCert: DWORD): HResult of object; TTerminateEvent = procedure(const Sender: TBSCB; const ThreadId: Integer; const aFileName: Widestring; var bCancel: Boolean) of object; TOnGetRootSecurityIdEvent = function(var SecurityIdBuffer: TByteArray; var BufferSize: DWord): HRESULT of object; {IServiceProvider Interface} TQueryServiceEvent = procedure(Sender: TObject; const rsid, iid: TGUID; var Obj: IUnknown) of object; TOnBeforeDownloadEvent = procedure(Sender: TInfoData; const Url, FileName, FileExtension, Host, DownloadFolder: string; const FileSize: Integer; var Cancel: Boolean) of object; TCustomIEDownload = class(TComponent) private FAbout: string; bCancelAll: boolean; bDone: boolean; bRenamed: boolean; BS: TBSCB; FActiveConnections: integer; FAdditionalHeader: TStrings; FBeginningTransaction: TBeginningTransactionEvent; FBindF: TBindF_Options; FBindF_Value: Cardinal; FBindF2: TBindF2_Options; FBindF2_Value: Cardinal; FBindInfoF: TBindInfoF_Options; FBindInfoF_Value: Cardinal; FBindInfoOption_: TBindInfoOptions_Options; FBindInfoOption_Value: Cardinal; FBindVerb: TBindVerb; FBindVerb_Value: Cardinal; FBusy: Boolean; FCancel: Boolean; FCodePageOption: TCodePageOption; FCodePageValue: Cardinal; FCustomVerb: string; FDefaultProtocol: string; FDefaultUrlFileName: string; FDisplayName: PWideChar; FdlCounter: integer; FDownloadedFile: string; FDownloadFolder: string; FDownloadMethod: TDownloadMethod; FDownloadTo: TDownloadTo; FExtraInfo: string; FFileExistsOption: TFileExistsOption; FFileExtension: string; FFileName: string; FFileSize: ULong; FFullUserAgent: string; FGetWindow: TGetWindowEvent; FHWnd: HWND; FMimeType: string; FOnAuthenticate: TAuthenticateEvent; {$IFDEF DELPHI6_UP} FOnAuthenticateEx: TAuthenticateExEvent; FOnPutProperty: TOnPutPropertyEvent; {$ENDIF} FOnCodeInstallProblem: TOnCodeInstallProblemEvent; FOnComplete: TOnCompleteEvent; FOnConnect: TOnConnectEvent; FOnBeforeDownload: TOnBeforeDownloadEvent; FOnDataAvailable: TOnDataAvailableEvent; FOnDataAvailableInfo: TOnDataAvailableInfoEvent; FOnError: TErrorEvent; FOnFileExists: TFileExistsEvent; FOnGetBindInfo: TOnGetBindInfoEvent; FOnGetBindInfoEx: TOnGetBindInfoExEvent; FOnGetBindResults: TOnGetBindResultsEvent; FOnGetClientCert: TOnGetClientCertEvent; FOnGetRootSecurityId: TOnGetRootSecurityIdEvent; FOnProgress: TOnProgressEvent; FOnQueryInterface: TQueryInterfaceEvent; FOnQueryService: TQueryServiceEvent; FOnRedirect: TRedirect; FOnResponse: TOnResponseEvent; FOnResume: TOnResumeEvent; FOnSecurityProblem: TOnSecurityProblemEvent; FOnStartBinding: TOnStartBindingEvent; FOnStateChange: TStateChangeEvent; FOnStopBinding: TOnStopBindingEvent; FOnStreamComplete: TOnStreamCompleteEvent; FOnTerminate: TTerminateEvent; FOpenDownloadFolder: Boolean; FPassword: string; FPostData: string; FProxySettings: TProxySettings; FPutFileName: string; FRange: TRange; FRefCount: Integer; FSecurity: TSecurity; FServerAddress: string; FServerIP: string; FStartTick: Integer; FState: TState; FTimeOut: Integer; FUrl: string; FUserAgent: string; FUserName: string; FUseSystemDownloadFolder: boolean; FValidateUrl: boolean; hProcess: THandle; hStop: THandle; private function GoAction(const actUrl, actFileName, actDownloadFolder: string; pmk: IMoniker; pbc: IBindCtx): boolean; function GoInit(const inUrl: string; const inFileName: string; const inDownloadFolder: string): boolean; function SetDownloadFolder(const aDownloadFolder: string): string; function SetHttpProtocol(const aUrl: string): string; procedure DoUpdate; procedure ExtractDataFromFile(const aFileName: string); procedure PrepareForExit; procedure PrepareForStart; procedure SetAbout(Value: string); procedure SetAdditionalHeader(const Value: TStrings); procedure SetBeforeExit; procedure SetBindF(const Value: TBindF_Options); procedure SetBindF2(const Value: TBindF2_Options); procedure SetBindInfoF(const Value: TBindInfoF_Options); procedure SetBindInfoOption(const Value: TBindInfoOptions_Options); procedure SetBindVerb(const Value: TBindVerb); procedure SetCodePage(const Value: TCodePageOption); procedure SetDefaultProtocol(const Value: string); procedure SetDownloadMethod(const Value: TDownloadMethod); procedure SetFileName(const Value: string); procedure SetUserAgent; procedure Update_BindF_Value; procedure Update_BindF2_Value; procedure Update_BindInfoF_Value; procedure Update_BindInfoOptions_Value; public ItemsManager: TBSCBList; constructor Create(AOwner: TComponent); override; destructor Destroy; override; function CheckFileExists(const aFileName: string): boolean; function CodeInstallProblemToStr(const ulStatusCode: Integer): string; function FormatSize(const Byte: Double): string; function FormatTickToTime(const TickCount: Cardinal): string; function IsAsyncMoniker(const pmk: IMoniker): HRESULT; function IsSynchronous(iedInfo: TInfoData): boolean; function IsUrlValid(const isUrl: string): Boolean; function OpenFolder(const aFolderName: string): Boolean; function ResponseCodeToStr(const dwResponse: Integer): string; function SetFileNameFromUrl(const aUrl: string): string; function URLDownloadToCacheFile(const aUrl: string): string; function UrlDownloadToFile(const aUrl: string): HRESULT; function WaitForProcess(var EventName: THandle; var aStartTick, aTimeOut: Integer): Boolean; function WideStringToLPOLESTR(const Source: string): POleStr; procedure BeforeDestruction; override; procedure Cancel(const Item: TBSCB); overload; procedure Cancel; overload; procedure Reset; procedure CancelAll; procedure Download(const pmk: IMoniker; const pbc: IBindCtx); overload; procedure Go(const aUrl: string); overload; procedure Go(const aUrl: string; const aFileName: string); overload; procedure Go(const aUrl: string; const aFileName: string; const aDownloadFolder: string); overload; procedure GoList(const UrlsList: TStrings); overload; procedure GoList(const UrlsList: TStrings; const FileNameList: TStrings); overload; procedure GoList(const UrlsList: TStrings; const FileNameList: TStrings; const DownloadFolderList: TStrings); overload; procedure Loaded; override; procedure Resume; procedure Suspend; public property ActiveConnections: integer read FActiveConnections; property Busy: Boolean read FBusy; property DisplayName: PWideChar read FDisplayName; property DownloadedFile: string read FDownloadedFile; property DownloadsCounter: integer read FdlCounter; property FileExtension: string read FFileExtension; property FileSize: ULong read FFileSize; property MimeType: string read FMimeType; property ServerAddress: string read FServerAddress; property ServerIP: string read FServerIP; property State: TState read FState; published property About: string read FAbout write SetAbout; property AdditionalHeader: TStrings read FAdditionalHeader write SetAdditionalHeader; property BindF: TBindF_Options read FBindF write SetBindF default [Asynchronous, AsyncStorage, PullData, NoWriteCache, GetNewestVersion]; property BindF2: TBindF2_Options read FBindF2 write SetBindF2 default [ReadDataOver4GB]; property BindInfoF: TBindInfoF_Options read FBindInfoF write SetBindInfoF default []; property BindVerb: TBindVerb read FBindVerb write SetBindVerb default Get; property BindInfoOptions: TBindInfoOptions_Options read FBindInfoOption_ write SetBindInfoOption default [UseBindInfoOptions, AllowConnectMessages]; property CodePage: TCodePageOption read FCodePageOption write SetCodePage default Ansi; property CustomVerb: string read FCustomVerb write FCustomVerb; property DefaultProtocol: string read FDefaultProtocol write SetDefaultProtocol; property DefaultUrlFileName: string read FDefaultUrlFileName write FDefaultUrlFileName; property DownloadFolder: string read FDownloadFolder write FDownloadFolder; property DownloadMethod: TDownloadMethod read FDownloadMethod write SetDownloadMethod default dmFile; property ExtraInfo: string read FExtraInfo write FExtraInfo; property FileExistsOption: TFileExistsOption read FFileExistsOption write FFileExistsOption default feOverwrite; property FileName: string read FFileName write SetFileName; property OnAuthenticate: TAuthenticateEvent read FOnAuthenticate write FOnAuthenticate; {$IFDEF DELPHI6_UP} property OnAuthenticateEx: TAuthenticateExEvent read FOnAuthenticateEx write FOnAuthenticateEx; property OnPutProperty: TOnPutPropertyEvent read FOnPutProperty write FOnPutProperty; {$ENDIF} property OnBeforeDownload: TOnBeforeDownloadEvent read FOnBeforeDownload write FOnBeforeDownload; property OnBeginningTransaction: TBeginningTransactionEvent read FBeginningTransaction write FBeginningTransaction; property OnCodeInstallProblem: TOnCodeInstallProblemEvent read FOnCodeInstallProblem write FOnCodeInstallProblem; property OnDataAvailable: TOnDataAvailableEvent read FOnDataAvailable write FOnDataAvailable; property OnDataAvailableInfo: TOnDataAvailableInfoEvent read FOnDataAvailableInfo write FOnDataAvailableInfo; property OnConnect: TOnConnectEvent read FOnConnect write FOnConnect; property OnComplete: TOnCompleteEvent read FOnComplete write FOnComplete; property OnStreamComplete: TOnStreamCompleteEvent read FOnStreamComplete write FOnStreamComplete; property OnError: TErrorEvent read FOnError write FOnError; property OnGetBindResults: TOnGetBindResultsEvent read FOnGetBindResults write FOnGetBindResults; property OnGetBindInfo: TOnGetBindInfoEvent read FOnGetBindInfo write FOnGetBindInfo; property OnGetBindInfoEx: TOnGetBindInfoExEvent read FOnGetBindInfoEx write FOnGetBindInfoEx; property OnGetSerializedClientCertContext: TOnGetClientCertEvent read FOnGetClientCert write FOnGetClientCert; property OnGetRootSecurityId: TOnGetRootSecurityIdEvent read FOnGetRootSecurityId write FOnGetRootSecurityId; property OnGetWindow: TGetWindowEvent read FGetWindow write FGetWindow; property OnFileExists: TFileExistsEvent read FOnFileExists write FOnFileExists; property OnProgress: TOnProgressEvent read FOnProgress write FOnProgress; property OnQueryInterface: TQueryInterfaceEvent read FOnQueryInterface write FOnQueryInterface; property OnQueryService: TQueryServiceEvent read FOnQueryService write FOnQueryService; property OnRedirect: TRedirect read FOnRedirect write FOnRedirect; property OnResponse: TOnResponseEvent read FOnResponse write FOnResponse; property OnResume: TOnResumeEvent read FOnResume write FOnResume; property OnSecurityProblem: TOnSecurityProblemEvent read FOnSecurityProblem write FOnSecurityProblem; property OnStartBinding: TOnStartBindingEvent read FOnStartBinding write FOnStartBinding; property OnStateChange: TStateChangeEvent read FOnStateChange write FOnStateChange; property OnTerminate: TTerminateEvent read FOnTerminate write FOnTerminate; property OnStopBinding: TOnStopBindingEvent read FOnStopBinding write FOnStopBinding; property OpenDownloadFolder: Boolean read FOpenDownloadFolder write FOpenDownloadFolder default False; property Password: string read FPassword write FPassword; property PostData: string read FPostData write FPostData; property ProxySettings: TProxySettings read FProxySettings write FProxySettings; property PutFileName: string read FPutFileName write FPutFileName; property Range: TRange read FRange write FRange; property Security: TSecurity read FSecurity write FSecurity; property TimeOut: Integer read FTimeOut write FTimeOut default 0; property Url: string read FUrl write FUrl; property UserAgent: string read FUserAgent write FUserAgent; property UserName: string read FUserName write FUserName; property UseSystemDownloadFolder: boolean read FUseSystemDownloadFolder write FUseSystemDownloadFolder default False; property ValidateUrl: boolean read FValidateUrl write FValidateUrl default False; end; TIEDownload = class(TCustomIEDownload) published end; var ThreadStatusDesc: array[TThreadStatus] of string = ('Running', 'Suspended', 'Waiting', 'Terminated'); implementation uses IEDownloadStrings, EwbUrl, IEDownloadTools, Forms {$IFDEF DELPHI6_UP}, StrUtils{$ENDIF}; {TInfoData---------------------------------------------------------------------} constructor TInfoData.Create; begin inherited Create; InfAdditionalHeader := TStringList.Create; end; destructor TInfoData.Destroy; begin {Cleaning out and free our resources} Clear; Remove(Sender); Extract(Self); {Its just to make sure we cleanly remove the IEDownload as an object} Remove(infSender); Extract(Self); if Assigned(infAdditionalHeader) then FreeAndNil(infAdditionalHeader); inherited; end; {End of TInfoData--------------------------------------------------------------} {Proxy Settings-----------------------------------------------------------------} function TProxySettings.SetProxy(const FullUserAgent, ProxyServer: string): Boolean; //mladen var intList: INTERNET_PER_CONN_OPTION_List; dwBufSize: DWORD; hInternet: Pointer; intOptions: array[1..3] of INTERNET_PER_CONN_OPTION; begin Result := False; dwBufSize := SizeOf(intList); intList.dwSize := SizeOf(intList); intList.pszConnection := nil; intList.dwOptionCount := High(intOptions); // the highest index of the array (in this case 3) intOptions[1].dwOption := INTERNET_PER_CONN_FLAGS; intOptions[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY; intOptions[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER; intOptions[2].Value.pszValue := PChar(ProxyServer); intOptions[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS; intOptions[3].Value.pszValue := ''; intList.intOptions := @intOptions; hInternet := InternetOpen(PChar(FullUserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0); if hInternet <> nil then try Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @intList, dwBufSize); Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0); finally InternetCloseHandle(hInternet) end; end; {End of Proxy Settings-----------------------------------------------------------} {$IFDEF USE_MSHTML} function TBSCB.OnChanged(dispId: TDispId): HRESULT; var DP: TDispParams; vResult: OLEVariant; Doc: IHTMLDocument2; begin if (DISPID_READYSTATE = DispId) then if Succeeded((Doc as IHTMLDocument2).Invoke(DISPId_READYSTATE, GUId_null, LOCALE_System_DEFAULT, DISPATCH_PROPERTYGET, DP, @vResult, nil, nil)) then if Integer(vResult) = READYSTATE_COMPLETE then PostThreadMessage(GetCurrentThreadId, WM_USER_STARTWALKING, 0, 0); Result := S_OK; end; function TBSCB.OnRequestEdit(dispId: TDispId): HRESULT; begin Result := E_NOTIMPL; end; {$ENDIF} {Callback procedure--------------------------------------------------------------} {IAuthenticate Interface Provides the URL moniker with information to authenticate the user} function TBSCB.Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR): HResult; {Provides the URL moniker with information to authenticate the user. S_OK Authentication was successful. E_ACCESSDENIED Authentication failed. E_INVALIDARG One or more parameters are invalid. } var aUser, aPwd: WideString; begin Result := S_OK; hwnd := FSender.FHWnd; aUser := EmptyStr; aPwd := EmptyStr; if Assigned(FSender.FOnAuthenticate) then FSender.FOnAuthenticate(Self, hwnd, aUser, aPwd, Result); if aUser <> EmptyStr then szUserName := WidestringToLPOLESTR(aUser) else szUserName := nil; if aPwd <> EmptyStr then szPassWord := WidestringToLPOLESTR(aPwd) else szPassWord := nil; end; {IHttpNegotiate Interface Implemented by a client application to provide support for HTTP negotiations} function TBSCB.BeginningTransaction(szURL, szHeaders: LPCWSTR; dwReserved: DWORD; out szAdditionalHeaders: LPWSTR): HRESULT; {IHttpNegotiate::BeginningTransaction Method Notifies the client of the URL that is being bound to at the beginning of an HTTP transaction. S_OK The HTTP transaction completed successfully and any additional headers specified have been appended. E_ABORT The HTTP transaction has been terminated. E_INVALIDARG A parameter is invalid.} var sr: TSearchRec; Action: Cardinal; tmpNewName: WideString; NewHeaders: string; Size: Longint; x, Len: Integer; ActExists: TFileExistsOption; begin ActExists := FSender.FFileExistsOption; tmpNewName := ''; dwReserved := 0; if (FSender.FCancel) and (Binding <> nil) then begin Result := E_ABORT; binding.Abort; Exit; end; NewHeaders := FSender.FFullUserAgent + #13 + #10; if (BscbInfo.infFileName <> EmptyStr) then begin if FindFirst(BscbInfo.infFileName, faAnyFile, sr) = 0 then begin Size := sr.Size; FindClose(sr); BscbInfo.infRangeEnd := 0; Action := 0; {IBinding still do not support resume (By MS 4.2009)} if Assigned(FSender.FOnResume) then begin FSender.FOnResume(Self, BscbInfo.infFileName, Action); BscbInfo.infRangeBegin := Size; end; if Assigned(FSender.FOnFileExists) then FSender.FOnFileExists(ActExists, BscbInfo.infFileName, tmpNewName); if tmpNewName = EmptyStr then tmpNewName := TimeToStr(now) + '_' + BscbInfo.infFileName; case ActExists of feOverwrite: begin Binding.Resume; if Assigned(FSender.FOnResume) then FSender.FOnResume(Self, BscbInfo.infFileName, Action); BscbInfo.infRangeBegin := 0 end; feSkip: begin Result := E_ABORT; Binding.Abort; Exit; end; feRename: BscbInfo.infFileName := tmpNewName; end end; end else {Download is starting} begin {Set the range to 0 which means start download from scratch} BscbInfo.infRangeBegin := 0; BscbInfo.infRangeEnd := 0; end; if ((BscbInfo.infRangeBegin <> 0) or (BscbInfo.infRangeEnd <> 0)) then begin {We set the new headers to send to the server} NewHeaders := NewHeaders + 'Range: bytes=' + IntToStr(BscbInfo.infRangeBegin) + '-'; if BscbInfo.infRangeEnd <> 0 then NewHeaders := NewHeaders + IntToStr(BscbInfo.infRangeEnd) + #13#10 else NewHeaders := NewHeaders + #13#10; end; if (BscbInfo.infAdditionalHeader.Text <> EmptyStr) then for x := 0 to BscbInfo.infAdditionalHeader.Count - 1 do NewHeaders := NewHeaders + BscbInfo.infAdditionalHeader[x] + #13#10; Len := Length(NewHeaders); szAdditionalHeaders := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar)); StringToWideChar(NewHeaders, szAdditionalHeaders, Len + 1); {We will post the event} if Assigned(FSender.FBeginningTransaction) then Result := FSender.FBeginningTransaction(Self, szURL, szHeaders, dwReserved, szAdditionalHeaders) else Result := S_OK; FBSCBTimer.Enabled := True; {Timeout timer} FTimedOut := False; Self._Release; end; function TBSCB.OnResponse(dwResponseCode: DWORD; szResponseHeaders, szRequestHeaders: LPCWSTR; out szAdditionalRequestHeaders: LPWSTR): HRESULT; {Enables the client of a bind operation to examine the response headers, optionally terminate the bind operation, and add HTTP headers to a request before resending the request. Returns one of the following values. S_OK The operation completed successfully. E_ABORT Terminate the HTTP transaction. E_INVALIDARG The parameter is invalid.} var Len: Cardinal; S: string; tmpName: string; begin if (FSender.FCancel) and (Binding <> nil) then begin Result := E_ABORT; binding.Abort; Exit; end; Result := S_OK; if (QueryInfo(HTTP_QUERY_CUSTOM, Len) and (Len = 0)) {file size = 0} or (QueryInfo(HTTP_QUERY_CONTENT_LENGTH, Len) and (Len = 0)) {file size = 0} or (dwResponseCode >= 400) then {An Error} begin Result := E_ABORT; if Assigned(FSender.FOnError) then FSender.FOnError(dwResponseCode, ResponseCodeToStr(dwResponseCode)); end; begin {Publish the event} if Assigned(FSender.FOnResponse) then Result := FSender.FOnResponse(Self, dwResponseCode, szResponseHeaders, szRequestHeaders, szAdditionalRequestHeaders); if (FSender.FDownloadTo = dtDownloadToFile) or (FSender.FDownloadTo = dtDownloadToCache) then begin Result := S_OK; Exit; end; if (BscbInfo.infRangeBegin <> 0) and (BscbInfo.infFileName <> EmptyStr) then begin {Retrieves the types of range requests that are accepted for a resource.} QueryInfo(HTTP_QUERY_ACCEPT_RANGES, S); {'Partial Content'} if (S = 'bytes') or (dwResponseCode = 206) then begin {Create an output file as a stream back from where we finished} tmpName := DoSaveFileAs; if tmpName <> EmptyStr then begin fsOutputFile := TFileStream.Create(tmpName, fmOpenReadWrite); fsOutputFile.Seek(0, soFromEnd); end; end else begin {'Create an output file as a stream from range begin 0'} // not needed tmpName := DoSaveFileAs; if tmpName <> EmptyStr then begin fsOutputFile := TFileStream.Create(tmpName, fmCreate); BscbInfo.infRangeBegin := 0; end; end; end else begin {Here we create the file} if (FSender.FDownloadMethod = dmFile) then begin tmpName := DoSaveFileAs; if tmpName <> EmptyStr then begin fsOutputFile := TFileStream.Create(tmpName, fmCreate); fsOutputFile.Seek(0, soFromBeginning); end; end; end end; end; {IHttpNegotiate2 Interface} function TBSCB.GetRootSecurityId(var SecurityIdBuffer: TByteArray; var BufferSize: DWord; dwReserved: DWORD): HResult; begin {Gets a root security ID.} if Assigned(FSender.FOnGetRootSecurityId) then Result := FSender.FOnGetRootSecurityId(SecurityIdBuffer, BufferSize) else Result := E_NOTIMPL; end; function TBSCB.GetBindInfoEx(out grfBINDF: DWORD; var pbindinfo: BINDINFO; out grfBINDF2: DWORD; out pdwReserved: DWORD): HResult; var PutFile: TFileStream; Len: Integer; begin pdwReserved := 0; if Assigned(FSender.FOnGetBindInfoEx) then FSender.FOnGetBindInfoEx(Self, grfBINDF, pbindinfo, grfBINDF2); grfBINDF := BscbInfo.infBindF_Value; {Insert our options.} grfBINDF2 := BscbInfo.infBindF2_Value; {Insert our options 2.} with pbindinfo do {Lets play with our options.} begin cbSize := SizeOf(TBindInfo); if FRedirect then begin {Set method to get in case of redirect} dwBindVerb := BINDVERB_GET; end else {Insert the options} dwBindVerb := BscbInfo.infBindVerb_Value; grfBindInfoF := BscbInfo.infBindInfoF_Value; dwCodePage := BscbInfo.infCodePage_Value; {Insert security arguments} with SecurityAttributes do begin nLength := SizeOf(TSecurityAttributes); bInheritHandle := BscbInfo.infInheritHandle; if BscbInfo.infDescriptor <> '' then lpSecurityDescriptor := PAnsiChar(BscbInfo.infDescriptor) else lpSecurityDescriptor := nil; end; {Insert Extra Info} if BscbInfo.infExtraInfo <> EmptyStr then begin Len := Length(BscbInfo.infExtraInfo); szExtraInfo := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar)); StringToWideChar(BscbInfo.infExtraInfo, szExtraInfo, Len + 1); end else szExtraInfo := nil; case BscbInfo.infBindVerb_Value of {Now we will set by our BindVerbOption} BINDVERB_PUT: {Perform an HTTP PUT operation. The data to put should be specified in the stgmedData member of the BINDINFO structure.} if BscbInfo.infPutFileName <> EmptyStr then begin PutFile := TFileStream.Create(BscbInfo.infPutFileName, fmOpenRead); try PutFile.Seek(0, 0); FGlobalData := GlobalAlloc(GPTR, PutFile.Size); FDataSize := PutFile.Size; PutFile.ReadBuffer(Pointer(FGlobalData)^, PutFile.Size); finally PutFile.Free; end; end; BINDVERB_POST: {Perform an HTTP POST operation. The data to be posted should be specified in the stgmedData member of the BINDINFO structure.} if BscbInfo.infPostData <> EmptyStr then begin FGlobalData := GlobalAlloc(GPTR, Length(BscbInfo.infPostData) + 1); FDataSize := Length(BscbInfo.infPostData) + 1; Move(BscbInfo.infPostData[1], Pointer(FGlobalData)^, Length(BscbInfo.infPostData)); end; BINDVERB_CUSTOM: {Perform a custom operation that is protocol-specific See the szCustomVerb member of the BINDINFO structure. The data to be used in the custom operation should be specified in the stgmedData structure.} if (BscbInfo.infCustomVerb <> EmptyStr) then begin Len := Length(BscbInfo.infCustomVerb); szCustomVerb := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar)); StringToWideChar(BscbInfo.infCustomVerb, szCustomVerb, Len + 1); end else {BINDVERB_GET so no need to play arround.} szCustomVerb := nil; end; FillChar(stgmedData, 0, SizeOf(STGMEDIUM)); cbStgmedData := FDataSize; with StgmedData do begin if dwBindVerb = BINDVERB_GET then {The stgmedData member of the BINDINFO structure should be set to TYMED_NULL for the GET operation} Tymed := TYMED_NULL else Tymed := TYMED_HGLOBAL; {this is the only medium urlmon supports right now} hGlobal := FGlobalData; IUnknown(unkForRelease) := Self; {Set the IUnknown interface} end; end; Result := S_OK; end; {IBindStatusCallback Interface} {Accepts information on an asynchronous bind operation.} function TBSCB.GetBindInfo(out grfBINDF: DWORD; var BindInfo: TBindInfo): HRESULT; {Provides information about how the bind operation is handled when it is called by an asynchronous moniker. Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.} var PutFile: TFileStream; Len: Integer; begin grfBINDF := BscbInfo.infBindF_Value; {Insert our options.} with BindInfo do {Lets play with our options.} begin cbSize := SizeOf(TBindInfo); if FRedirect then begin {Set method to get in case of redirect} dwBindVerb := BINDVERB_GET; end else {Insert the options} dwBindVerb := BscbInfo.infBindVerb_Value; grfBindInfoF := BscbInfo.infBindInfoF_Value; dwCodePage := BscbInfo.infCodePage_Value; {Insert security arguments} with SecurityAttributes do begin nLength := SizeOf(TSecurityAttributes); bInheritHandle := BscbInfo.infInheritHandle; if BscbInfo.infDescriptor <> '' then lpSecurityDescriptor := PAnsiChar(BscbInfo.infDescriptor) else lpSecurityDescriptor := nil; end; {Insert Extra Info} if BscbInfo.infExtraInfo <> EmptyStr then begin Len := Length(BscbInfo.infExtraInfo); szExtraInfo := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar)); StringToWideChar(BscbInfo.infExtraInfo, szExtraInfo, Len + 1); end else szExtraInfo := nil; case BscbInfo.infBindVerb_Value of {Now we will set by our BindVerbOption} BINDVERB_PUT: {Perform an HTTP PUT operation. The data to put should be specified in the stgmedData member of the BINDINFO structure.} if BscbInfo.infPutFileName <> EmptyStr then begin {Create a process to put a file} PutFile := TFileStream.Create(BscbInfo.infPutFileName, fmOpenRead); try PutFile.Seek(0, 0); FGlobalData := GlobalAlloc(GPTR, PutFile.Size); FDataSize := PutFile.Size; PutFile.ReadBuffer(Pointer(FGlobalData)^, PutFile.Size); finally PutFile.Free; end; end; BINDVERB_POST: {Perform an HTTP POST operation. The data to be posted should be specified in the stgmedData member of the BINDINFO structure.} if BscbInfo.infPostData <> EmptyStr then begin FGlobalData := GlobalAlloc(GPTR, Length(BscbInfo.infPostData) + 1); FDataSize := Length(BscbInfo.infPostData) + 1; Move(BscbInfo.infPostData[1], Pointer(FGlobalData)^, Length(BscbInfo.infPostData)); end; BINDVERB_CUSTOM: {Perform a custom operation that is protocol-specific See the szCustomVerb member of the BINDINFO structure. The data to be used in the custom operation should be specified in the stgmedData structure.} if (BscbInfo.infCustomVerb <> EmptyStr) then begin Len := Length(BscbInfo.infCustomVerb); szCustomVerb := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar)); StringToWideChar(BscbInfo.infCustomVerb, szCustomVerb, Len + 1); end else {BINDVERB_GET so no need to play arround.} szCustomVerb := nil; end; FillChar(stgmedData, 0, SizeOf(STGMEDIUM)); cbStgmedData := FDataSize; with StgmedData do begin if dwBindVerb = BINDVERB_GET then {The stgmedData member of the BINDINFO structure should be set to TYMED_NULL for the GET operation} Tymed := TYMED_NULL else Tymed := TYMED_HGLOBAL; {this is the only medium urlmon supports right now} hGlobal := FGlobalData; IUnknown(unkForRelease) := Self; {Set the IUnknown interface} end; end; if Assigned(FSender.FOnGetBindInfo) then FSender.FOnGetBindInfo(Self, grfBINDF, BindInfo); Result := S_OK; end; function TBSCB.GetPriority(out nPriority): HRESULT; {Gets the priority for the bind operation when it is called by an asynchronous moniker.} {Returns S_OK if this is successful or E_INVALIDARG if the pnPriority parameter is invalid.} begin {if you want to set priority you should implement SetPriority in your application} Result := S_OK; if (FSender.FCancel) and (Binding <> nil) then binding.Abort end; function TBSCB.OnDataAvailable(grfBSCF, dwSize: DWORD; FormatEtc: PFormatEtc; stgmed: PStgMedium): HRESULT; {Provides data to the client as it becomes available during asynchronous bind operations.OnDataAvailable return E_PENDING when they reference data not yet available through their read methods, rather than blocking until the data becomes available. This flag applies only to ASYNCHRONOUS operations} {Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.} var Data: PByte; BufL, dwRead, dwActuallyRead: Cardinal; begin if (FSender.FCancel) and (Binding <> nil) then binding.Abort else begin if Assigned(FSender.FOnDataAvailableInfo) then FSender.FOnDataAvailableInfo(Self, grfBSCF, DataAvalibleToStr(grfBSCF) {, FormatEtc}); if Assigned(FBSCBTimer) then {reset our timer.} begin FBSCBTimer.Enabled := False; FBSCBTimer.Enabled := True; end; if (grfBSCF = grfBSCF or BSCF_FIRSTDATANOTIFICATION) then begin if (fOutStream = nil) and (stgmed.tymed = TYMED_ISTREAM) then fOutStream := IStream(stgmed.stm); if Assigned(m_pPrevBSCB) and not Assigned(fsOutputFile) and (BscbInfo.infFileName <> '') then try //TODO: check for resume fsOutputFile := TFileStream.Create(DoSaveFileAs, fmCreate); BscbInfo.infRangeBegin := 0; except on EFCreateError do begin Binding.Abort; Result := E_FAIL; Exit; fsOutputFile.Free; end; end; end; dwRead := dwSize - FTotalRead; dwActuallyRead := 0; if (dwRead > 0) then repeat Data := AllocMem(dwRead + 1); fOutStream.Read(Data, dwRead, @dwActuallyRead); BufL := dwActuallyRead; if Assigned(FSender.FOnDataAvailable) then begin FSender.FOnDataAvailable(self, Data, BufL); end; if (BscbInfo.infFileName <> '') and Assigned(fsOutputFile) then begin fsOutputFile.WriteBuffer(Data^, BufL); end else if Assigned(Stream) then Stream.WriteBuffer(Data^, BufL); Inc(FTotalRead, dwActuallyRead); FreeMem(Data); until dwActuallyRead = 0; end; Result := S_OK; {if (grfBSCF = grfBSCF or BSCF_FIRSTDATANOTIFICATION) then begin if (fOutStream = nil) and (stgmed.tymed = TYMED_ISTREAM) then fOutStream := IStream(stgmed.stm); if Assigned(m_pPrevBSCB) and not Assigned(fsOutputFile) //and (BscbInfo.infFileName <> '') then // and (FSender.FDownloadMethod = dmFile) then try fsOutputFile := TFileStream.Create(DoSaveFileAs, fmCreate); BscbInfo.infRangeBegin := 0; except on EFCreateError do begin Binding.Abort; Result := E_INVALIDARG; if Assigned(FSender.FOnError) then FSender.FOnError(GetLastError, SysErrorMessage(GetLastError)); fsOutputFile.Free; Exit; end; end; end; dwRead := dwSize - FTotalRead; dwActuallyRead := 0; if (dwRead > 0) then repeat Data := AllocMem(dwRead + 1); //to fix stack overflow fOutStream.Read(Data, dwRead, @dwActuallyRead); BufL := dwActuallyRead; if Assigned(FSender.FOnDataAvailable) then FSender.FOnDataAvailable(Self, Data, Bufl); try Stream.WriteBuffer(Data^, Bufl); except on EWriteError do begin Binding.Abort; Result := E_INVALIDARG; if Assigned(FSender.FOnError) then FSender.FOnError(GetLastError, SysErrorMessage(GetLastError)); fsOutputFile.Free; Exit; end; end; if (FSender.FDownloadMethod = dmFile) and Assigned(fsOutputFile) then begin try fsOutputFile.WriteBuffer(Data^, bufl); except on EWriteError do begin Binding.Abort; Result := E_INVALIDARG; if Assigned(FSender.FOnError) then FSender.FOnError(GetLastError, SysErrorMessage(GetLastError)); fsOutputFile.Free; Exit; end end; end; Inc(FTotalRead, dwActuallyRead); FreeMem(Data); until dwActuallyRead = 0; end; Result := S_OK;} end; function TBSCB.OnLowResource(Reserved: DWORD): HRESULT; {Not implemented by MS.} begin Result := E_NOTIMPL; end; function TBSCB.OnObjectAvailable(const IID: TGUID; punk: IUnknown): HRESULT; {Passes the requested object interface pointer to the client.} {Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.} begin Self._AddRef; if (FSender.FCancel) and (Binding <> nil) then binding.Abort; Result := S_OK; end; function TBSCB.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG; szStatusText: LPCWSTR): HRESULT; {Indicates the progress and the status of the bind operation.} {Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.} {Avalible flags: http://msdn.microsoft.com/en-us/library/ms775133(VS.85).aspx} var Percent, Speed, Elapsed, Downloaded, RemainingTime, Status: string; _Speed: Single; bAbort: Boolean; tmpElapsed, iFileSize: integer; begin if (FSender.FCancel) and (Binding <> nil) then Binding.Abort else begin tmpElapsed := 0; bAbort := False; Status := ResponseCodeToStr(ulStatusCode); if (ulProgress > ulProgressMax) then ulProgressMax := ulProgress; iFileSize := ulProgressMax; FSender.FFileSize := ulProgressMax; {For a download manager} if Assigned(m_pPrevBSCB) then begin {Weed to do this otherwise a filedownload dlg will be displayed as we are downloading the file.} if (ulStatusCode = BINDSTATUS_CONTENTDISPOSITIONATTACH) then begin Result := S_OK; Exit; {We must exit so no DLG will be displayed} end; m_pPrevBSCB.OnProgress(ulProgress, ulProgressMax, ulStatusCode, szStatusText); end; case ulStatusCode of BINDSTATUS_REDIRECTING: {redirecting} begin FRedirect := True; FSender.FServerAddress := szStatusText; if (Assigned(FSender.FOnRedirect)) and (FSender.FUrl <> szStatusText) then FSender.FOnRedirect(Self, bAbort, FSender.FUrl, szStatusText); if bAbort then {If we do not wish to be redirect} begin FSender.FCancel := True; Result := E_INVALIDARG; Exit; end; {Get the new addreess after redirecing} if (FSender.FDownloadMethod = dmFile) then FSender.SetFileNameFromUrl(szStatusText); end; BINDSTATUS_CONNECTING: FSender.FServerIP := szStatusText; BINDSTATUS_MIMETYPEAVAILABLE: FSender.FMimeType := szStatusText; BINDSTATUS_BEGINDOWNLOADDATA: FSender.FServerAddress := szStatusText; BINDSTATUS_DOWNLOADINGDATA: {We are downloading so here we will calculate download variables} if Assigned(FSender.FOnProgress) then begin if (ulProgress {+ BscbInfo.infRangeBegin} > 0) then Downloaded := FormatSize(ulProgress {+ BscbInfo.infRangeBegin}); if (ulProgressMax > 0) and (ulProgress > 0) then Percent := Format('%.1f %%', [ulProgress / ulProgressMax * 100]); QueryPerformanceCounter(TimeNow); if (TimeNow > TimeStarted) {and (Round((TimeNow-TimeStarted)/Frequency) <= tmpElapsed)}then begin tmpElapsed := Round((TimeNow - TimeStarted) / Frequency); Elapsed := SecToStr(tmpElapsed); end; try if (ulProgress > 0) and (tmpElapsed > 0) then _Speed := ulProgress / 1024 / tmpElapsed else _Speed := 0; Speed := Format('%.1f ' + kb_sec, [_Speed]); if (ulProgressMax > 0) and ((_Speed) > 0) and (ulProgressMax > ulProgress) then RemainingTime := SecToStr(Round(ulProgressMax / _speed / 1000) - Round(ulProgress / _speed / 1000)) else RemainingTime := TimeToStr(0); except on EZeroDivide do RemainingTime := TimeToStr(0); end; end; BINDSTATUS_ENDDOWNLOADDATA: {You are joking right? NO MORE DATA TO DOWNLOAD} begin Downloaded := done; ulProgress := 0; ulProgressMax := 0; Speed := '0/00' + kb_sec; RemainingTime := '00.00.00'; Status := done; Percent := '100%'; end; {Here you can add more handlers to any BINDSTATUS_ you like} end; if Assigned(FSender.FOnProgress) then {Publish the event} FSender.FOnProgress(Self, ulProgress {+ BscbInfo.infRangeBegin}, ulProgressMax {+ BscbInfo.infRangeBegin}, ulStatusCode, iFileSize, szStatusText, Downloaded, Elapsed, Speed, RemainingTime, Status, Percent); end; Result := S_OK; end; function TBSCB.GetFileNameFromUrl(Url: string): string; var Ut: TUrl; begin Ut := TUrl.Create(Url); try Ut.CrackUrl(Url, ICU_ESCAPE); if AnsiPos('.', Ut.ExtraInfo) = 0 then Result := FSender.FDefaultUrlFileName else Result := Ut.ExtraInfo; finally Ut.Free; end; end; function TBSCB.OnStartBinding(dwReserved: DWORD; pib: IBinding): HRESULT; {Notifies the client about the callback methods that it is registered to receive.} {Returns S_OK if this is successful or E_INVALIDARG if the pib parameter is invalid. To abort the binding we should return E_FAIL.} var bAbort: Boolean; begin //dwReserved:= 0; // A demand by ms that is not needed.} if FSender.FCancel then Result := E_FAIL else begin Result := S_OK; bAbort := False; Binding := pib; {A pointer to the IBinding interface} Binding._AddRef; {To be released on StopBinding} {We will try to get the file size using query info} QueryInfo(HTTP_QUERY_CONTENT_LENGTH, BscbInfo.infFileSize); QueryInfoFileName; if Assigned(FSender.FOnBeforeDownload) then FSender.FOnBeforeDownload(BscbInfo, BscbInfo.infUrl, BscbInfo.infFileName, BscbInfo.infFileExt, BscbInfo.infHost, BscbInfo.infDownloadFolder, BscbInfo.infFileSize, bAbort); {For the download manager} FSender.FFileName := BscbInfo.infFileName; FSender.FDownloadFolder := BscbInfo.infDownloadFolder; if Assigned(m_pPrevBSCB) then m_pPrevBSCB.OnStopBinding(HTTP_STATUS_OK, nil); {Remove file name which is not needed for stream} case FSender.FDownloadMethod of dmStream: BscbInfo.infFileName := EmptyStr; dmFile: begin {Try # 2} if (BscbInfo.infFileName = EmptyStr) and (FSender.FDownloadTo = dtMoniker) then BscbInfo.infFileName := GetFileNameFromUrl(FSender.FUrl) else begin if (BscbInfo.infFileName = EmptyStr) and (not FSender.bRenamed) and (BscbInfo.infFileName <> GetFileNameFromUrl(BscbInfo.infUrl)) then BscbInfo.infFileName := GetFileNameFromUrl(BscbInfo.infUrl); end; end; end; if Assigned(FSender.FOnStartBinding) then FSender.FOnStartBinding(Self, bAbort, Binding, BscbInfo.infFileName, BscbInfo.infFileSize); if bAbort then begin {Note: We are still in busy state until OnStopBinding!!} Result := E_FAIL; {Do not use Binding.Abort! Just send E_FAIL} FSender.FCancel := True; end; end; end; function TBSCB.OnStopBinding(HRESULT: HRESULT; szError: LPCWSTR): HRESULT; {This method indicates the end of the bind operation. Returns S_OK if this is successful or an error value otherwise.} var clsidProtocol: TCLSID; dwResult: DWORD; szResult: POLEStr; HR: System.HRESULT; begin //OK if (FSender.FDownloadTo = dtDownloadToFile) or (FSender.FDownloadTo = dtDownloadToCache) then begin Result := S_OK; Exit; end; if (Assigned(m_pPrevBSCB) and Assigned(FBindCtx)) then {Stores an IUnknown pointer on the specified object } begin {To be used with a download manager} HR := FBindCtx.RegisterObjectParam('_BSCB_Holder_', m_pPrevBSCB); if Failed(HR) and Assigned(FSender.FOnError) then FSender.FOnError(GetLastError, SysErrorMessage(GetLastError)) else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, Registering_new_moniker + ResponseCodeToStr(HR)); m_pPrevBSCB._Release; m_pPrevBSCB := nil; FBindCtx._Release; FBindCtx := nil; Dec(FSender.FRefCount); end; GetBindResult(clsidProtocol, dwResult, szResult); if FTimedOut then begin {If we reached TimeOut them we will post the event} HRESULT := INET_E_CONNECTION_TIMEOUT; if Assigned(FSender.FOnError) then FSender.FOnError(HRESULT, ResponseCodeToStr(HRESULT)); end; if Assigned(FSender.FOnStopBinding) then FSender.FOnStopBinding(Self, HRESULT, szError); Result := HRESULT; FSender.FState := sStopped; if Assigned(FSender.FOnStateChange) then FSender.FOnStateChange(FSender.FState); if Assigned(FSender.FOnStreamComplete) then FSender.FOnStreamComplete(Self, Stream, HRESULT); FSender.bDone := True; SetEvent(FSender.hStop); Terminate; Dec(FSender.FActiveConnections); if FSender.FActiveConnections = 0 then SetEvent(FSender.hProcess); end; {IServiceProvider Interface} function TBSCB.QueryService(const rsid, iid: TGUID; out Obj): HRESULT; begin Pointer(Obj) := nil; if Assigned(FSender.FOnQueryService) then FSender.FOnQueryService(Self, rsid, iid, IUnknown(obj)); if Pointer(Obj) <> nil then Result := S_OK else Result := E_NOINTERFACE; end; {ICodeInstall Interface} function TBSCB.OnCodeInstallProblem(ulStatusCode: ULONG; szDestination, szSource: LPCWSTR; dwReserved: DWORD): HResult; stdcall; {Returns a value based on the status passed in, which indicates whether to abort the application installation or file download. S_OK Indicates that the installation or download should continue. E_ABORT Indicates that the installation or download should abort.} begin dwReserved := 0; if Assigned(FSender.FOnCodeInstallProblem) then Result := FSender.FOnCodeInstallProblem(Self, ulStatusCode, szDestination, szSource, dwReserved, ResponseCodeToStr(ulStatusCode)) else Result := S_OK; end; {IUnknown Interface} function TBSCB.QueryInterface(const IID: TGUID; out Obj): HRESULT; {S_OK if the interface is supported, E_NOINTERFACE if not.} begin Self._AddRef; if Assigned(FSender.OnQueryInterface) then FSender.OnQueryInterface(IID, Obj); if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE; end; function TBSCB._AddRef: Integer; {The IUnknown::AddRef method increments the reference count for an interface on an object.} begin Result := InterlockedIncrement(FSender.FRefCount); end; function TBSCB._Release: Integer; {Decrements the reference count for the calling interface on a object. } begin Result := InterlockedDecrement(FSender.FRefCount); if Result = 0 then Destroy; end; {IWindowForBindingUI Interface} function TBSCB.GetWindow(const GUIDReason: TGUID; out hwnd): HRESULT; {Returns S_OK if the window handle was successfully returned, or E_INVALIDARG if the phwnd parameter is invalid. If you implement this interface, you can return S_FALSE for this method to indicate that no window is available for to display user interface information.} begin if Assigned(FSender.FGetWindow) then Result := FSender.FGetWindow(Self, GUIDReason, LongWord(hwnd)) else Result := S_OK; end; {IHttpSecurity} function TBSCB.OnSecurityProblem(dwProblem: DWORD): HResult; {RPC_E_RETRY The calling application should continue or retry the download. S_FALSE The calling application should open a dialog box to warn the user. E_ABORT The calling application should abort the download.} begin if Assigned(FSender.FOnSecurityProblem) then Result := FSender.FOnSecurityProblem(Self, dwProblem, ResponseCodeToStr(dwProblem)) else Result := S_FALSE; end; function TBSCB.GetSerializedClientCertContext(out ppbCert: Byte; var pcbCert: DWORD): HResult; stdcall; begin if Assigned(FSender.FOnGetClientCert) then Result := FSender.FOnGetClientCert(Self, ppbCert, pcbCert) else Result := S_FALSE; end; {$IFDEF DELPHI6_UP} function TBSCB.AuthenticateEx(out phwnd: HWND; out pszUsername, pszPassword: LPWSTR; var pauthinfo: AUTHENTICATEINFO): HResult; stdcall; var aUser, aPwd: WideString; tmpHWND: HWND; begin Result := S_OK; phwnd := FSender.FHWnd; aUser := EmptyStr; aPwd := EmptyStr; if Assigned(FSender.FOnAuthenticateEx) then FSender.FOnAuthenticateEx(Self, tmpHWND, aUser, aPwd, pauthinfo, Result); if aUser <> EmptyStr then pszUserName := WidestringToLPOLESTR(aUser) else pszUserName := nil; if aPwd <> EmptyStr then pszPassWord := WidestringToLPOLESTR(aPwd) else pszPassWord := nil; end; function TBSCB.PutProperty(mkp: MONIKERPROPERTY; val: LPCWSTR): HResult; {This interface is implemented by persistent monikers, such as a MIME handler, to get properties about the moniker being handled.} begin if Assigned(FSender.FOnPutProperty) then Result := FSender.FOnPutProperty(Self, mkp, val) else Result := E_NOTIMPL; end; {$ENDIF} function TBSCB.GetBindResult(out clsidProtocol: TCLSID; out dwResult: DWORD; out szResult: POLEStr): HRESULT; {Gets the protocol-specific outcome of a bind operation.} var dwReserved: DWORD; begin dwReserved := 0; if (Binding <> nil) then Result := Binding.GetBindResult(clsidProtocol, dwResult, szResult, dwReserved) else Result := E_FAIL; if Assigned(FSender.FOnGetBindResults) then FSender.FOnGetBindResults(Self, clsidProtocol, dwResult, szResult, ResponseCodeToStr(dwResult)); if (Result <> S_OK) and (Assigned(FSender.FOnError)) then FSender.FOnError(Result, ResponseCodeToStr(Result)); end; function TBSCB.CheckCancelState: Integer; begin if (FSender.FCancel = True) then Result := E_ABORT else Result := S_OK; end; procedure TBSCB.TimerExpired(Sender: TObject); begin FTimedOut := True; end; procedure TBSCB.ClearAll; begin {Reset our resources} if Assigned(Binding) then Binding.Abort; FGlobalData := 0; FTotalRead := 0; if m_pPrevBSCB <> nil then m_pPrevBSCB := nil; end; function TBSCB.QueryInfo(dwOption: DWORD; var Info: Cardinal): Boolean; var HttpInfo: IWinInetHttpInfo; C: Cardinal; BufferLength: Cardinal; Reserved, dwFlags: Cardinal; begin if (Assigned(Binding) and (Binding.QueryInterface(IWinInetHttpInfo, HttpInfo) = S_OK)) then begin Info := 0; Reserved := 0; dwFlags := 0; BufferLength := SizeOf(Cardinal); Result := not Boolean(HttpInfo.QueryInfo(dwOption or HTTP_QUERY_FLAG_NUMBER, @C, BufferLength, dwFlags, Reserved)); HttpInfo := nil; if Result then Info := C; end else Result := False; end; function TBSCB.QueryInfo(dwOption: DWORD; var Info: string): Boolean; var Buf: array[0..INTERNET_MAX_PATH_LENGTH] of AnsiChar; HttpInfo: IWinInetHttpInfo; BufLength, dwReserved, dwFlags: Cardinal; begin if (Assigned(Binding) and (Binding.QueryInterface(IWinInetHttpInfo, HttpInfo) = S_OK)) then begin Info := ''; dwReserved := 0; dwFlags := 0; BufLength := INTERNET_MAX_PATH_LENGTH + 1; Result := not Boolean(HttpInfo.QueryInfo(dwOption, @Buf, BufLength, dwFlags, dwReserved)); HttpInfo := nil; if Result then Info := string(Buf); end else Result := False; end; function TBSCB.QueryInfo(dwOption: DWORD; var Info: TDateTime): Boolean; var HttpInfo: IWinInetHttpInfo; SysTime: TSystemtime; BufferLength: Cardinal; Reserved, dwFlags: Cardinal; begin if (Assigned(Binding) and (Binding.QueryInterface(IWinInetHttpInfo, HttpInfo) = S_OK)) then begin Info := 0; Reserved := 0; dwFlags := 0; BufferLength := SizeOf(TSystemTime); Result := not Boolean(HttpInfo.QueryInfo(dwOption or HTTP_QUERY_FLAG_SYSTEMTIME, @SysTime, BufferLength, dwFlags, Reserved)); HttpInfo := nil; if Result then Info := SystemTimeToDateTime(SysTime); end else Result := False; end; function TBSCB.DoSaveFileAs: string; begin if FSender.FDownloadMethod = dmFile then begin with BscbInfo do begin if (infFileName = EmptyStr) then infFileName := FSender.SetFileNameFromUrl(infUrl); if (infFileName = EmptyStr) then infFileName := FSender.FDefaultUrlFileName; end; with FSender do begin FDownloadedFile := BscbInfo.infDownloadFolder + BscbInfo.infFileName; FFileExtension := ExtractFileExt(FSender.FDownloadedFile); BscbInfo.infFileExt := FFileExtension; FFileName := BscbInfo.infFileName; FDownloadFolder := BscbInfo.infDownloadFolder; end; Result := CharReplace(FSender.FDownloadedFile, '?', '_'); ; end; end; function TBSCB.QueryInfoFileName: HRESULT; const CD_FILE_PARAM = 'filename='; var i: Integer; st, sTmp: string; res: Boolean; begin Result := E_FAIL; sTmp := ''; res := QueryInfo(HTTP_QUERY_CONTENT_DISPOSITION, sTmp); if not res then Exit; i := Pos(CD_FILE_PARAM, sTmp); if (i > 0) then begin sTmp := Copy(sTmp, i + Length(CD_FILE_PARAM), Length(sTmp) - i); if (sTmp[1] = '"') then i := Pos('";', sTmp) else i := Pos(';', sTmp); //TODO: what's happen, if the filename contains a quotion mark? if (i > 0) then sTmp := Copy(sTmp, 1, i); if (sTmp[1] = '"') then begin st := (Copy(sTmp, 2, Length(sTmp) - 2)); BscbInfo.infFileName := Copy(sTmp, 2, Length(sTmp) - 2); end else BscbInfo.infFileName := sTmp; if (Length(sTmp) > 0) then Result := S_OK; end; FSender.FFileName := BscbInfo.infFileName; {Return Data} end; function TBSCB.IsRunning: Boolean; begin if (Succeeded(FMoniker.IsRunning(FBindCtx, FMoniker, nil))) then Result := True else Result := False; end; function TBSCB.GetDisplayName: PWideChar; begin {Expensive operation so I'll do it only once. For extra info use MkParseDisplayName } if IsRunning then FMoniker.GetDisplayName(FBindCtx, nil, Result); end; function TBSCB.MkParseDisplayName(var DisplayName: PWideChar): IMoniker; var i: cardinal; begin UrlMon.MkParseDisplayNameEx(FBindCtx, DisplayName, i, Result); end; function TBSCB.CreateMoniker(szName: POLEStr; BC: IBindCtx; out mk: IMoniker; dwReserved: DWORD): HResult; begin szName := StringToOleStr(BscbInfo.infUrl); Result := CreateURLMonikerEx(nil, szName, FMoniker, URL_MK_UNIFORM {URL_MK_LEGACY}); end; function TBSCB.MonikerBindToStorage(Mk: IMoniker; BC: IBindCtx; BSC: IBindStatusCallback; const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult; begin Mk := FMoniker; BC := FBindCtx; BSC := Self; Result := Mk.BindToStorage(BC, nil, IStream, fOutStream); end; function TBSCB.MonikerBindToObject(Mk: IMoniker; BC: IBindCtx; BSC: IBindStatusCallback; const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult; begin Mk := FMoniker; BC := FBindCtx; BSC := Self; Result := Mk.BindToObject(BC, nil, IStream, fOutStream); end; function TBSCB.AbortBinding: HRESULT; begin Result := E_Fail; if Assigned(Binding) then Result := Binding.Abort; end; destructor TBSCB.Destroy; begin {Cleaning out and free our resources} ClearAll; if Assigned(Stream) then FreeAndNil(Stream); if Assigned(FBSCBTimer) then FreeAndNil(FBSCBTimer); if Assigned(fsOutputFile) then FreeAndNil(fsOutputFile); if (FGlobalData <> 0) then GlobalFree(FGlobalData); inherited; end; constructor TBSCB.Create(aSender: TCustomIEDownload; const pmk: IMoniker; const pbc: IBindCtx; CreateSuspended: boolean); var tmp: PWideChar; begin inherited Create(CreateSuspended); FreeOnTerminate := False; if CreateSuspended then ThreadStatus := tsSuspended else ThreadStatus := tsWaiting; Stream := TMemoryStream.Create; {A stream to contain the download} FSender := aSender; FMoniker := pmk; FBindCtx := pbc; if FSender.FDownloadTo = dtMoniker then begin FSender.FBindF := FSender.FBindF + [GetNewestVersion]; FSender.DoUpdate; FMoniker.GetDisplayName(FBindCtx, nil, tmp); FSender.FUrl := tmp; FSender.ItemsManager.SessionList.Add(tmp); end; end; procedure TBSCB.SetComponents; begin {Initial all internals before the process} QueryPerformanceFrequency(Frequency); QueryPerformanceCounter(TimeStarted); ClearAll; {Clearing Internals} FBSCBTimer := TTimer.Create(nil); {Creating Timer for a TimeOut option} FBSCBTimer.OnTimer := TimerExpired; FBSCBTimer.Interval := BscbInfo.infTimeOut; FTimedOut := False; LongTimeFormat := Frmt_Time; if not FSender.IsSynchronous(BscbInfo) then {We are on Asynchronous mode} begin FSender.ItemsManager.Add(Self); {Adding asynchronous items} Inc(BscbInfo.infIndex); {Pass the index} Inc(FSender.FdlCounter); end; end; procedure TBSCB.Resume; begin inherited; ThreadStatus := tsRunning; end; procedure TBSCB.Suspend; begin inherited; ThreadStatus := tsSuspended; end; procedure TBSCB.Terminate; var bCanc: Boolean; begin if FSender.ActiveConnections = 0 then FSender.FBusy := False; ThreadStatus := tsTerminated; bCanc := False; if Assigned(FSender.FOnTerminate) then FSender.FOnTerminate(Self, ThreadID, BscbInfo.infFileName, bCanc); if bCanc then FSender.CancelAll; inherited; end; procedure TBSCB.Execute; begin if Terminated then Exit; try {Dont be in shock, as a tread it sometimes fail so we should succeed now} OleInitialize(nil); except end; ThreadStatus := tsRunning; Synchronize(ReceiveData); Synchronize(SetComponents); case FSender.FDownloadTo of dtNormal: begin Synchronize(DoConnect); Synchronize(ReturnData); end; dtMoniker: begin Synchronize(DoConnect); Synchronize(ReturnData); end; dtDownloadToCache: Synchronize(DoDownloadToCache); dtDownloadToFile: Synchronize(DoDownloadToFile); end; try if (Assigned(BscbInfo)) then finally BscbInfo.Clear; FreeAndNil(BscbInfo); end; OleUninitialize; end; procedure TBSCB.ReceiveData; begin BscbInfo := TInfoData.Create; GetData(FSender); {Pass Data to the TObject} FSender := TCustomIEDownload(BscbInfo.Sender); end; procedure TBSCB.ReturnData; begin with FSender do begin FDownloadedFile := BscbInfo.infDownloadFolder + BscbInfo.infFileName; FFileExtension := ExtractFileExt(FSender.FDownloadedFile); BscbInfo.infFileExt := FFileExtension; FFileName := BscbInfo.infFileName; FDownloadFolder := BscbInfo.infDownloadFolder; end; end; procedure TBSCB.DoDownloadToCache; var Buf: array[0..INTERNET_MAX_PATH_LENGTH] of char; begin if Succeeded(UrlMon.URLDownloadToCacheFile(nil, Pchar(BscbInfo.infUrl), Buf, SizeOf(Buf), 0, Self)) then FSender.ExtractDataFromFile(Buf); FSender.ItemsManager.Extract(Self); end; procedure TBSCB.DoDownloadToFile; var HR: integer; tmp: string; begin tmp:= BscbInfo.infDownloadFolder + BscbInfo.infFileName; HR := UrlMon.URLDownloadToFile(nil, Pchar(BscbInfo.infUrl), PChar(tmp), 0, Self); if Failed(HR) and Assigned(FSender.FOnError) then FSender.FOnError(GetLastError, Err_ToFile + SysErrorMessage(GetLastError)) else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, DL_ToFile + ResponseCodeToStr(HR)); FSender.ExtractDataFromFile(tmp); FSender.ItemsManager.Extract(Self); end; procedure TBSCB.DoConnect; var Ut: TUrl; HR: HRESULT; pPrevBSCB, tmpBSC: IBindStatusCallback; begin FSender.bDone := False; FSender.hStop := 0; if FSender.FDownloadTo <> dtMoniker then begin HR := CreateURLMonikerEx(nil, BscbInfo.infUrl, FMoniker, URL_MK_UNIFORM {URL_MK_LEGACY}); if Failed(HR) and Assigned(FSender.FOnError) then begin FSender.FOnError(GetLastError, Err_URLMEx + ResponseCodeToStr(HR)); Exit; end else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, CreateURLMEx + ResponseCodeToStr(HR)); HR := CreateAsyncBindCtx(0, Self, nil, FBindCtx); if Failed(HR) and Assigned(FSender.FOnError) then begin FSender.FOnError(GetLastError, Err_AsyncBindCtx + ResponseCodeToStr(HR)); Exit; end else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, CreateABindCtx + ResponseCodeToStr(HR)); end; FSender.FDisplayName := GetDisplayName; begin if FSender.FDisplayName <> EmptyStr then begin BscbInfo.infUrl := FSender.FDisplayName; FSender.FUrl := FSender.FDisplayName; end; Ut := TUrl.Create(BscbInfo.infUrl); try Ut.QueryUrl(BscbInfo.infUrl); BscbInfo.infFileName := Ut.Document; BscbInfo.infHost := Ut.HostName; finally Ut.Free; end; end; HR := RegisterBindStatusCallback(FBindCtx, Self, pPrevBSCB, 0); if Failed(HR) and Assigned(pPrevBSCB) then begin HR := FBindCtx.RevokeObjectParam('_BSCB_Holder_'); if (Succeeded(HR)) then begin {Attempt register again, should succeed now} HR := RegisterBindStatusCallback(FBindCtx, Self, tmpBSC, 0); if (SUCCEEDED(HR)) then begin //Need to pass a pointer for BindCtx and previous BSCB to our implementation m_pPrevBSCB := pPrevBSCB; Self._AddRef; m_pPrevBSCB._AddRef; FBindCtx._AddRef; if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, Reg_BSCB + ResponseCodeToStr(HR)); end else if Assigned(FSender.FOnError) then FSender.FOnError(GetLastError, Err_RegBSCB + ResponseCodeToStr(HR)); end; end else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, Reg_BSCB + ResponseCodeToStr(HR)); FSender.hStop := CreateEvent(nil, True, False, nil); HR := FMoniker.BindToStorage(FBindCtx, nil, IStream, fOutStream); if Failed(HR) and Assigned(FSender.FOnError) then begin FSender.FOnError(GetLastError, Err_BindToSt + ResponseCodeToStr(HR)); Exit; end else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, Bind_To_St + ResponseCodeToStr(HR)); repeat try if FSender.WaitForProcess(FSender.hStop, FSender.FStartTick, FSender.FTimeOut) then except if Assigned(FSender.FOnError) then FSender.FOnError(E_FAIL, Err_Proc_Ev); raise; end; until (FSender.FCancel) or (FSender.bDone) {and (stream = nil)}{or (BscbInfo.infIndex = 0)}; HR := RevokeBindStatusCallback(FBindCtx, pPrevBSCB); if Failed(HR) then HR := RevokeBindStatusCallback(FBindCtx, tmpBSC); if Failed(HR) and Assigned(FSender.FOnError) then FSender.FOnError(HR, Err_Revoke + ResponseCodeToStr(HR)) else if (Assigned(FSender.FOnConnect)) then FSender.FOnConnect(Self, HR, Revoke_BSCB + ResponseCodeToStr(S_OK)); if FSender.FActiveConnections = 0 then FSender.FBusy := False; if not FSender.IsSynchronous(BscbInfo) then {We are on asynchronous mode} begin FSender.ItemsManager.Extract(Self); {Remove the item from our list because we finished} Dec(BscbInfo.infIndex); {Pass the new index} end; end; procedure TBSCB.GetData(aSender: TCustomIEDownload); begin {Get data from IEDownload to the iedInfo} with BscbInfo do begin infAdditionalHeader.AddStrings(aSender.FAdditionalHeader); infBindF_Value := aSender.FBindF_Value; infBindF2_Value := aSender.FBindF2_Value; infBindInfoF_Value := aSender.FBindInfoF_Value; infBindVerb_Value := aSender.FBindVerb_Value; infBindInfoOptions_Value := aSender.FBindVerb_Value; infCodePage_Value := aSender.FCodePageValue; infCustomVerb := aSender.FCustomVerb; infDescriptor := aSender.Security.FDescriptor; infDownloadFolder := aSender.FDownloadFolder; infExtraInfo := aSender.FExtraInfo; infFileName := aSender.FFileName; inFFileSize := 0; infInheritHandle := aSender.Security.FInheritHandle; infPassword := aSender.FPassword; infPostData := aSender.FPostData; infPutFileName := aSender.FPutFileName; infRangeBegin := aSender.Range.FRangeBegin; infRangeEnd := aSender.Range.FRangeEnd; infTimeOut := aSender.FTimeOut; infUrl := StringToOleStr(aSender.FUrl); infUserName := aSender.FUserName; Sender := aSender; end; end; {Enf of Callback procedure------------------------------------------------------} {BSCBList----------------------------------------------------------------------} function TBSCBList.byURL(Url: string): TBSCB; //by Jury Gerasimov var i: integer; begin Result := nil; for i := 0 to Count - 1 do if Items[i].BscbInfo.infUrl = Url then begin Result := Items[i]; Break; end; end; function TBSCBList.GetItem(Index: Integer): TBSCB; begin Result := TBSCB(inherited GetItem(Index)); end; procedure TBSCBList.SetItem(Index: Integer; Value: TBSCB); begin inherited SetItem(Index, Value); end; constructor TBSCBList.Create; begin inherited Create; SessionList := TStringList.Create; end; destructor TBSCBList.Destroy; begin FreeAndNil(SessionList); inherited Destroy; end; {End of BSCBList---------------------------------------------------------------} {IEDownload--------------------------------------------------------------------} constructor TCustomIEDownload.Create(AOwner: TComponent); begin inherited; TimeSeparator := '_'; {For the feRename} FAbout := IED_INFO; hProcess := 0; bDone := False; bCancelAll := False; FAdditionalHeader := TStringlist.Create; FAdditionalHeader.Add('Content-Type: application/x-www-form-urlencoded '); FBindF := [Asynchronous, AsyncStorage, PullData, NoWriteCache, GetNewestVersion]; FBindF2 := [ReadDataOver4GB]; FBindVerb := Get; FCodePageOption := Ansi; FBindInfoOption_ := [UseBindInfoOptions, AllowConnectMessages]; FDefaultProtocol := 'http://'; FDefaultUrlFileName := 'index.html'; FdlCounter := 0; FActiveConnections := 0; FDownloadMethod := dmFile; FProxySettings := TProxySettings.Create; FProxySettings.FPort := 80; FRange := TRange.Create; FRefCount := 0; FSecurity := TSecurity.Create; FState := sReady; FBindInfoF := []; ItemsManager := TBSCBList.Create; SetUserAgent; end; procedure TCustomIEDownload.Loaded; begin inherited Loaded; if FTimeOut = 0 then FTimeOut := MaxInt; if (FProxySettings.FAutoLoadProxy) and (FProxySettings.FServer <> EmptyStr) then FProxySettings.SetProxy(FFullUserAgent, FProxySettings.FServer + ':' + IntToStr(FProxySettings.FPort)); end; procedure TCustomIEDownload.Resume; begin if BS <> nil then BS.Resume; end; procedure TCustomIEDownload.Suspend; begin if BS <> nil then BS.Suspend; end; destructor TCustomIEDownload.Destroy; begin FTimeOut := 0; FRange.Free; FSecurity.Free; FProxySettings.Free; ItemsManager.Free; if Assigned(FAdditionalHeader) then FreeAndNil(FAdditionalHeader); inherited; end; procedure TCustomIEDownload.BeforeDestruction; begin if FProxySettings.FAutoLoadProxy then FProxySettings.SetProxy(EmptyStr, EmptyStr); {To restore proxy settings} inherited BeforeDestruction; end; procedure TCustomIEDownload.Cancel; begin if (not FBusy) or (FState <> sBusy) then Exit; FCancel := True; Application.ProcessMessages; end; procedure TCustomIEDownload.Reset; begin if (FState = sBusy) then Exit; FCancel := False; bCancelAll := False; Application.ProcessMessages; end; procedure TCustomIEDownload.CancelAll; begin if (not FBusy) or (FState <> sBusy) then Exit; bCancelAll := True; FCancel := True; Application.ProcessMessages; end; procedure TCustomIEDownload.Cancel(const Item: TBSCB); begin Item.CheckCancelState; FCancel := True; end; procedure TCustomIEDownload.Update_BindInfoF_Value; const Acard_BindInfoF_Values: array[TBindInfoF] of Cardinal = ( $00000001, $00000002); var i: TBindInfoF; begin FBindInfoF_Value := 0; if (FBindInfoF <> []) then for i := Low(TBindInfoF) to High(TBindInfoF) do if (i in FBindInfoF) then Inc(FBindInfoF_Value, Acard_BindInfoF_Values[i]); end; procedure TCustomIEDownload.Update_BindF_Value; const Acard_BindF_Values: array[TBindF] of Cardinal = ( $00000001, $00000002, $00000004, $00000008, $00000010, $00000020, $00000040, $00000080, $00000100, $00000200, $00000400, $00000800, $00001000, $00002000, $00004000, $00008000, $00010000, $00020000, $00040000, $00080000, $00100000, $00200000, $00400000, $00800000); var i: TBindF; begin FBindF_Value := 0; if (FBindF <> []) then for i := Low(TBindF) to High(TBindF) do if (i in FBindF) then Inc(FBindF_Value, Acard_BindF_Values[i]); end; procedure TCustomIEDownload.Update_BindInfoOptions_Value; const AcardBindInfoOption_Values: array[TBindInfoOption] of Cardinal = ( $00010000, $00020000, $00040000, $00080000, $00100000, $00200000, $00400000, $00800000, $01000000, $02000000, $08000000, $10000000, $40000000, $80000000, $20000000); var i: TBindInfoOption; begin FBindInfoOption_Value := 0; if (FBindInfoOption_ <> []) then for i := Low(TBindInfoOption) to High(TBindInfoOption) do if (i in FBindInfoOption_) then Inc(FBindInfoOption_Value, AcardBindInfoOption_Values[i]); end; procedure TCustomIEDownload.Update_BindF2_Value; const AcardBindF2_Values: array[TBindF2] of Cardinal = ($00000001, $00000002, $00000004, $00000008, $40000000, $80000000); var i: TBindF2; begin FBindF2_Value := 0; if (FBindF2 <> []) then for i := Low(TBindF2) to High(TBindF2) do if (i in FBindF2) then Inc(FBindF2_Value, AcardBindF2_Values[i]); end; function TCustomIEDownload.OpenFolder(const aFolderName: string): Boolean; var Int: integer; begin Result := False; if (FDownloadMethod = dmFile) then begin Int := ShellExecute(Forms.Application.Handle, PChar('explore'), PChar(aFolderName), nil, nil, SW_SHOWNORMAL); Result := (Int > 32); if not Result and Assigned(FOnError) then FOnError(Int, Err_Folder); end; end; procedure TCustomIEDownload.DoUpdate; begin Update_BindF_Value; Update_BindF2_Value; Update_BindInfoF_Value; Update_BindInfoOptions_Value; end; function TCustomIEDownload.CodeInstallProblemToStr(const ulStatusCode: Integer): string; begin Result := IEDownloadTools.CodeInstallProblemToStr(ulStatusCode); end; function TCustomIEDownload.CheckFileExists(const aFileName: string): boolean; begin Result := FileExists(aFileName); end; procedure TCustomIEDownload.Go(const aUrl: string); begin GoAction(aUrl, EmptyStr, EmptyStr, nil, nil); if FOpenDownloadFolder then OpenFolder(FDownloadFolder); end; procedure TCustomIEDownload.Go(const aUrl: string; const aFileName: string); begin GoAction(aUrl, aFileName, EmptyStr, nil, nil); if FOpenDownloadFolder then OpenFolder(FDownloadFolder); end; procedure TCustomIEDownload.Go(const aUrl: string; const aFileName: string; const aDownloadFolder: string); begin GoAction(aUrl, aFileName, aDownloadFolder, nil, nil); if FOpenDownloadFolder then OpenFolder(FDownloadFolder); end; procedure TCustomIEDownload.GoList(const UrlsList: TStrings); var Idx: integer; begin for Idx := 0 to UrlsList.Count - 1 do if (UrlsList[Idx] <> EmptyStr) and (not bCancelAll) then GoAction(UrlsList[Idx], EmptyStr, EmptyStr, nil, nil); if FOpenDownloadFolder then OpenFolder(FDownloadFolder); end; procedure TCustomIEDownload.GoList(const UrlsList: TStrings; const FileNameList: TStrings); var Idx: integer; begin for Idx := 0 to UrlsList.Count - 1 do if (UrlsList[Idx] <> EmptyStr) and (not bCancelAll) then GoAction(UrlsList[Idx], FileNameList[Idx], EmptyStr, nil, nil); if FOpenDownloadFolder then OpenFolder(FDownloadFolder); end; procedure TCustomIEDownload.GoList(const UrlsList: TStrings; const FileNameList: TStrings; const DownloadFolderList: TStrings); var Idx: integer; begin for Idx := 0 to UrlsList.Count - 1 do if (UrlsList[Idx] <> EmptyStr) and (not bCancelAll) then GoAction(UrlsList[Idx], FileNameList[Idx], DownloadFolderList[Idx], nil, nil); if FOpenDownloadFolder then OpenFolder(FDownloadFolder); end; procedure TCustomIEDownload.Download(const pmk: IMoniker; const pbc: IBindCtx); begin FDownloadTo := dtMoniker; PrepareForStart; hProcess := CreateEvent(nil, True, False, nil); if (not GoInit('', FFileName, FDownloadFolder)) then begin PrepareForExit; Exit; end; BS := TBSCB.Create(Self, pmk, pbc, True); try BS.Execute; repeat try if WaitForProcess(hProcess, FStartTick, FTimeOut) then except if Assigned(FOnError) then FOnError(E_FAIL, Err_Proc_Ev); raise; end; until (FCancel) or (FActiveConnections = 0); finally FreeAndNil(BS); end; PrepareForExit; end; function TCustomIEDownload.GoAction(const actUrl, actFileName, actDownloadFolder: string; pmk: IMoniker; pbc: IBindCtx): boolean; begin Result := False; PrepareForStart; hProcess := CreateEvent(nil, True, False, nil); if (not GoInit(actUrl, actFileName, actDownloadFolder)) then begin PrepareForExit; Exit; end; BS := TBSCB.Create(Self, pmk, pbc, True); {Creating Download Callback} try //Fix Deadlock? BS.Execute; repeat try if WaitForProcess(hProcess, FStartTick, FTimeOut) then except if Assigned(FOnError) then FOnError(E_FAIL, Err_Proc_Ev); raise; end; until (FCancel) or (FActiveConnections = 0); finally FreeAndNil(BS); end; PrepareForExit; Result := True; end; function TCustomIEDownload.URLDownloadToCacheFile(const aUrl: string): string; begin Result := EmptyStr; PrepareForStart; if not GoInit(aUrl, '', '') then Exit; FDownloadTo := dtDownloadToCache; BS := TBSCB.Create(Self, nil, nil, True); try BS.Execute; BS.Terminate; Dec(FActiveConnections); finally FreeAndNil(BS); end; SetBeforeExit; PrepareForExit; Result := FDownloadFolder; end; function TCustomIEDownload.UrlDownloadToFile(const aUrl: string): HRESULT; begin Result := E_FAIL; PrepareForStart; if not GoInit(aUrl, '', '') then Exit; FDownloadTo := dtDownloadToFile; BS := TBSCB.Create(Self, nil, nil, True); try BS.Execute; BS.Terminate; Dec(FActiveConnections); finally FreeAndNil(BS); end; SetBeforeExit; PrepareForExit; Result := S_OK; end; procedure TCustomIEDownload.SetBeforeExit; begin if FOpenDownloadFolder then OpenFolder(FDownloadFolder); if FActiveConnections = 0 then FBusy := False; FState := sStopped; if Assigned(FOnStateChange) then FOnStateChange(FState); end; function TCustomIEDownload.GoInit(const inUrl: string; const inFileName: string; const inDownloadFolder: string): boolean; var tmpNewName: WideString; Act: TFileExistsOption; begin act := FFileExistsOption; tmpNewName := ''; Result := False; if FDownloadTo <> dtMoniker then begin if inUrl = EmptyStr then begin PrepareForExit; Exit; end; FUrl := SetHttpProtocol(inUrl); {We pass the Address we got to the component} if (FValidateUrl) and not (IsUrlValid(FUrl)) then begin PrepareForExit; Exit; end; ItemsManager.SessionList.Add(FUrl); if FDownloadMethod = dmFile then begin FDownloadFolder := SetDownloadFolder(inDownloadFolder); if FDownloadFolder = EmptyStr then Exit; FFileName := inFileName; if (FFileName = EmptyStr) then FFileName := SetFileNameFromUrl(FUrl); {First try} if (CheckFileExists(FDownloadFolder + FFileName)) then begin if Assigned(FOnFileExists) then FOnFileExists(Act, FDownloadFolder + FFileName, tmpNewName); case Act of feSkip: begin PrepareForExit; Exit; end; feRename: begin if tmpNewName = EmptyStr then tmpNewName := TimeToStr(now) + '_' + FFileName; FFileName := tmpNewName; bRenamed := True; end; feOverwrite: FBindF := FBindF + [GetNewestVersion]; end; end; end else FBindF := FBindF + [GetNewestVersion]; end; DoUpdate; Result := True; end; function TCustomIEDownload.WaitForProcess(var EventName: THandle; var aStartTick, aTimeOut: Integer): Boolean; var dwResult: DWORD; Msg: TMsg; EventList: array[0..0] of THandle; begin EventList[0] := EventName; dwResult := MsgWaitForMultipleObjects(1, EventList, False, DWORD(ATimeOut), QS_ALLEVENTS); case dwResult of WAIT_FAILED: {Waiting failed} begin if Assigned(FOnError) then FOnError(GetLastError, SysErrorMessage(GetLastError)); end; WAIT_TIMEOUT: {Waiting Timo out} begin if Assigned(FOnError) then FOnError(GetLastError, SysErrorMessage(GetLastError)); end; WAIT_BSCB: {Our state to process messages} begin while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin TranslateMessage(Msg); DispatchMessage(Msg); if (Integer(GetTickCount) - aStartTick > aTimeOut) then begin if Assigned(FOnError) then FOnError(GetLastError, Err_TimeOut); end; end; if (Integer(GetTickCount) - aStartTick > aTimeOut) then begin if Assigned(FOnError) then FOnError(GetLastError, Err_TimeOut); end; end; end; Result := (dwResult = WAIT_OBJECT_0); {We are done waiting} end; function TCustomIEDownload.IsSynchronous(iedInfo: TInfoData): boolean; begin {Return True if mode is Synchronous} if iedInfo.infBindF_Value <> (iedInfo.infBindF_Value or BINDF_ASYNCHRONOUS) then Result := True else Result := False; end; function TCustomIEDownload.IsAsyncMoniker(const pmk: IMoniker): HRESULT; begin Result := UrlMon.IsAsyncMoniker(pmk); end; function TCustomIEDownload.FormatSize(const Byte: Double): string; begin Result := IEDownloadTools.FormatSize(Byte); end; function TCustomIEDownload.FormatTickToTime(const TickCount: Cardinal): string; begin Result := IEDownloadTools.FormatTickToTime(TickCount); end; function TCustomIEDownload.IsUrlValid(const isUrl: string): Boolean; var U: TUrl; begin U := TUrl.Create(isUrl); try Result := U.IsUrlValid(isUrl); if not Result and Assigned(FOnError) then FOnError(GetLastError, SysErrorMessage(GetLastError) + isUrl); finally U.Free; end; end; procedure TCustomIEDownload.PrepareForExit; begin if Assigned(FOnComplete) then FOnComplete(Self, FDownloadedFile, FFileName, FDownloadFolder, FFileExtension, ActiveConnections); FState := sReady; if Assigned(FOnStateChange) then FOnStateChange(FState); end; procedure TCustomIEDownload.PrepareForStart; begin FBusy := True; bRenamed := False; FCancel := False; FDownloadedFile := EmptyStr; FDownloadFolder := EmptyStr; FFileExtension := EmptyStr; FFileName := EmptyStr; FFileSize := 0; FMimeType := EmptyStr; FServerAddress := EmptyStr; FServerIP := EmptyStr; FUrl := EmptyStr; FState := sBusy; if Assigned(FOnStateChange) then FOnStateChange(FState); FStartTick := GetTickCount; Inc(FRefCount); Inc(FActiveConnections); end; procedure TCustomIEDownload.SetCodePage(const Value: TCodePageOption); begin FCodePageOption := Value; case FCodePageOption of Ansi: FCodePageValue := CP_ACP; Mac: FCodePageValue := CP_MACCP; OEM: FCodePageValue := CP_OEMCP; Symbol: FCodePageValue := CP_SYMBOL; ThreadsAnsi: FCodePageValue := CP_THREAD_ACP; UTF7: FCodePageValue := CP_UTF7; UTF8: FCodePageValue := CP_UTF8; end; end; procedure TCustomIEDownload.SetBindVerb(const Value: TBindVerb); begin {Contains values that specify an action, such as an HTTP request, to be performed during the binding operation.} FBindVerb := Value; case FBindVerb of Get: FBindVerb_Value := BINDVERB_GET; Put: FBindVerb_Value := BINDVERB_PUT; Post: FBindVerb_Value := BINDVERB_POST; Custom: FBindVerb_Value := BINDVERB_CUSTOM; end; end; procedure TCustomIEDownload.SetFileName(const Value: string); begin FFileName := Value; end; function TCustomIEDownload.SetFileNameFromUrl(const aUrl: string): string; var Ut: TUrl; sTmp1, sTmp2: string; begin if FDownloadMethod = dmFile then begin Ut := TUrl.Create(aUrl); try Ut.CrackUrl(aUrl, ICU_ESCAPE); if AnsiPos('.', Ut.ExtraInfo) <> 0 then sTmp1 := Ut.ExtraInfo; Ut.QueryUrl(aUrl); sTmp2 := Ut.Document; finally Ut.Free; end; if sTmp1 <> EmptyStr then begin Result := sTmp1; Exit; end else Result := sTmp2; end; end; procedure TCustomIEDownload.ExtractDataFromFile(const aFileName: string); begin FDownloadedFile := aFileName; FFileName := ExtractFileName(aFileName); FDownloadFolder := ExtractFilePath(aFileName); FFileExtension := ExtractFileExt(aFileName); end; procedure TCustomIEDownload.SetAdditionalHeader(const Value: TStrings); begin {Sets additional headers to append to the HTTP request.} FAdditionalHeader.Assign(Value); end; procedure TCustomIEDownload.SetAbout(Value: string); begin Exit; end; procedure TCustomIEDownload.SetDefaultProtocol(const Value: string); begin FDefaultProtocol := (Value); if FDefaultProtocol = EmptyStr then FDefaultProtocol := 'http://'; end; procedure TCustomIEDownload.SetUserAgent; begin FFullUserAgent := USER_AGENT_IE6 + '(' + FUserAgent + ')' + #13#10; end; procedure TCustomIEDownload.SetBindInfoF(const Value: TBindInfoF_Options); begin FBindInfoF := Value; Update_BindInfoF_Value; end; procedure TCustomIEDownload.SetBindF2(const Value: TBindF2_Options); begin FBindF2 := Value; Update_BindF2_Value; end; procedure TCustomIEDownload.SetBindInfoOption(const Value: TBindInfoOptions_Options); begin FBindInfoOption_ := Value; Update_BindInfoOptions_Value; end; procedure TCustomIEDownload.SetBindF(const Value: TBindF_Options); begin if FFileExistsOption = feOverWrite then FBindF := FBindF + [GetNewestVersion]; FBindF := Value; Update_BindF_Value; end; procedure TCustomIEDownload.SetDownloadMethod(const Value: TDownloadMethod); begin FDownloadMethod := Value; end; function TCustomIEDownload.SetHttpProtocol(const aUrl: string): string; type {Insert http to an address like bsalsa.com } TProtocols = array[1..23] of string; const Protocols: TProtocols = ( 'about', 'cdl', 'dvd', 'file', 'ftp', 'gopher', 'http', 'ipp', 'its', 'javascript', 'local', 'mailto', 'mk', 'msdaipp', 'ms-help', 'ms-its', 'mso', 'res', 'sysimage', 'tv', 'vbscript', 'via', 'https'); var i: Integer; begin for i := 1 to 23 do begin if (AnsiPos(AnsiUpperCase(Protocols[i]), AnsiUpperCase(aUrl)) <> 0) then begin Result := aUrl; Exit; end; end; Result := 'http://' + aUrl; end; function TCustomIEDownload.SetDownloadFolder(const aDownloadFolder: string): string; begin if (FDownloadMethod = dmFile) then begin Result := aDownloadFolder; if (Result = EmptyStr) then Result := ExtractFilePath(Application.ExeName) + DL_DIR; if Result <> EmptyStr then try ForceDirectories(Result); except if Assigned(FOnError) then FOnError(GetLastError, SysErrorMessage(GetLastError) + Err_Creating_Dir); end; end; end; function TCustomIEDownload.ResponseCodeToStr(const dwResponse: Integer): string; begin Result := IEDownloadTools.ResponseCodeToStr(dwResponse); end; function TCustomIEDownload.WideStringToLPOLESTR(const Source: string): POleStr; begin Result := IEDownloadTools.WidestringToLPOLESTR(Source); end; initialization coInitialize(nil); finalization coUninitialize; end.