source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/IEDownload.pas@ 800

Last change on this file since 800 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 100.1 KB
Line 
1//*************************************************************************
2// *
3// IEDownload 2009 *
4// IEDownload is a UrlMon wrapper with a build-in Callback *
5// *
6// Freeware Component *
7// for Delphi by *
8// Eran Bodankin *
9// and Per Lindsø Larsen *
10// *
11// *
12// Updated versions: *
13// http://www.bsalsa.com *
14//*************************************************************************
15{LICENSE:
16THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
17EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
18WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
19YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
20AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
21AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
22OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
23OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
24INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
25OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
26AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
27DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
28
29You may use, change or modify the component under 4 conditions:
301. In your website, add a link to "http://www.bsalsa.com"
312. In your application, add credits to "Embedded Web Browser"
323. Mail me (bsalsa@gmail.com) any code change in the unit
33 for the benefit of the other users.
344. Please, consider donation in our web site!
35{*******************************************************************************}
36//$Id: IEDownload.pas,v 1.6 2009/02/25 11:56:31 bsalsa Exp $
37
38
39unit IEDownload;
40
41{To use the MSHTML, just remove the dot in the line below like {$DEFINE USE_MSHTML}{
42and re-compile the package.}
43{$DEFINE USE_MSHTML}
44
45interface
46
47{$I EWB.inc}
48
49
50uses
51 Dialogs, IEDownloadAcc, Controls, Shellapi, IEConst, ActiveX,
52 Contnrs, ExtCtrls, Windows, WinInet, UrlMon, Classes, SysUtils
53{$IFDEF DELPHI5}, FileCtrl{$ENDIF}{$IFDEF USE_MSHTML}, MSHTML_EWB{$ENDIF};
54
55const
56 WAIT_BSCB = WAIT_OBJECT_0 + 1;
57
58{$IFNDEF UNICODE}
59type
60 RawByteString = AnsiString;
61{$ENDIF UNICODE}
62
63type
64 TProxySettings = class(TPersistent)
65 private
66 FPort: Integer;
67 FServer: string;
68 FAutoLoadProxy: Boolean;
69 public
70 function SetProxy(const FullUserAgent, ProxyServer: string): Boolean;
71 published
72 property AutoLoadProxy: Boolean read FAutoLoadProxy write FAutoLoadProxy
73 default False;
74 property Port: Integer read FPort write FPort default 80;
75 property Server: string read FServer write FServer;
76 end;
77
78 TCustomIEDownload = class;
79
80 TInfoData = class(TList)
81 public
82 infAdditionalHeader: TStrings;
83 infBindF_Value: Cardinal;
84 infBindF2_Value: Cardinal;
85 infBindInfoF_Value: Cardinal;
86 infBindInfoOptions_Value: Cardinal;
87 infBindVerb_Value: Cardinal;
88 infCodePage_Value: Cardinal;
89 infCustomVerb: string;
90 infDescriptor: RawByteString;
91 infDownloadFolder: string;
92 infExtraInfo: string;
93 infFileExt: string;
94 infFileName: string;
95 infFileSize: Cardinal;
96 infHost: string;
97 infIndex: Integer;
98 infInheritHandle: Boolean;
99 infPassword: string;
100 infPostData: string;
101 infPutFileName: string;
102 infRangeBegin: Cardinal;
103 infRangeEnd: Integer;
104 infSender: TCustomIEDownload;
105 infTimeOut: Integer;
106 infUrl: PWideChar;
107 infUserAgent: string;
108 infUserName: string;
109 Sender: TObject;
110 public
111 constructor Create;
112 destructor Destroy; override;
113 end;
114
115 TThreadStatus = (tsRunning, tsSuspended, tsWaiting, tsTerminated);
116 TState = (sBusy, sReady, sStopped);
117
118 TBSCB = class(TThread,
119 IAuthenticate,
120{$IFDEF DELPHI6_UP}
121 IAuthenticateEx,
122 IMonikerProp,
123{$ENDIF}
124 IBindHost,
125 IWindowForBindingUI,
126 IBindStatusCallback,
127 IBindStatusCallbackEx,
128 ICodeInstall,
129 IHttpNegotiate,
130 IHttpNegotiate2,
131 IHttpNegotiate3,
132 IHTTPSecurity,
133{$IFDEF USE_MSHTML}
134 IPropertyNotifySink,
135{$ENDIF}
136 IServiceProvider,
137 IUnknown)
138
139 private
140 Frequency: Int64;
141 TimeStarted: Int64;
142 TimeNow: Int64;
143 FSender: TCustomIEDownload;
144 FBindCtx: IBindCtx;
145 FBSCBTimer: TTimer;
146 FDataSize: Integer;
147 FGlobalData: HGLOBAL;
148 FMoniker: IMoniker;
149 FRedirect: Boolean;
150 fOutStream: IStream;
151 FTimedOut: Boolean;
152 FTotalRead: Cardinal;
153 m_pPrevBSCB: IBindStatusCallback;
154 fsOutputFile: TFileStream;
155
156 function GetSerializedClientCertContext(out ppbCert: Byte; var pcbCert: DWORD): HResult; stdcall;
157{$IFDEF DELPHI6_UP}
158 function AuthenticateEx(out phwnd: HWND; out pszUsername,
159 pszPassword: LPWSTR; var pauthinfo: AUTHENTICATEINFO): HResult; stdcall;
160 {IMonikerProp Interface}
161 function PutProperty(mkp: MONIKERPROPERTY; val: LPCWSTR): HResult;
162 stdcall;
163{$ENDIF}
164
165 {IBindStatusCallbackEx}
166 function GetBindInfoEx(out grfBINDF: DWORD; var pbindinfo: BINDINFO;
167 out grfBINDF2: DWORD; out pdwReserved: DWORD): HResult; stdcall;
168
169
170{$IFDEF USE_MSHTML}
171 {IPropertyNotifySink Interface}
172 function OnChanged(dispId: TDispId): HRESULT; stdcall;
173 function OnRequestEdit(dispId: TDispId): HRESULT; stdcall;
174{$ENDIF}
175
176 {IHttpNegotiate2 Interface}
177 function GetRootSecurityId(var SecurityIdBuffer: TByteArray; var
178 BufferSize: DWord; dwReserved: DWORD): HResult; stdcall;
179
180 {IBindStatusCallback Interface}
181 function GetBindInfo(out grfBINDF: DWORD; var BindInfo: TBindInfo): HRESULT;
182 stdcall;
183 function GetPriority(out nPriority): HRESULT; stdcall;
184 function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; FormatEtc:
185 PFormatEtc; stgmed: PStgMedium): HRESULT; stdcall;
186 function OnLowResource(Reserved: DWORD): HRESULT; stdcall;
187 function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
188 szStatusText: LPCWSTR): HRESULT; stdcall;
189 function OnObjectAvailable(const IID: TGUID; punk: IUnknown): HRESULT;
190 stdcall;
191 function OnStartBinding(dwReserved: DWORD; pib: IBinding): HRESULT; stdcall;
192 function OnStopBinding(HRESULT: HRESULT; szError: LPCWSTR): HRESULT;
193 stdcall;
194 function OnSecurityProblem(dwProblem: DWORD): HRESULT; stdcall;
195
196 {IHTTPNegotiate methods}
197 function OnResponse(dwResponseCode: DWORD; szResponseHeaders,
198 szRequestHeaders: LPCWSTR;
199 out szAdditionalRequestHeaders: LPWSTR): HRESULT; stdcall;
200 function BeginningTransaction(szURL, szHeaders: LPCWSTR; dwReserved: DWORD;
201 out szAdditionalHeaders: LPWSTR): HRESULT; stdcall;
202
203 {IUnknown Interface}
204 function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
205 function _AddRef: Integer; stdcall;
206 function _Release: Integer; stdcall;
207
208 {IWindowForBindingUI methods}
209 function GetWindow(const GUIDReason: TGUID; out hwnd): HRESULT; stdcall;
210
211 {IAuthenticate Interface}
212 function Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR):
213 HResult; stdcall;
214
215 {ICodeInstall Interface}
216 function OnCodeInstallProblem(ulStatusCode: ULONG; szDestination, szSource:
217 LPCWSTR;
218 dwReserved: DWORD): HResult; stdcall;
219
220 {IBindHost Interface}
221 function CreateMoniker(szName: POLEStr; BC: IBindCtx; out mk: IMoniker;
222 dwReserved: DWORD): HResult; stdcall;
223 function MonikerBindToStorage(Mk: IMoniker; BC: IBindCtx; BSC:
224 IBindStatusCallback;
225 const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult; stdcall;
226 function MonikerBindToObject(Mk: IMoniker; BC: IBindCtx; BSC:
227 IBindStatusCallback;
228 const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult; stdcall;
229
230 {IServiceProvider Interface}
231 function QueryService(const rsid, iid: TGUID; out Obj): HRESULT; stdcall;
232
233 function GetBindResult(out clsidProtocol: TCLSID; out dwResult: DWORD;
234 out szResult: POLEStr): HRESULT;
235 private
236 function CheckCancelState: Integer;
237 procedure ClearAll;
238 procedure TimerExpired(Sender: TObject);
239 procedure DoConnect;
240 procedure DoDownloadToFile;
241 procedure DoDownloadToCache;
242 procedure ReceiveData;
243 procedure ReturnData;
244 procedure GetData(aSender: TCustomIEDownload);
245 procedure SetComponents;
246 protected
247 procedure Execute; override;
248 procedure Suspend;
249 procedure Terminate;
250 procedure Resume;
251
252 public
253 Stream: TStream;
254 Binding: IBinding;
255 BscbInfo: TInfoData;
256 ThreadStatus: TThreadStatus;
257 constructor Create(aSender: TCustomIEDownload; const pmk: IMoniker;
258 const pbc: IBindCtx; CreateSuspended: boolean);
259 destructor Destroy; override;
260 function QueryInfoFileName: HRESULT;
261 function DoSaveFileAs: string;
262 function QueryInfo(dwOption: DWORD; var Info: Cardinal): Boolean; overload;
263 function QueryInfo(dwOption: DWORD; var Info: string): Boolean; overload;
264 function QueryInfo(dwOption: DWORD; var Info: TDateTime): Boolean; overload;
265 function IsRunning: Boolean;
266 function GetDisplayName: PWideChar;
267 function GetFileNameFromUrl(Url: string): string;
268 function AbortBinding: Hresult;
269 function MkParseDisplayName(var DisplayName: PWideChar): IMoniker;
270 end;
271
272 TBSCBList = class(TObjectList) {by Jury Gerasimov}
273 private
274 function GetItem(Index: Integer): TBSCB;
275 procedure SetItem(Index: Integer; Value: TBSCB);
276 public
277 SessionList: TStrings;
278 constructor Create;
279 destructor Destroy; override;
280 property Items[Index: Integer]: TBSCB read GetItem write SetItem; default;
281 function byURL(Url: string): TBSCB;
282 end;
283
284 TSecurity = class(TPersistent)
285 private
286 FInheritHandle: Boolean;
287 FDescriptor: RawByteString;
288 published
289 property InheritHandle: boolean read FInheritHandle write FInheritHandle
290 default False;
291 property Descriptor: RawByteString read FDescriptor write FDescriptor;
292 end;
293
294 TRange = class(TPersistent)
295 private
296 FRangeBegin: Integer;
297 FRangeEnd: Integer;
298 published
299 property RangeBegin: Integer read FRangeBegin write FRangeBegin default 0;
300 property RangeEnd: Integer read FRangeEnd write FRangeEnd default 0;
301 end;
302 {http://msdn.microsoft.com/en-us/library/ms775130(VS.85).aspx}
303 TBindF = (Asynchronous, AsyncStorage, NoProgressiveRendering,
304 OfflineOperation, GetNewestVersion, NoWriteCache, NeedFile, PullData,
305 IgnoreSecurityProblem, Resynchronize, AllowHyperlink, No_UI,
306 SilentOperation, Pragma_No_Cache, GetClassObject, Reserved_1,
307 Free_Threaded, DirectReadIgnoreSize, HandleAsFormsSubmit,
308 GetFromCacheIfNetFail, FromUrlmon, FisrtTryCache, PreferDefaultHandler,
309 RestrictedSitesZone);
310 TBindF_Options = set of TBindF;
311 TBindF2 = (DisableBasicAuth, DisableAutoCookie, DisableRedirectUnlessSID,
312 ReadDataOver4GB, Reserved_2, Reserved_11);
313 TBindF2_Options = set of TBindF2;
314 TBindInfoF = (PostData, ExtraInfo);
315 TBindInfoF_Options = set of TBindInfoF;
316 TBindInfoOption = (UseBindInfoOptions, EnableUtf8, DisableUtf8, UseIE_Encoding,
317 BindToObject, SecurityOptOut, IgnoreMimeTextPlain, UseBindStrCredentials,
318 IgnoreHttp2HttpsRedirect, IgnoreSslErrOnce, WpcDownloadBlocked, WpcLoggingEnabled,
319 DisableAutoRedirect, ShDocVw_Reserved, AllowConnectMessages);
320 TBindInfoOptions_Options = set of TBindInfoOption;
321 TBindVerb = (Get, Post, Put, Custom);
322 TCodePageOption = (
323 Ansi, {default to ANSI code page}
324 OEM, {default to OEM code page}
325 Mac, {default to MAC code page}
326 ThreadsAnsi, {Current thread's ANSI code page}
327 Symbol, {Symbol code page (42)}
328 UTF7, {Translate using UTF-7}
329 UTF8); {Translate using UTF-8}
330
331 TDownloadTo = (dtNormal, dtDownloadToFile, dtDownloadToCache, dtMoniker);
332 TDownloadMethod = (dmStream, dmFile); {Set download to a file or astream}
333 TFileExistsOption = (feOverWrite, feSkip, feRename); {If file exsits then..}
334
335 TQueryInterfaceEvent = function(const IID: TGUID; out Obj): HRESULT of object;
336 TAuthenticateEvent = procedure(Sender: TBSCB; var tmpHWND: HWnd;
337 var szUserName, szPassWord: WideString; var Rezult: HRESULT) of object;
338{$IFDEF DELPHI6_UP}
339 TAuthenticateExEvent = procedure(Sender: TBSCB; var tmpHWND: HWnd;
340 var szUserName, szPassWord: WideString; pauthinfo: AUTHENTICATEINFO;
341 var Rezult: HRESULT) of object;
342 TOnPutPropertyEvent = function(Sender: TBSCB; mkp: MONIKERPROPERTY; val: LPCWSTR): HResult of object;
343{$ENDIF}
344
345 TOnCodeInstallProblemEvent = function(Sender: TBSCB; ulStatusCode: ULONG;
346 szDestination, szSource: LPCWSTR;
347 dwReserved: DWORD; stResult: string): HRESULT of object;
348 TStateChangeEvent = procedure(const State: TState) of object;
349 TErrorEvent = procedure(const ErrorCode: integer; const
350 stError: string) of object;
351 TOnConnectEvent = procedure(Sender: TBSCB; Res: HRESULT; stMessage: string) of
352 object;
353 TOnGetBindInfoEvent = function(Sender: TBSCB; out grfBINDF: DWORD; var
354 BindInfo: TBindInfo): HRESULT of object;
355 TOnGetBindInfoExEvent = function(Sender: TBSCB; out grfBINDF: DWORD; pbindinfo: BINDINFO;
356 out grfBINDF2: DWORD): HRESULT of object;
357 TRedirect = procedure(Sender: TBSCB; var AbortRedirect: boolean; const
358 FromUrl: string; const DestUrl: string) of object;
359 TBeginningTransactionEvent = function(Sender: TBSCB; szURL, szHeaders:
360 LPCWSTR; dwReserved: DWORD;
361 out szAdditionalHeaders: LPWSTR): HRESULT of object;
362 TOnResponseEvent = function(Sender: TBSCB; dwResponseCode: DWORD;
363 szResponseHeaders, szRequestHeaders: LPCWSTR;
364 out szAdditionalRequestHeaders: LPWSTR): HRESULT of object;
365 TOnSecurityProblemEvent = function(Sender: TBSCB; dwProblem: DWORD; Problem:
366 string): HRESULT of object;
367 TFileExistsEvent = procedure(var Action: TFileExistsOption; const aFileName:
368 WideString; var NewFileName: WideString) of object;
369 TOnProgressEvent = procedure(Sender: TBSCB; ulProgress, ulProgressMax,
370 ulStatusCode, FileSize: ULONG; szStatusText: LPCWSTR; Downloaded,
371 ElapsedTime, Speed, RemainingTime, Status, Percent: string) of object;
372 TOnDataAvailableEvent = procedure(Sender: TBSCB; var Buffer: PByte; var
373 BufLength: Cardinal) of object;
374 TOnDataAvailableInfoEvent = procedure(Sender: TBSCB; grfBSCF: DWORD;
375 Status: string {; FormatEtc: PFormatEtc}) of object;
376 TOnCompleteEvent = procedure(Sender: TCustomIEDownload; aFileNameAndPath, aFileName,
377 aFolderName, aExtension: WideString; const ActiveConnections: Integer) of object;
378 TOnStreamCompleteEvent = procedure(Sender: TBSCB; Stream: TStream; Result:
379 HRESULT) of object;
380 TOnResumeEvent = procedure(Sender: TBSCB; FileName: string; var Action:
381 Cardinal) of object;
382 TGetWindowEvent = function(Sender: TBSCB; const GUIDReason: TGUID; out hwnd:
383 LongWord): HRESULT of object;
384 TOnStartBindingEvent = procedure(Sender: TBSCB; var Cancel: Boolean; pib:
385 IBinding; const FileName: WideString; const FileSize: integer) of object;
386 TOnStopBindingEvent = procedure(Sender: TBSCB; HRESULT: HRESULT;
387 szError: LPCWSTR) of object;
388 TOnGetBindResultsEvent = procedure(var Sender: TBSCB; out clsidProtocol:
389 TCLSID; out dwResult: DWORD; out szResult: POLEStr;
390 const stResult: string) of object;
391 TOnGetClientCertEvent = function(var Sender: TBSCB; out ppbCert: Byte; var pcbCert: DWORD): HResult of object;
392 TTerminateEvent = procedure(const Sender: TBSCB; const ThreadId: Integer;
393 const aFileName: Widestring; var bCancel: Boolean) of object;
394 TOnGetRootSecurityIdEvent = function(var SecurityIdBuffer: TByteArray; var
395 BufferSize: DWord): HRESULT of object;
396 {IServiceProvider Interface}
397 TQueryServiceEvent = procedure(Sender: TObject; const rsid, iid: TGUID; var
398 Obj: IUnknown) of object;
399 TOnBeforeDownloadEvent = procedure(Sender: TInfoData; const Url, FileName,
400 FileExtension, Host, DownloadFolder: string; const FileSize: Integer; var Cancel: Boolean) of object;
401
402 TCustomIEDownload = class(TComponent)
403
404 private
405 FAbout: string;
406 bCancelAll: boolean;
407 bDone: boolean;
408 bRenamed: boolean;
409 BS: TBSCB;
410 FActiveConnections: integer;
411 FAdditionalHeader: TStrings;
412 FBeginningTransaction: TBeginningTransactionEvent;
413 FBindF: TBindF_Options;
414 FBindF_Value: Cardinal;
415 FBindF2: TBindF2_Options;
416 FBindF2_Value: Cardinal;
417 FBindInfoF: TBindInfoF_Options;
418 FBindInfoF_Value: Cardinal;
419 FBindInfoOption_: TBindInfoOptions_Options;
420 FBindInfoOption_Value: Cardinal;
421 FBindVerb: TBindVerb;
422 FBindVerb_Value: Cardinal;
423 FBusy: Boolean;
424 FCancel: Boolean;
425 FCodePageOption: TCodePageOption;
426 FCodePageValue: Cardinal;
427 FCustomVerb: string;
428 FDefaultProtocol: string;
429 FDefaultUrlFileName: string;
430 FDisplayName: PWideChar;
431 FdlCounter: integer;
432 FDownloadedFile: string;
433 FDownloadFolder: string;
434 FDownloadMethod: TDownloadMethod;
435 FDownloadTo: TDownloadTo;
436 FExtraInfo: string;
437 FFileExistsOption: TFileExistsOption;
438 FFileExtension: string;
439 FFileName: string;
440 FFileSize: ULong;
441 FFullUserAgent: string;
442 FGetWindow: TGetWindowEvent;
443 FHWnd: HWND;
444 FMimeType: string;
445 FOnAuthenticate: TAuthenticateEvent;
446{$IFDEF DELPHI6_UP}
447 FOnAuthenticateEx: TAuthenticateExEvent;
448 FOnPutProperty: TOnPutPropertyEvent;
449{$ENDIF}
450 FOnCodeInstallProblem: TOnCodeInstallProblemEvent;
451 FOnComplete: TOnCompleteEvent;
452 FOnConnect: TOnConnectEvent;
453 FOnBeforeDownload: TOnBeforeDownloadEvent;
454 FOnDataAvailable: TOnDataAvailableEvent;
455 FOnDataAvailableInfo: TOnDataAvailableInfoEvent;
456 FOnError: TErrorEvent;
457 FOnFileExists: TFileExistsEvent;
458 FOnGetBindInfo: TOnGetBindInfoEvent;
459 FOnGetBindInfoEx: TOnGetBindInfoExEvent;
460 FOnGetBindResults: TOnGetBindResultsEvent;
461 FOnGetClientCert: TOnGetClientCertEvent;
462 FOnGetRootSecurityId: TOnGetRootSecurityIdEvent;
463 FOnProgress: TOnProgressEvent;
464 FOnQueryInterface: TQueryInterfaceEvent;
465 FOnQueryService: TQueryServiceEvent;
466 FOnRedirect: TRedirect;
467 FOnResponse: TOnResponseEvent;
468 FOnResume: TOnResumeEvent;
469 FOnSecurityProblem: TOnSecurityProblemEvent;
470 FOnStartBinding: TOnStartBindingEvent;
471 FOnStateChange: TStateChangeEvent;
472 FOnStopBinding: TOnStopBindingEvent;
473 FOnStreamComplete: TOnStreamCompleteEvent;
474 FOnTerminate: TTerminateEvent;
475 FOpenDownloadFolder: Boolean;
476 FPassword: string;
477 FPostData: string;
478 FProxySettings: TProxySettings;
479 FPutFileName: string;
480 FRange: TRange;
481 FRefCount: Integer;
482 FSecurity: TSecurity;
483 FServerAddress: string;
484 FServerIP: string;
485 FStartTick: Integer;
486 FState: TState;
487 FTimeOut: Integer;
488 FUrl: string;
489 FUserAgent: string;
490 FUserName: string;
491 FUseSystemDownloadFolder: boolean;
492 FValidateUrl: boolean;
493 hProcess: THandle;
494 hStop: THandle;
495
496 private
497 function GoAction(const actUrl, actFileName, actDownloadFolder: string;
498 pmk: IMoniker; pbc: IBindCtx): boolean;
499 function GoInit(const inUrl: string; const inFileName: string;
500 const inDownloadFolder: string): boolean;
501 function SetDownloadFolder(const aDownloadFolder: string): string;
502 function SetHttpProtocol(const aUrl: string): string;
503 procedure DoUpdate;
504 procedure ExtractDataFromFile(const aFileName: string);
505 procedure PrepareForExit;
506 procedure PrepareForStart;
507 procedure SetAbout(Value: string);
508 procedure SetAdditionalHeader(const Value: TStrings);
509 procedure SetBeforeExit;
510 procedure SetBindF(const Value: TBindF_Options);
511 procedure SetBindF2(const Value: TBindF2_Options);
512 procedure SetBindInfoF(const Value: TBindInfoF_Options);
513 procedure SetBindInfoOption(const Value: TBindInfoOptions_Options);
514 procedure SetBindVerb(const Value: TBindVerb);
515 procedure SetCodePage(const Value: TCodePageOption);
516 procedure SetDefaultProtocol(const Value: string);
517 procedure SetDownloadMethod(const Value: TDownloadMethod);
518 procedure SetFileName(const Value: string);
519 procedure SetUserAgent;
520 procedure Update_BindF_Value;
521 procedure Update_BindF2_Value;
522 procedure Update_BindInfoF_Value;
523 procedure Update_BindInfoOptions_Value;
524
525 public
526 ItemsManager: TBSCBList;
527 constructor Create(AOwner: TComponent); override;
528 destructor Destroy; override;
529 function CheckFileExists(const aFileName: string): boolean;
530 function CodeInstallProblemToStr(const ulStatusCode: Integer): string;
531 function FormatSize(const Byte: Double): string;
532 function FormatTickToTime(const TickCount: Cardinal): string;
533 function IsAsyncMoniker(const pmk: IMoniker): HRESULT;
534 function IsSynchronous(iedInfo: TInfoData): boolean;
535 function IsUrlValid(const isUrl: string): Boolean;
536 function OpenFolder(const aFolderName: string): Boolean;
537 function ResponseCodeToStr(const dwResponse: Integer): string;
538 function SetFileNameFromUrl(const aUrl: string): string;
539 function URLDownloadToCacheFile(const aUrl: string): string;
540 function UrlDownloadToFile(const aUrl: string): HRESULT;
541 function WaitForProcess(var EventName: THandle; var aStartTick,
542 aTimeOut: Integer): Boolean;
543 function WideStringToLPOLESTR(const Source: string): POleStr;
544 procedure BeforeDestruction; override;
545 procedure Cancel(const Item: TBSCB); overload;
546 procedure Cancel; overload;
547 procedure Reset;
548 procedure CancelAll;
549 procedure Download(const pmk: IMoniker; const pbc: IBindCtx); overload;
550 procedure Go(const aUrl: string); overload;
551 procedure Go(const aUrl: string; const aFileName: string); overload;
552 procedure Go(const aUrl: string; const aFileName: string; const
553 aDownloadFolder: string); overload;
554 procedure GoList(const UrlsList: TStrings); overload;
555 procedure GoList(const UrlsList: TStrings; const FileNameList: TStrings);
556 overload;
557 procedure GoList(const UrlsList: TStrings; const FileNameList: TStrings;
558 const DownloadFolderList: TStrings); overload;
559 procedure Loaded; override;
560 procedure Resume;
561 procedure Suspend;
562
563 public
564 property ActiveConnections: integer read FActiveConnections;
565 property Busy: Boolean read FBusy;
566 property DisplayName: PWideChar read FDisplayName;
567 property DownloadedFile: string read FDownloadedFile;
568 property DownloadsCounter: integer read FdlCounter;
569 property FileExtension: string read FFileExtension;
570 property FileSize: ULong read FFileSize;
571 property MimeType: string read FMimeType;
572 property ServerAddress: string read FServerAddress;
573 property ServerIP: string read FServerIP;
574 property State: TState read FState;
575
576 published
577 property About: string read FAbout write SetAbout;
578 property AdditionalHeader: TStrings read FAdditionalHeader write
579 SetAdditionalHeader;
580 property BindF: TBindF_Options read FBindF write
581 SetBindF default [Asynchronous, AsyncStorage, PullData,
582 NoWriteCache, GetNewestVersion];
583 property BindF2: TBindF2_Options read FBindF2 write
584 SetBindF2 default [ReadDataOver4GB];
585 property BindInfoF: TBindInfoF_Options read FBindInfoF write
586 SetBindInfoF default [];
587 property BindVerb: TBindVerb read FBindVerb write
588 SetBindVerb default Get;
589 property BindInfoOptions: TBindInfoOptions_Options read FBindInfoOption_
590 write SetBindInfoOption default [UseBindInfoOptions, AllowConnectMessages];
591 property CodePage: TCodePageOption read FCodePageOption write
592 SetCodePage default Ansi;
593 property CustomVerb: string read FCustomVerb write FCustomVerb;
594 property DefaultProtocol: string read FDefaultProtocol write
595 SetDefaultProtocol;
596 property DefaultUrlFileName: string read FDefaultUrlFileName write
597 FDefaultUrlFileName;
598 property DownloadFolder: string read FDownloadFolder write
599 FDownloadFolder;
600 property DownloadMethod: TDownloadMethod read FDownloadMethod write
601 SetDownloadMethod default dmFile;
602 property ExtraInfo: string read FExtraInfo write FExtraInfo;
603 property FileExistsOption: TFileExistsOption read FFileExistsOption write
604 FFileExistsOption default feOverwrite;
605 property FileName: string read FFileName write SetFileName;
606 property OnAuthenticate: TAuthenticateEvent read FOnAuthenticate
607 write FOnAuthenticate;
608{$IFDEF DELPHI6_UP}
609 property OnAuthenticateEx: TAuthenticateExEvent read FOnAuthenticateEx
610 write FOnAuthenticateEx;
611 property OnPutProperty: TOnPutPropertyEvent read FOnPutProperty write FOnPutProperty;
612{$ENDIF}
613 property OnBeforeDownload: TOnBeforeDownloadEvent read FOnBeforeDownload write FOnBeforeDownload;
614 property OnBeginningTransaction: TBeginningTransactionEvent read
615 FBeginningTransaction write FBeginningTransaction;
616 property OnCodeInstallProblem: TOnCodeInstallProblemEvent read
617 FOnCodeInstallProblem write FOnCodeInstallProblem;
618 property OnDataAvailable: TOnDataAvailableEvent read
619 FOnDataAvailable write FOnDataAvailable;
620 property OnDataAvailableInfo: TOnDataAvailableInfoEvent read
621 FOnDataAvailableInfo write FOnDataAvailableInfo;
622 property OnConnect: TOnConnectEvent read FOnConnect write FOnConnect;
623 property OnComplete: TOnCompleteEvent read FOnComplete write FOnComplete;
624 property OnStreamComplete: TOnStreamCompleteEvent read
625 FOnStreamComplete write FOnStreamComplete;
626 property OnError: TErrorEvent read FOnError write FOnError;
627 property OnGetBindResults: TOnGetBindResultsEvent read
628 FOnGetBindResults write FOnGetBindResults;
629 property OnGetBindInfo: TOnGetBindInfoEvent read
630 FOnGetBindInfo write FOnGetBindInfo;
631 property OnGetBindInfoEx: TOnGetBindInfoExEvent read
632 FOnGetBindInfoEx write FOnGetBindInfoEx;
633 property OnGetSerializedClientCertContext: TOnGetClientCertEvent read FOnGetClientCert
634 write FOnGetClientCert;
635 property OnGetRootSecurityId: TOnGetRootSecurityIdEvent
636 read FOnGetRootSecurityId write FOnGetRootSecurityId;
637 property OnGetWindow: TGetWindowEvent read FGetWindow write
638 FGetWindow;
639 property OnFileExists: TFileExistsEvent read FOnFileExists write
640 FOnFileExists;
641 property OnProgress: TOnProgressEvent read FOnProgress write
642 FOnProgress;
643 property OnQueryInterface: TQueryInterfaceEvent read
644 FOnQueryInterface write FOnQueryInterface;
645 property OnQueryService: TQueryServiceEvent read FOnQueryService write
646 FOnQueryService;
647 property OnRedirect: TRedirect read FOnRedirect write FOnRedirect;
648 property OnResponse: TOnResponseEvent read FOnResponse
649 write FOnResponse;
650 property OnResume: TOnResumeEvent read FOnResume write FOnResume;
651 property OnSecurityProblem: TOnSecurityProblemEvent read FOnSecurityProblem
652 write FOnSecurityProblem;
653 property OnStartBinding: TOnStartBindingEvent read FOnStartBinding write
654 FOnStartBinding;
655 property OnStateChange: TStateChangeEvent read FOnStateChange write
656 FOnStateChange;
657 property OnTerminate: TTerminateEvent read FOnTerminate write FOnTerminate;
658 property OnStopBinding: TOnStopBindingEvent read FOnStopBinding
659 write FOnStopBinding;
660 property OpenDownloadFolder: Boolean read FOpenDownloadFolder write
661 FOpenDownloadFolder default False;
662 property Password: string read FPassword write FPassword;
663 property PostData: string read FPostData write FPostData;
664 property ProxySettings: TProxySettings read FProxySettings write
665 FProxySettings;
666 property PutFileName: string read FPutFileName write FPutFileName;
667 property Range: TRange read FRange write FRange;
668 property Security: TSecurity read FSecurity write FSecurity;
669 property TimeOut: Integer read FTimeOut write FTimeOut default 0;
670 property Url: string read FUrl write FUrl;
671 property UserAgent: string read FUserAgent write FUserAgent;
672 property UserName: string read FUserName write FUserName;
673 property UseSystemDownloadFolder: boolean read FUseSystemDownloadFolder write
674 FUseSystemDownloadFolder default False;
675 property ValidateUrl: boolean read FValidateUrl write FValidateUrl default
676 False;
677 end;
678
679 TIEDownload = class(TCustomIEDownload)
680 published
681 end;
682
683var
684 ThreadStatusDesc: array[TThreadStatus] of string = ('Running', 'Suspended',
685 'Waiting', 'Terminated');
686
687implementation
688
689uses
690 IEDownloadStrings, EwbUrl, IEDownloadTools, Forms
691{$IFDEF DELPHI6_UP}, StrUtils{$ENDIF};
692
693
694{TInfoData---------------------------------------------------------------------}
695
696constructor TInfoData.Create;
697begin
698 inherited Create;
699 InfAdditionalHeader := TStringList.Create;
700end;
701
702destructor TInfoData.Destroy;
703begin {Cleaning out and free our resources}
704 Clear;
705 Remove(Sender);
706 Extract(Self);
707 {Its just to make sure we cleanly remove the IEDownload as an object}
708 Remove(infSender);
709 Extract(Self);
710 if Assigned(infAdditionalHeader) then
711 FreeAndNil(infAdditionalHeader);
712 inherited;
713end;
714{End of TInfoData--------------------------------------------------------------}
715
716{Proxy Settings-----------------------------------------------------------------}
717
718function TProxySettings.SetProxy(const FullUserAgent, ProxyServer: string):
719 Boolean; //mladen
720var
721 intList: INTERNET_PER_CONN_OPTION_List;
722 dwBufSize: DWORD;
723 hInternet: Pointer;
724 intOptions: array[1..3] of INTERNET_PER_CONN_OPTION;
725begin
726 Result := False;
727 dwBufSize := SizeOf(intList);
728 intList.dwSize := SizeOf(intList);
729 intList.pszConnection := nil;
730 intList.dwOptionCount := High(intOptions);
731 // the highest index of the array (in this case 3)
732 intOptions[1].dwOption := INTERNET_PER_CONN_FLAGS;
733 intOptions[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
734 intOptions[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
735 intOptions[2].Value.pszValue := PChar(ProxyServer);
736 intOptions[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
737 intOptions[3].Value.pszValue := '<local>';
738 intList.intOptions := @intOptions;
739 hInternet := InternetOpen(PChar(FullUserAgent), INTERNET_OPEN_TYPE_DIRECT,
740 nil, nil, 0);
741 if hInternet <> nil then
742 try
743 Result := InternetSetOption(hInternet,
744 INTERNET_OPTION_PER_CONNECTION_OPTION,
745 @intList, dwBufSize);
746 Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH,
747 nil, 0);
748 finally
749 InternetCloseHandle(hInternet)
750 end;
751end;
752{End of Proxy Settings-----------------------------------------------------------}
753
754{$IFDEF USE_MSHTML}
755
756function TBSCB.OnChanged(dispId: TDispId): HRESULT;
757var
758 DP: TDispParams;
759 vResult: OLEVariant;
760 Doc: IHTMLDocument2;
761begin
762 if (DISPID_READYSTATE = DispId) then
763 if Succeeded((Doc as IHTMLDocument2).Invoke(DISPId_READYSTATE, GUId_null,
764 LOCALE_System_DEFAULT, DISPATCH_PROPERTYGET, DP, @vResult, nil, nil)) then
765 if Integer(vResult) = READYSTATE_COMPLETE then
766 PostThreadMessage(GetCurrentThreadId, WM_USER_STARTWALKING, 0, 0);
767 Result := S_OK;
768end;
769
770function TBSCB.OnRequestEdit(dispId: TDispId): HRESULT;
771begin
772 Result := E_NOTIMPL;
773end;
774{$ENDIF}
775{Callback procedure--------------------------------------------------------------}
776{IAuthenticate Interface
777Provides the URL moniker with information to authenticate the user}
778
779function TBSCB.Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR):
780 HResult;
781{Provides the URL moniker with information to authenticate the user.
782S_OK Authentication was successful.
783E_ACCESSDENIED Authentication failed.
784E_INVALIDARG One or more parameters are invalid. }
785var
786 aUser, aPwd: WideString;
787begin
788 Result := S_OK;
789 hwnd := FSender.FHWnd;
790 aUser := EmptyStr;
791 aPwd := EmptyStr;
792 if Assigned(FSender.FOnAuthenticate) then
793 FSender.FOnAuthenticate(Self, hwnd, aUser, aPwd, Result);
794 if aUser <> EmptyStr then
795 szUserName := WidestringToLPOLESTR(aUser)
796 else
797 szUserName := nil;
798 if aPwd <> EmptyStr then
799 szPassWord := WidestringToLPOLESTR(aPwd)
800 else
801 szPassWord := nil;
802end;
803
804{IHttpNegotiate Interface
805Implemented by a client application to provide support for HTTP negotiations}
806
807function TBSCB.BeginningTransaction(szURL, szHeaders: LPCWSTR; dwReserved:
808 DWORD; out szAdditionalHeaders: LPWSTR): HRESULT;
809{IHttpNegotiate::BeginningTransaction Method
810Notifies the client of the URL that is being bound to at the beginning of an HTTP transaction.
811S_OK The HTTP transaction completed successfully and any additional headers specified have been appended.
812E_ABORT The HTTP transaction has been terminated.
813E_INVALIDARG A parameter is invalid.}
814var
815 sr: TSearchRec;
816 Action: Cardinal;
817 tmpNewName: WideString;
818 NewHeaders: string;
819 Size: Longint;
820 x, Len: Integer;
821 ActExists: TFileExistsOption;
822begin
823 ActExists := FSender.FFileExistsOption;
824 tmpNewName := '';
825 dwReserved := 0;
826 if (FSender.FCancel) and (Binding <> nil) then
827 begin
828 Result := E_ABORT;
829 binding.Abort;
830 Exit;
831 end;
832 NewHeaders := FSender.FFullUserAgent + #13 + #10;
833 if (BscbInfo.infFileName <> EmptyStr) then
834 begin
835 if FindFirst(BscbInfo.infFileName, faAnyFile, sr) = 0 then
836 begin
837 Size := sr.Size;
838 FindClose(sr);
839 BscbInfo.infRangeEnd := 0;
840 Action := 0;
841
842 {IBinding still do not support resume (By MS 4.2009)}
843 if Assigned(FSender.FOnResume) then
844 begin
845 FSender.FOnResume(Self, BscbInfo.infFileName, Action);
846 BscbInfo.infRangeBegin := Size;
847 end;
848
849 if Assigned(FSender.FOnFileExists) then
850 FSender.FOnFileExists(ActExists, BscbInfo.infFileName, tmpNewName);
851
852 if tmpNewName = EmptyStr then
853 tmpNewName := TimeToStr(now) + '_' + BscbInfo.infFileName;
854 case ActExists of
855 feOverwrite:
856 begin
857 Binding.Resume;
858 if Assigned(FSender.FOnResume) then
859 FSender.FOnResume(Self, BscbInfo.infFileName, Action);
860 BscbInfo.infRangeBegin := 0
861 end;
862 feSkip:
863 begin
864 Result := E_ABORT;
865 Binding.Abort;
866 Exit;
867 end;
868 feRename: BscbInfo.infFileName := tmpNewName;
869 end
870 end;
871 end
872 else {Download is starting}
873 begin {Set the range to 0 which means start download from scratch}
874 BscbInfo.infRangeBegin := 0;
875 BscbInfo.infRangeEnd := 0;
876 end;
877
878 if ((BscbInfo.infRangeBegin <> 0) or (BscbInfo.infRangeEnd <> 0)) then
879 begin {We set the new headers to send to the server}
880 NewHeaders := NewHeaders + 'Range: bytes=' +
881 IntToStr(BscbInfo.infRangeBegin) + '-';
882 if BscbInfo.infRangeEnd <> 0 then
883 NewHeaders := NewHeaders + IntToStr(BscbInfo.infRangeEnd) + #13#10
884 else
885 NewHeaders := NewHeaders + #13#10;
886 end;
887 if (BscbInfo.infAdditionalHeader.Text <> EmptyStr) then
888 for x := 0 to BscbInfo.infAdditionalHeader.Count - 1 do
889 NewHeaders := NewHeaders + BscbInfo.infAdditionalHeader[x] + #13#10;
890 Len := Length(NewHeaders);
891 szAdditionalHeaders := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar));
892 StringToWideChar(NewHeaders, szAdditionalHeaders, Len + 1);
893 {We will post the event}
894 if Assigned(FSender.FBeginningTransaction) then
895 Result := FSender.FBeginningTransaction(Self, szURL, szHeaders,
896 dwReserved, szAdditionalHeaders)
897 else
898 Result := S_OK;
899 FBSCBTimer.Enabled := True; {Timeout timer}
900 FTimedOut := False;
901 Self._Release;
902end;
903
904function TBSCB.OnResponse(dwResponseCode: DWORD; szResponseHeaders,
905 szRequestHeaders: LPCWSTR; out szAdditionalRequestHeaders: LPWSTR): HRESULT;
906{Enables the client of a bind operation to examine the response headers,
907 optionally terminate the bind operation, and add HTTP headers to a
908 request before resending the request.
909Returns one of the following values.
910S_OK The operation completed successfully.
911E_ABORT Terminate the HTTP transaction.
912E_INVALIDARG The parameter is invalid.}
913var
914 Len: Cardinal;
915 S: string;
916 tmpName: string;
917begin
918 if (FSender.FCancel) and (Binding <> nil) then
919 begin
920 Result := E_ABORT;
921 binding.Abort;
922 Exit;
923 end;
924 Result := S_OK;
925 if (QueryInfo(HTTP_QUERY_CUSTOM, Len) and (Len = 0)) {file size = 0}
926 or (QueryInfo(HTTP_QUERY_CONTENT_LENGTH, Len) and (Len = 0)) {file size = 0}
927 or (dwResponseCode >= 400) then {An Error}
928 begin
929 Result := E_ABORT;
930 if Assigned(FSender.FOnError) then
931 FSender.FOnError(dwResponseCode,
932 ResponseCodeToStr(dwResponseCode));
933 end;
934 begin {Publish the event}
935 if Assigned(FSender.FOnResponse) then
936 Result := FSender.FOnResponse(Self, dwResponseCode,
937 szResponseHeaders, szRequestHeaders, szAdditionalRequestHeaders);
938 if (FSender.FDownloadTo = dtDownloadToFile)
939 or (FSender.FDownloadTo = dtDownloadToCache) then
940 begin
941 Result := S_OK;
942 Exit;
943 end;
944
945 if (BscbInfo.infRangeBegin <> 0) and (BscbInfo.infFileName <> EmptyStr) then
946 begin {Retrieves the types of range requests that are accepted for a resource.}
947 QueryInfo(HTTP_QUERY_ACCEPT_RANGES, S);
948 {'Partial Content'}
949 if (S = 'bytes') or (dwResponseCode = 206) then
950 begin {Create an output file as a stream back from where we finished}
951 tmpName := DoSaveFileAs;
952 if tmpName <> EmptyStr then
953 begin
954 fsOutputFile := TFileStream.Create(tmpName, fmOpenReadWrite);
955 fsOutputFile.Seek(0, soFromEnd);
956 end;
957 end
958 else
959 begin {'Create an output file as a stream from range begin 0'}
960 // not needed
961 tmpName := DoSaveFileAs;
962 if tmpName <> EmptyStr then
963 begin
964 fsOutputFile := TFileStream.Create(tmpName, fmCreate);
965 BscbInfo.infRangeBegin := 0;
966 end;
967 end;
968 end
969 else
970 begin {Here we create the file}
971 if (FSender.FDownloadMethod = dmFile) then
972 begin
973 tmpName := DoSaveFileAs;
974 if tmpName <> EmptyStr then
975 begin
976 fsOutputFile := TFileStream.Create(tmpName, fmCreate);
977 fsOutputFile.Seek(0, soFromBeginning);
978 end;
979 end;
980 end
981 end;
982end;
983
984{IHttpNegotiate2 Interface}
985
986function TBSCB.GetRootSecurityId(var SecurityIdBuffer: TByteArray; var
987 BufferSize: DWord; dwReserved: DWORD): HResult;
988begin {Gets a root security ID.}
989 if Assigned(FSender.FOnGetRootSecurityId) then
990 Result := FSender.FOnGetRootSecurityId(SecurityIdBuffer, BufferSize)
991 else
992 Result := E_NOTIMPL;
993end;
994
995function TBSCB.GetBindInfoEx(out grfBINDF: DWORD; var pbindinfo: BINDINFO;
996 out grfBINDF2: DWORD; out pdwReserved: DWORD): HResult;
997var
998 PutFile: TFileStream;
999 Len: Integer;
1000begin
1001 pdwReserved := 0;
1002 if Assigned(FSender.FOnGetBindInfoEx) then
1003 FSender.FOnGetBindInfoEx(Self, grfBINDF, pbindinfo, grfBINDF2);
1004 grfBINDF := BscbInfo.infBindF_Value; {Insert our options.}
1005 grfBINDF2 := BscbInfo.infBindF2_Value; {Insert our options 2.}
1006 with pbindinfo do {Lets play with our options.}
1007 begin
1008 cbSize := SizeOf(TBindInfo);
1009 if FRedirect then
1010 begin {Set method to get in case of redirect}
1011 dwBindVerb := BINDVERB_GET;
1012 end
1013 else {Insert the options}
1014 dwBindVerb := BscbInfo.infBindVerb_Value;
1015 grfBindInfoF := BscbInfo.infBindInfoF_Value;
1016 dwCodePage := BscbInfo.infCodePage_Value;
1017 {Insert security arguments}
1018 with SecurityAttributes do
1019 begin
1020 nLength := SizeOf(TSecurityAttributes);
1021 bInheritHandle := BscbInfo.infInheritHandle;
1022 if BscbInfo.infDescriptor <> '' then
1023 lpSecurityDescriptor := PAnsiChar(BscbInfo.infDescriptor)
1024 else
1025 lpSecurityDescriptor := nil;
1026 end;
1027 {Insert Extra Info}
1028 if BscbInfo.infExtraInfo <> EmptyStr then
1029 begin
1030 Len := Length(BscbInfo.infExtraInfo);
1031 szExtraInfo := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar));
1032 StringToWideChar(BscbInfo.infExtraInfo, szExtraInfo, Len + 1);
1033 end
1034 else
1035 szExtraInfo := nil;
1036 case BscbInfo.infBindVerb_Value of
1037 {Now we will set by our BindVerbOption}
1038 BINDVERB_PUT: {Perform an HTTP PUT operation. The data to put should be
1039 specified in the stgmedData member of the BINDINFO structure.}
1040 if BscbInfo.infPutFileName <> EmptyStr then
1041 begin
1042 PutFile := TFileStream.Create(BscbInfo.infPutFileName,
1043 fmOpenRead);
1044 try
1045 PutFile.Seek(0, 0);
1046 FGlobalData := GlobalAlloc(GPTR, PutFile.Size);
1047 FDataSize := PutFile.Size;
1048 PutFile.ReadBuffer(Pointer(FGlobalData)^, PutFile.Size);
1049 finally
1050 PutFile.Free;
1051 end;
1052 end;
1053 BINDVERB_POST: {Perform an HTTP POST operation.
1054 The data to be posted should be specified in the stgmedData
1055 member of the BINDINFO structure.}
1056 if BscbInfo.infPostData <> EmptyStr then
1057 begin
1058 FGlobalData := GlobalAlloc(GPTR, Length(BscbInfo.infPostData)
1059 + 1);
1060 FDataSize := Length(BscbInfo.infPostData) + 1;
1061 Move(BscbInfo.infPostData[1], Pointer(FGlobalData)^,
1062 Length(BscbInfo.infPostData));
1063 end;
1064 BINDVERB_CUSTOM: {Perform a custom operation that is protocol-specific
1065 See the szCustomVerb member of the BINDINFO structure.
1066 The data to be used in the custom operation should be specified
1067 in the stgmedData structure.}
1068 if (BscbInfo.infCustomVerb <> EmptyStr) then
1069 begin
1070 Len := Length(BscbInfo.infCustomVerb);
1071 szCustomVerb := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar));
1072 StringToWideChar(BscbInfo.infCustomVerb, szCustomVerb, Len + 1);
1073 end
1074 else {BINDVERB_GET so no need to play arround.}
1075 szCustomVerb := nil;
1076 end;
1077 FillChar(stgmedData, 0, SizeOf(STGMEDIUM));
1078 cbStgmedData := FDataSize;
1079 with StgmedData do
1080 begin
1081 if dwBindVerb = BINDVERB_GET then
1082 {The stgmedData member of the BINDINFO
1083 structure should be set to TYMED_NULL for the GET operation}
1084 Tymed := TYMED_NULL
1085 else
1086 Tymed := TYMED_HGLOBAL;
1087 {this is the only medium urlmon supports right now}
1088 hGlobal := FGlobalData;
1089 IUnknown(unkForRelease) := Self; {Set the IUnknown interface}
1090 end;
1091 end;
1092 Result := S_OK;
1093end;
1094
1095{IBindStatusCallback Interface}
1096{Accepts information on an asynchronous bind operation.}
1097
1098function TBSCB.GetBindInfo(out grfBINDF: DWORD; var BindInfo: TBindInfo):
1099 HRESULT;
1100{Provides information about how the bind operation is handled when
1101 it is called by an asynchronous moniker.
1102Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.}
1103var
1104 PutFile: TFileStream;
1105 Len: Integer;
1106begin
1107 grfBINDF := BscbInfo.infBindF_Value; {Insert our options.}
1108 with BindInfo do {Lets play with our options.}
1109 begin
1110 cbSize := SizeOf(TBindInfo);
1111 if FRedirect then
1112 begin {Set method to get in case of redirect}
1113 dwBindVerb := BINDVERB_GET;
1114 end
1115 else {Insert the options}
1116 dwBindVerb := BscbInfo.infBindVerb_Value;
1117 grfBindInfoF := BscbInfo.infBindInfoF_Value;
1118 dwCodePage := BscbInfo.infCodePage_Value;
1119 {Insert security arguments}
1120 with SecurityAttributes do
1121 begin
1122 nLength := SizeOf(TSecurityAttributes);
1123 bInheritHandle := BscbInfo.infInheritHandle;
1124 if BscbInfo.infDescriptor <> '' then
1125 lpSecurityDescriptor := PAnsiChar(BscbInfo.infDescriptor)
1126 else
1127 lpSecurityDescriptor := nil;
1128 end;
1129 {Insert Extra Info}
1130 if BscbInfo.infExtraInfo <> EmptyStr then
1131 begin
1132 Len := Length(BscbInfo.infExtraInfo);
1133 szExtraInfo := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar));
1134 StringToWideChar(BscbInfo.infExtraInfo, szExtraInfo, Len + 1);
1135 end
1136 else
1137 szExtraInfo := nil;
1138 case BscbInfo.infBindVerb_Value of
1139 {Now we will set by our BindVerbOption}
1140 BINDVERB_PUT: {Perform an HTTP PUT operation. The data to put should be
1141 specified in the stgmedData member of the BINDINFO structure.}
1142 if BscbInfo.infPutFileName <> EmptyStr then
1143 begin {Create a process to put a file}
1144 PutFile := TFileStream.Create(BscbInfo.infPutFileName,
1145 fmOpenRead);
1146 try
1147 PutFile.Seek(0, 0);
1148 FGlobalData := GlobalAlloc(GPTR, PutFile.Size);
1149 FDataSize := PutFile.Size;
1150 PutFile.ReadBuffer(Pointer(FGlobalData)^, PutFile.Size);
1151 finally
1152 PutFile.Free;
1153 end;
1154 end;
1155
1156 BINDVERB_POST: {Perform an HTTP POST operation.
1157 The data to be posted should be specified in the stgmedData
1158 member of the BINDINFO structure.}
1159 if BscbInfo.infPostData <> EmptyStr then
1160 begin
1161 FGlobalData := GlobalAlloc(GPTR, Length(BscbInfo.infPostData)
1162 + 1);
1163 FDataSize := Length(BscbInfo.infPostData) + 1;
1164 Move(BscbInfo.infPostData[1], Pointer(FGlobalData)^,
1165 Length(BscbInfo.infPostData));
1166 end;
1167 BINDVERB_CUSTOM: {Perform a custom operation that is protocol-specific
1168 See the szCustomVerb member of the BINDINFO structure.
1169 The data to be used in the custom operation should be specified
1170 in the stgmedData structure.}
1171 if (BscbInfo.infCustomVerb <> EmptyStr) then
1172 begin
1173 Len := Length(BscbInfo.infCustomVerb);
1174 szCustomVerb := CoTaskMemAlloc((Len + 1) * SizeOf(WideChar));
1175 StringToWideChar(BscbInfo.infCustomVerb, szCustomVerb, Len + 1);
1176 end
1177 else {BINDVERB_GET so no need to play arround.}
1178 szCustomVerb := nil;
1179 end;
1180 FillChar(stgmedData, 0, SizeOf(STGMEDIUM));
1181 cbStgmedData := FDataSize;
1182 with StgmedData do
1183 begin
1184 if dwBindVerb = BINDVERB_GET then
1185 {The stgmedData member of the BINDINFO
1186 structure should be set to TYMED_NULL for the GET operation}
1187 Tymed := TYMED_NULL
1188 else
1189 Tymed := TYMED_HGLOBAL;
1190 {this is the only medium urlmon supports right now}
1191 hGlobal := FGlobalData;
1192 IUnknown(unkForRelease) := Self; {Set the IUnknown interface}
1193 end;
1194 end;
1195 if Assigned(FSender.FOnGetBindInfo) then
1196 FSender.FOnGetBindInfo(Self, grfBINDF, BindInfo);
1197 Result := S_OK;
1198end;
1199
1200
1201function TBSCB.GetPriority(out nPriority): HRESULT;
1202{Gets the priority for the bind operation when it is called by an asynchronous moniker.}
1203{Returns S_OK if this is successful or E_INVALIDARG if the pnPriority parameter is invalid.}
1204begin {if you want to set priority you should implement SetPriority in your application}
1205 Result := S_OK;
1206 if (FSender.FCancel) and (Binding <> nil) then
1207 binding.Abort
1208end;
1209
1210function TBSCB.OnDataAvailable(grfBSCF, dwSize: DWORD; FormatEtc: PFormatEtc;
1211 stgmed: PStgMedium): HRESULT;
1212{Provides data to the client as it becomes available during
1213asynchronous bind operations.OnDataAvailable return E_PENDING
1214when they reference data not yet available through their read
1215methods, rather than blocking until the data becomes available.
1216 This flag applies only to ASYNCHRONOUS operations}
1217{Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.}
1218var
1219 Data: PByte;
1220 BufL, dwRead, dwActuallyRead: Cardinal;
1221begin
1222 if (FSender.FCancel) and (Binding <> nil) then
1223 binding.Abort
1224 else
1225 begin
1226
1227 if Assigned(FSender.FOnDataAvailableInfo) then
1228 FSender.FOnDataAvailableInfo(Self, grfBSCF,
1229 DataAvalibleToStr(grfBSCF) {, FormatEtc});
1230
1231 if Assigned(FBSCBTimer) then {reset our timer.}
1232 begin
1233 FBSCBTimer.Enabled := False;
1234 FBSCBTimer.Enabled := True;
1235 end;
1236
1237 if (grfBSCF = grfBSCF or BSCF_FIRSTDATANOTIFICATION) then
1238 begin
1239
1240 if (fOutStream = nil) and (stgmed.tymed = TYMED_ISTREAM) then
1241 fOutStream := IStream(stgmed.stm);
1242 if Assigned(m_pPrevBSCB) and not Assigned(fsOutputFile)
1243 and (BscbInfo.infFileName <> '') then
1244 try
1245 //TODO: check for resume
1246 fsOutputFile := TFileStream.Create(DoSaveFileAs, fmCreate);
1247 BscbInfo.infRangeBegin := 0;
1248 except on EFCreateError do
1249 begin
1250 Binding.Abort;
1251 Result := E_FAIL;
1252 Exit;
1253 fsOutputFile.Free;
1254 end;
1255 end;
1256 end;
1257 dwRead := dwSize - FTotalRead;
1258 dwActuallyRead := 0;
1259 if (dwRead > 0) then
1260 repeat
1261 Data := AllocMem(dwRead + 1);
1262 fOutStream.Read(Data, dwRead, @dwActuallyRead);
1263 BufL := dwActuallyRead;
1264 if Assigned(FSender.FOnDataAvailable) then
1265 begin
1266 FSender.FOnDataAvailable(self, Data, BufL);
1267 end;
1268 if (BscbInfo.infFileName <> '') and Assigned(fsOutputFile) then
1269 begin
1270 fsOutputFile.WriteBuffer(Data^, BufL);
1271 end
1272 else if Assigned(Stream) then
1273 Stream.WriteBuffer(Data^, BufL);
1274 Inc(FTotalRead, dwActuallyRead);
1275 FreeMem(Data);
1276 until dwActuallyRead = 0;
1277 end;
1278 Result := S_OK;
1279 {if (grfBSCF = grfBSCF or BSCF_FIRSTDATANOTIFICATION) then
1280 begin
1281 if (fOutStream = nil) and (stgmed.tymed = TYMED_ISTREAM) then
1282 fOutStream := IStream(stgmed.stm);
1283 if Assigned(m_pPrevBSCB) and not Assigned(fsOutputFile)
1284 //and (BscbInfo.infFileName <> '')
1285 then
1286 // and (FSender.FDownloadMethod = dmFile) then
1287 try
1288 fsOutputFile := TFileStream.Create(DoSaveFileAs, fmCreate);
1289 BscbInfo.infRangeBegin := 0;
1290 except on EFCreateError do
1291 begin
1292 Binding.Abort;
1293 Result := E_INVALIDARG;
1294 if Assigned(FSender.FOnError) then
1295 FSender.FOnError(GetLastError, SysErrorMessage(GetLastError));
1296 fsOutputFile.Free;
1297 Exit;
1298 end;
1299 end;
1300 end;
1301 dwRead := dwSize - FTotalRead;
1302 dwActuallyRead := 0;
1303 if (dwRead > 0) then
1304 repeat
1305 Data := AllocMem(dwRead + 1); //to fix stack overflow
1306 fOutStream.Read(Data, dwRead, @dwActuallyRead);
1307 BufL := dwActuallyRead;
1308 if Assigned(FSender.FOnDataAvailable) then
1309 FSender.FOnDataAvailable(Self, Data, Bufl);
1310 try
1311 Stream.WriteBuffer(Data^, Bufl);
1312 except
1313 on EWriteError do
1314 begin
1315 Binding.Abort;
1316 Result := E_INVALIDARG;
1317 if Assigned(FSender.FOnError) then
1318 FSender.FOnError(GetLastError, SysErrorMessage(GetLastError));
1319 fsOutputFile.Free;
1320 Exit;
1321 end;
1322 end;
1323
1324 if (FSender.FDownloadMethod = dmFile) and Assigned(fsOutputFile) then
1325 begin
1326 try
1327 fsOutputFile.WriteBuffer(Data^, bufl);
1328 except
1329 on EWriteError do
1330 begin
1331 Binding.Abort;
1332 Result := E_INVALIDARG;
1333 if Assigned(FSender.FOnError) then
1334 FSender.FOnError(GetLastError, SysErrorMessage(GetLastError));
1335 fsOutputFile.Free;
1336 Exit;
1337 end
1338 end;
1339 end;
1340 Inc(FTotalRead, dwActuallyRead);
1341 FreeMem(Data);
1342 until dwActuallyRead = 0;
1343 end;
1344 Result := S_OK;}
1345end;
1346
1347function TBSCB.OnLowResource(Reserved: DWORD): HRESULT;
1348{Not implemented by MS.}
1349begin
1350 Result := E_NOTIMPL;
1351end;
1352
1353function TBSCB.OnObjectAvailable(const IID: TGUID; punk: IUnknown): HRESULT;
1354{Passes the requested object interface pointer to the client.}
1355{Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.}
1356begin
1357 Self._AddRef;
1358 if (FSender.FCancel) and (Binding <> nil) then
1359 binding.Abort;
1360 Result := S_OK;
1361end;
1362
1363function TBSCB.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
1364 szStatusText: LPCWSTR): HRESULT;
1365{Indicates the progress and the status of the bind operation.}
1366{Returns S_OK if this is successful or E_INVALIDARG if one or more parameters are invalid.}
1367{Avalible flags: http://msdn.microsoft.com/en-us/library/ms775133(VS.85).aspx}
1368var
1369 Percent, Speed, Elapsed, Downloaded, RemainingTime, Status: string;
1370 _Speed: Single;
1371 bAbort: Boolean;
1372 tmpElapsed, iFileSize: integer;
1373begin
1374 if (FSender.FCancel) and (Binding <> nil) then
1375 Binding.Abort
1376 else
1377 begin
1378 tmpElapsed := 0;
1379 bAbort := False;
1380 Status := ResponseCodeToStr(ulStatusCode);
1381 if (ulProgress > ulProgressMax) then
1382 ulProgressMax := ulProgress;
1383 iFileSize := ulProgressMax;
1384 FSender.FFileSize := ulProgressMax;
1385 {For a download manager}
1386 if Assigned(m_pPrevBSCB) then
1387 begin
1388 {Weed to do this otherwise a filedownload dlg will be displayed
1389 as we are downloading the file.}
1390 if (ulStatusCode = BINDSTATUS_CONTENTDISPOSITIONATTACH) then
1391 begin
1392 Result := S_OK;
1393 Exit; {We must exit so no DLG will be displayed}
1394 end;
1395 m_pPrevBSCB.OnProgress(ulProgress, ulProgressMax, ulStatusCode,
1396 szStatusText);
1397 end;
1398 case ulStatusCode of
1399 BINDSTATUS_REDIRECTING: {redirecting}
1400 begin
1401 FRedirect := True;
1402 FSender.FServerAddress := szStatusText;
1403 if (Assigned(FSender.FOnRedirect)) and
1404 (FSender.FUrl <> szStatusText) then
1405 FSender.FOnRedirect(Self, bAbort, FSender.FUrl, szStatusText);
1406 if bAbort then {If we do not wish to be redirect}
1407 begin
1408 FSender.FCancel := True;
1409 Result := E_INVALIDARG;
1410 Exit;
1411 end;
1412 {Get the new addreess after redirecing}
1413 if (FSender.FDownloadMethod = dmFile) then
1414 FSender.SetFileNameFromUrl(szStatusText);
1415 end;
1416 BINDSTATUS_CONNECTING: FSender.FServerIP := szStatusText;
1417 BINDSTATUS_MIMETYPEAVAILABLE: FSender.FMimeType := szStatusText;
1418 BINDSTATUS_BEGINDOWNLOADDATA: FSender.FServerAddress := szStatusText;
1419 BINDSTATUS_DOWNLOADINGDATA: {We are downloading so here we will calculate download variables}
1420 if Assigned(FSender.FOnProgress) then
1421 begin
1422 if (ulProgress {+ BscbInfo.infRangeBegin} > 0) then
1423 Downloaded := FormatSize(ulProgress {+ BscbInfo.infRangeBegin});
1424 if (ulProgressMax > 0) and (ulProgress > 0) then
1425 Percent := Format('%.1f %%', [ulProgress / ulProgressMax * 100]);
1426 QueryPerformanceCounter(TimeNow);
1427 if (TimeNow > TimeStarted)
1428 {and (Round((TimeNow-TimeStarted)/Frequency) <= tmpElapsed)}then
1429 begin
1430 tmpElapsed := Round((TimeNow - TimeStarted) / Frequency);
1431 Elapsed := SecToStr(tmpElapsed);
1432 end;
1433 try
1434 if (ulProgress > 0) and (tmpElapsed > 0) then
1435 _Speed := ulProgress / 1024 / tmpElapsed
1436 else
1437 _Speed := 0;
1438 Speed := Format('%.1f ' + kb_sec, [_Speed]);
1439 if (ulProgressMax > 0) and ((_Speed) > 0) and (ulProgressMax >
1440 ulProgress) then
1441 RemainingTime := SecToStr(Round(ulProgressMax / _speed / 1000)
1442 - Round(ulProgress / _speed / 1000))
1443 else
1444 RemainingTime := TimeToStr(0);
1445 except
1446 on EZeroDivide do
1447 RemainingTime := TimeToStr(0);
1448 end;
1449 end;
1450
1451 BINDSTATUS_ENDDOWNLOADDATA: {You are joking right? NO MORE DATA TO DOWNLOAD}
1452 begin
1453 Downloaded := done;
1454 ulProgress := 0;
1455 ulProgressMax := 0;
1456 Speed := '0/00' + kb_sec;
1457 RemainingTime := '00.00.00';
1458 Status := done;
1459 Percent := '100%';
1460 end;
1461 {Here you can add more handlers to any BINDSTATUS_ you like}
1462 end;
1463
1464 if Assigned(FSender.FOnProgress) then {Publish the event}
1465 FSender.FOnProgress(Self, ulProgress {+ BscbInfo.infRangeBegin},
1466 ulProgressMax {+ BscbInfo.infRangeBegin}, ulStatusCode, iFileSize, szStatusText,
1467 Downloaded, Elapsed, Speed, RemainingTime, Status, Percent);
1468 end;
1469 Result := S_OK;
1470end;
1471
1472function TBSCB.GetFileNameFromUrl(Url: string): string;
1473var
1474 Ut: TUrl;
1475begin
1476 Ut := TUrl.Create(Url);
1477 try
1478 Ut.CrackUrl(Url, ICU_ESCAPE);
1479 if AnsiPos('.', Ut.ExtraInfo) = 0 then
1480 Result := FSender.FDefaultUrlFileName
1481 else
1482 Result := Ut.ExtraInfo;
1483 finally
1484 Ut.Free;
1485 end;
1486end;
1487
1488function TBSCB.OnStartBinding(dwReserved: DWORD; pib: IBinding): HRESULT;
1489{Notifies the client about the callback methods that it is registered to receive.}
1490{Returns S_OK if this is successful or
1491 E_INVALIDARG if the pib parameter is invalid.
1492To abort the binding we should return E_FAIL.}
1493var
1494 bAbort: Boolean;
1495begin
1496 //dwReserved:= 0; // A demand by ms that is not needed.}
1497 if FSender.FCancel then
1498 Result := E_FAIL
1499 else
1500 begin
1501
1502 Result := S_OK;
1503 bAbort := False;
1504 Binding := pib; {A pointer to the IBinding interface}
1505 Binding._AddRef; {To be released on StopBinding}
1506 {We will try to get the file size using query info}
1507 QueryInfo(HTTP_QUERY_CONTENT_LENGTH, BscbInfo.infFileSize);
1508 QueryInfoFileName;
1509 if Assigned(FSender.FOnBeforeDownload) then
1510 FSender.FOnBeforeDownload(BscbInfo, BscbInfo.infUrl, BscbInfo.infFileName,
1511 BscbInfo.infFileExt, BscbInfo.infHost, BscbInfo.infDownloadFolder,
1512 BscbInfo.infFileSize, bAbort);
1513
1514 {For the download manager}
1515 FSender.FFileName := BscbInfo.infFileName;
1516 FSender.FDownloadFolder := BscbInfo.infDownloadFolder;
1517 if Assigned(m_pPrevBSCB) then
1518 m_pPrevBSCB.OnStopBinding(HTTP_STATUS_OK, nil);
1519
1520 {Remove file name which is not needed for stream}
1521 case FSender.FDownloadMethod of
1522 dmStream: BscbInfo.infFileName := EmptyStr;
1523 dmFile:
1524 begin {Try # 2}
1525 if (BscbInfo.infFileName = EmptyStr) and (FSender.FDownloadTo = dtMoniker) then
1526 BscbInfo.infFileName := GetFileNameFromUrl(FSender.FUrl)
1527 else
1528 begin
1529 if (BscbInfo.infFileName = EmptyStr) and (not FSender.bRenamed) and
1530 (BscbInfo.infFileName <> GetFileNameFromUrl(BscbInfo.infUrl)) then
1531 BscbInfo.infFileName := GetFileNameFromUrl(BscbInfo.infUrl);
1532 end;
1533 end;
1534 end;
1535 if Assigned(FSender.FOnStartBinding) then
1536 FSender.FOnStartBinding(Self, bAbort, Binding, BscbInfo.infFileName, BscbInfo.infFileSize);
1537 if bAbort then
1538 begin {Note: We are still in busy state until OnStopBinding!!}
1539 Result := E_FAIL; {Do not use Binding.Abort! Just send E_FAIL}
1540 FSender.FCancel := True;
1541 end;
1542 end;
1543end;
1544
1545function TBSCB.OnStopBinding(HRESULT: HRESULT; szError: LPCWSTR): HRESULT;
1546{This method indicates the end of the bind operation.
1547Returns S_OK if this is successful or an error value otherwise.}
1548var
1549 clsidProtocol: TCLSID;
1550 dwResult: DWORD;
1551 szResult: POLEStr;
1552 HR: System.HRESULT;
1553begin //OK
1554 if (FSender.FDownloadTo = dtDownloadToFile)
1555 or (FSender.FDownloadTo = dtDownloadToCache) then
1556 begin
1557 Result := S_OK;
1558 Exit;
1559 end;
1560
1561 if (Assigned(m_pPrevBSCB) and Assigned(FBindCtx)) then
1562 {Stores an IUnknown pointer on the specified object }
1563 begin {To be used with a download manager}
1564 HR := FBindCtx.RegisterObjectParam('_BSCB_Holder_', m_pPrevBSCB);
1565 if Failed(HR) and Assigned(FSender.FOnError) then
1566 FSender.FOnError(GetLastError, SysErrorMessage(GetLastError))
1567 else if (Assigned(FSender.FOnConnect)) then
1568 FSender.FOnConnect(Self, HR, Registering_new_moniker +
1569 ResponseCodeToStr(HR));
1570 m_pPrevBSCB._Release;
1571 m_pPrevBSCB := nil;
1572 FBindCtx._Release;
1573 FBindCtx := nil;
1574 Dec(FSender.FRefCount);
1575 end;
1576
1577 GetBindResult(clsidProtocol, dwResult, szResult);
1578 if FTimedOut then
1579 begin {If we reached TimeOut them we will post the event}
1580 HRESULT := INET_E_CONNECTION_TIMEOUT;
1581 if Assigned(FSender.FOnError) then
1582 FSender.FOnError(HRESULT, ResponseCodeToStr(HRESULT));
1583 end;
1584 if Assigned(FSender.FOnStopBinding) then
1585 FSender.FOnStopBinding(Self, HRESULT, szError);
1586 Result := HRESULT;
1587 FSender.FState := sStopped;
1588 if Assigned(FSender.FOnStateChange) then
1589 FSender.FOnStateChange(FSender.FState);
1590
1591 if Assigned(FSender.FOnStreamComplete) then
1592 FSender.FOnStreamComplete(Self, Stream, HRESULT);
1593 FSender.bDone := True;
1594 SetEvent(FSender.hStop);
1595 Terminate;
1596 Dec(FSender.FActiveConnections);
1597 if FSender.FActiveConnections = 0 then
1598 SetEvent(FSender.hProcess);
1599end;
1600
1601{IServiceProvider Interface}
1602
1603function TBSCB.QueryService(const rsid, iid: TGUID; out Obj): HRESULT;
1604begin
1605 Pointer(Obj) := nil;
1606 if Assigned(FSender.FOnQueryService) then
1607 FSender.FOnQueryService(Self, rsid, iid, IUnknown(obj));
1608 if Pointer(Obj) <> nil then
1609 Result := S_OK
1610 else
1611 Result := E_NOINTERFACE;
1612end;
1613
1614{ICodeInstall Interface}
1615
1616function TBSCB.OnCodeInstallProblem(ulStatusCode: ULONG; szDestination,
1617 szSource: LPCWSTR; dwReserved: DWORD): HResult; stdcall;
1618{Returns a value based on the status passed in, which indicates
1619whether to abort the application installation or file download.
1620S_OK Indicates that the installation or download should continue.
1621E_ABORT Indicates that the installation or download should abort.}
1622begin
1623 dwReserved := 0;
1624 if Assigned(FSender.FOnCodeInstallProblem) then
1625 Result := FSender.FOnCodeInstallProblem(Self, ulStatusCode, szDestination,
1626 szSource, dwReserved, ResponseCodeToStr(ulStatusCode))
1627 else
1628 Result := S_OK;
1629end;
1630
1631{IUnknown Interface}
1632
1633function TBSCB.QueryInterface(const IID: TGUID; out Obj): HRESULT;
1634{S_OK if the interface is supported, E_NOINTERFACE if not.}
1635begin
1636 Self._AddRef;
1637 if Assigned(FSender.OnQueryInterface) then
1638 FSender.OnQueryInterface(IID, Obj);
1639 if GetInterface(IID, Obj) then
1640 Result := 0
1641 else
1642 Result := E_NOINTERFACE;
1643end;
1644
1645function TBSCB._AddRef: Integer;
1646{The IUnknown::AddRef method increments the reference count for
1647 an interface on an object.}
1648begin
1649 Result := InterlockedIncrement(FSender.FRefCount);
1650end;
1651
1652function TBSCB._Release: Integer;
1653{Decrements the reference count for the calling interface on a object. }
1654begin
1655 Result := InterlockedDecrement(FSender.FRefCount);
1656 if Result = 0 then
1657 Destroy;
1658end;
1659
1660{IWindowForBindingUI Interface}
1661
1662function TBSCB.GetWindow(const GUIDReason: TGUID; out hwnd): HRESULT;
1663{Returns S_OK if the window handle was successfully returned,
1664 or E_INVALIDARG if the phwnd parameter is invalid.
1665 If you implement this interface, you can return S_FALSE
1666 for this method to indicate that no window is available for
1667 to display user interface information.}
1668begin
1669 if Assigned(FSender.FGetWindow) then
1670 Result := FSender.FGetWindow(Self, GUIDReason, LongWord(hwnd))
1671 else
1672 Result := S_OK;
1673end;
1674
1675{IHttpSecurity}
1676
1677function TBSCB.OnSecurityProblem(dwProblem: DWORD): HResult;
1678{RPC_E_RETRY The calling application should continue or retry the download.
1679S_FALSE The calling application should open a dialog box to warn the user.
1680E_ABORT The calling application should abort the download.}
1681begin
1682 if Assigned(FSender.FOnSecurityProblem) then
1683 Result := FSender.FOnSecurityProblem(Self, dwProblem,
1684 ResponseCodeToStr(dwProblem))
1685 else
1686 Result := S_FALSE;
1687end;
1688
1689function TBSCB.GetSerializedClientCertContext(out ppbCert: Byte; var pcbCert: DWORD): HResult; stdcall;
1690begin
1691 if Assigned(FSender.FOnGetClientCert) then
1692 Result := FSender.FOnGetClientCert(Self, ppbCert, pcbCert)
1693 else
1694 Result := S_FALSE;
1695end;
1696{$IFDEF DELPHI6_UP}
1697
1698function TBSCB.AuthenticateEx(out phwnd: HWND; out pszUsername,
1699 pszPassword: LPWSTR; var pauthinfo: AUTHENTICATEINFO): HResult; stdcall;
1700var
1701 aUser, aPwd: WideString;
1702 tmpHWND: HWND;
1703begin
1704 Result := S_OK;
1705 phwnd := FSender.FHWnd;
1706 aUser := EmptyStr;
1707 aPwd := EmptyStr;
1708 if Assigned(FSender.FOnAuthenticateEx) then
1709 FSender.FOnAuthenticateEx(Self, tmpHWND, aUser, aPwd,
1710 pauthinfo, Result);
1711 if aUser <> EmptyStr then
1712 pszUserName := WidestringToLPOLESTR(aUser)
1713 else
1714 pszUserName := nil;
1715 if aPwd <> EmptyStr then
1716 pszPassWord := WidestringToLPOLESTR(aPwd)
1717 else
1718 pszPassWord := nil;
1719end;
1720
1721function TBSCB.PutProperty(mkp: MONIKERPROPERTY; val: LPCWSTR): HResult;
1722{This interface is implemented by persistent monikers,
1723 such as a MIME handler, to get properties about the moniker
1724 being handled.}
1725begin
1726 if Assigned(FSender.FOnPutProperty) then
1727 Result := FSender.FOnPutProperty(Self, mkp, val)
1728 else
1729 Result := E_NOTIMPL;
1730end;
1731{$ENDIF}
1732
1733function TBSCB.GetBindResult(out clsidProtocol: TCLSID; out dwResult: DWORD;
1734 out szResult: POLEStr): HRESULT;
1735{Gets the protocol-specific outcome of a bind operation.}
1736var
1737 dwReserved: DWORD;
1738begin
1739 dwReserved := 0;
1740 if (Binding <> nil) then
1741 Result := Binding.GetBindResult(clsidProtocol, dwResult, szResult,
1742 dwReserved)
1743 else
1744 Result := E_FAIL;
1745 if Assigned(FSender.FOnGetBindResults) then
1746 FSender.FOnGetBindResults(Self, clsidProtocol, dwResult,
1747 szResult, ResponseCodeToStr(dwResult));
1748 if (Result <> S_OK) and (Assigned(FSender.FOnError)) then
1749 FSender.FOnError(Result, ResponseCodeToStr(Result));
1750end;
1751
1752function TBSCB.CheckCancelState: Integer;
1753begin
1754 if (FSender.FCancel = True) then
1755 Result := E_ABORT
1756 else
1757 Result := S_OK;
1758end;
1759
1760procedure TBSCB.TimerExpired(Sender: TObject);
1761begin
1762 FTimedOut := True;
1763end;
1764
1765procedure TBSCB.ClearAll;
1766begin {Reset our resources}
1767 if Assigned(Binding) then
1768 Binding.Abort;
1769 FGlobalData := 0;
1770 FTotalRead := 0;
1771 if m_pPrevBSCB <> nil then
1772 m_pPrevBSCB := nil;
1773end;
1774
1775function TBSCB.QueryInfo(dwOption: DWORD; var Info: Cardinal): Boolean;
1776var
1777 HttpInfo: IWinInetHttpInfo;
1778 C: Cardinal;
1779 BufferLength: Cardinal;
1780 Reserved, dwFlags: Cardinal;
1781begin
1782 if (Assigned(Binding) and (Binding.QueryInterface(IWinInetHttpInfo, HttpInfo)
1783 = S_OK)) then
1784 begin
1785 Info := 0;
1786 Reserved := 0;
1787 dwFlags := 0;
1788 BufferLength := SizeOf(Cardinal);
1789 Result := not Boolean(HttpInfo.QueryInfo(dwOption or HTTP_QUERY_FLAG_NUMBER,
1790 @C, BufferLength, dwFlags, Reserved));
1791 HttpInfo := nil;
1792 if Result then
1793 Info := C;
1794 end
1795 else
1796 Result := False;
1797end;
1798
1799function TBSCB.QueryInfo(dwOption: DWORD; var Info: string): Boolean;
1800var
1801 Buf: array[0..INTERNET_MAX_PATH_LENGTH] of AnsiChar;
1802 HttpInfo: IWinInetHttpInfo;
1803 BufLength, dwReserved, dwFlags: Cardinal;
1804begin
1805 if (Assigned(Binding) and (Binding.QueryInterface(IWinInetHttpInfo, HttpInfo)
1806 = S_OK)) then
1807 begin
1808 Info := '';
1809 dwReserved := 0;
1810 dwFlags := 0;
1811 BufLength := INTERNET_MAX_PATH_LENGTH + 1;
1812 Result := not Boolean(HttpInfo.QueryInfo(dwOption, @Buf, BufLength, dwFlags,
1813 dwReserved));
1814 HttpInfo := nil;
1815 if Result then
1816 Info := string(Buf);
1817 end
1818 else
1819 Result := False;
1820end;
1821
1822function TBSCB.QueryInfo(dwOption: DWORD; var Info: TDateTime): Boolean;
1823var
1824 HttpInfo: IWinInetHttpInfo;
1825 SysTime: TSystemtime;
1826 BufferLength: Cardinal;
1827 Reserved, dwFlags: Cardinal;
1828begin
1829 if (Assigned(Binding) and (Binding.QueryInterface(IWinInetHttpInfo, HttpInfo)
1830 = S_OK)) then
1831 begin
1832 Info := 0;
1833 Reserved := 0;
1834 dwFlags := 0;
1835 BufferLength := SizeOf(TSystemTime);
1836 Result := not Boolean(HttpInfo.QueryInfo(dwOption or
1837 HTTP_QUERY_FLAG_SYSTEMTIME,
1838 @SysTime, BufferLength, dwFlags, Reserved));
1839 HttpInfo := nil;
1840 if Result then
1841 Info := SystemTimeToDateTime(SysTime);
1842 end
1843 else
1844 Result := False;
1845end;
1846
1847function TBSCB.DoSaveFileAs: string;
1848begin
1849 if FSender.FDownloadMethod = dmFile then
1850 begin
1851 with BscbInfo do
1852 begin
1853 if (infFileName = EmptyStr) then
1854 infFileName := FSender.SetFileNameFromUrl(infUrl);
1855 if (infFileName = EmptyStr) then
1856 infFileName := FSender.FDefaultUrlFileName;
1857 end;
1858 with FSender do
1859 begin
1860 FDownloadedFile := BscbInfo.infDownloadFolder + BscbInfo.infFileName;
1861 FFileExtension := ExtractFileExt(FSender.FDownloadedFile);
1862 BscbInfo.infFileExt := FFileExtension;
1863 FFileName := BscbInfo.infFileName;
1864 FDownloadFolder := BscbInfo.infDownloadFolder;
1865 end;
1866 Result := CharReplace(FSender.FDownloadedFile, '?', '_'); ;
1867 end;
1868end;
1869
1870function TBSCB.QueryInfoFileName: HRESULT;
1871const
1872 CD_FILE_PARAM = 'filename=';
1873var
1874 i: Integer;
1875 st, sTmp: string;
1876 res: Boolean;
1877begin
1878 Result := E_FAIL;
1879 sTmp := '';
1880 res := QueryInfo(HTTP_QUERY_CONTENT_DISPOSITION, sTmp);
1881 if not res then
1882 Exit;
1883 i := Pos(CD_FILE_PARAM, sTmp);
1884 if (i > 0) then
1885 begin
1886 sTmp := Copy(sTmp, i + Length(CD_FILE_PARAM), Length(sTmp) - i);
1887 if (sTmp[1] = '"') then
1888 i := Pos('";', sTmp)
1889 else
1890 i := Pos(';', sTmp);
1891 //TODO: what's happen, if the filename contains a quotion mark?
1892 if (i > 0) then
1893 sTmp := Copy(sTmp, 1, i);
1894 if (sTmp[1] = '"') then
1895 begin
1896 st := (Copy(sTmp, 2, Length(sTmp) - 2));
1897 BscbInfo.infFileName := Copy(sTmp, 2, Length(sTmp) - 2);
1898 end
1899 else
1900 BscbInfo.infFileName := sTmp;
1901 if (Length(sTmp) > 0) then
1902 Result := S_OK;
1903 end;
1904 FSender.FFileName := BscbInfo.infFileName; {Return Data}
1905end;
1906
1907function TBSCB.IsRunning: Boolean;
1908begin
1909 if (Succeeded(FMoniker.IsRunning(FBindCtx, FMoniker, nil))) then
1910 Result := True
1911 else
1912 Result := False;
1913end;
1914
1915function TBSCB.GetDisplayName: PWideChar;
1916begin {Expensive operation so I'll do it only once.
1917 For extra info use MkParseDisplayName }
1918 if IsRunning then
1919 FMoniker.GetDisplayName(FBindCtx, nil, Result);
1920end;
1921
1922function TBSCB.MkParseDisplayName(var DisplayName: PWideChar): IMoniker;
1923var
1924 i: cardinal;
1925begin
1926 UrlMon.MkParseDisplayNameEx(FBindCtx, DisplayName, i, Result);
1927end;
1928
1929function TBSCB.CreateMoniker(szName: POLEStr; BC: IBindCtx; out mk: IMoniker;
1930 dwReserved: DWORD): HResult;
1931begin
1932 szName := StringToOleStr(BscbInfo.infUrl);
1933 Result := CreateURLMonikerEx(nil, szName, FMoniker, URL_MK_UNIFORM {URL_MK_LEGACY});
1934end;
1935
1936function TBSCB.MonikerBindToStorage(Mk: IMoniker; BC: IBindCtx; BSC:
1937 IBindStatusCallback;
1938 const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult;
1939begin
1940 Mk := FMoniker;
1941 BC := FBindCtx;
1942 BSC := Self;
1943 Result := Mk.BindToStorage(BC, nil, IStream, fOutStream);
1944end;
1945
1946function TBSCB.MonikerBindToObject(Mk: IMoniker; BC: IBindCtx; BSC:
1947 IBindStatusCallback;
1948 const iid: TGUID; out pvObj{$IFNDEF DELPHI8_UP}: Pointer{$ENDIF}): HResult;
1949begin
1950 Mk := FMoniker;
1951 BC := FBindCtx;
1952 BSC := Self;
1953 Result := Mk.BindToObject(BC, nil, IStream, fOutStream);
1954end;
1955
1956function TBSCB.AbortBinding: HRESULT;
1957begin
1958 Result := E_Fail;
1959 if Assigned(Binding) then
1960 Result := Binding.Abort;
1961end;
1962
1963destructor TBSCB.Destroy;
1964begin {Cleaning out and free our resources}
1965 ClearAll;
1966 if Assigned(Stream) then
1967 FreeAndNil(Stream);
1968 if Assigned(FBSCBTimer) then
1969 FreeAndNil(FBSCBTimer);
1970 if Assigned(fsOutputFile) then
1971 FreeAndNil(fsOutputFile);
1972 if (FGlobalData <> 0) then
1973 GlobalFree(FGlobalData);
1974 inherited;
1975end;
1976
1977constructor TBSCB.Create(aSender: TCustomIEDownload; const pmk: IMoniker;
1978 const pbc: IBindCtx; CreateSuspended: boolean);
1979var
1980 tmp: PWideChar;
1981begin
1982 inherited Create(CreateSuspended);
1983 FreeOnTerminate := False;
1984 if CreateSuspended then
1985 ThreadStatus := tsSuspended
1986 else
1987 ThreadStatus := tsWaiting;
1988 Stream := TMemoryStream.Create; {A stream to contain the download}
1989 FSender := aSender;
1990 FMoniker := pmk;
1991 FBindCtx := pbc;
1992 if FSender.FDownloadTo = dtMoniker then
1993 begin
1994 FSender.FBindF := FSender.FBindF + [GetNewestVersion];
1995 FSender.DoUpdate;
1996 FMoniker.GetDisplayName(FBindCtx, nil, tmp);
1997 FSender.FUrl := tmp;
1998 FSender.ItemsManager.SessionList.Add(tmp);
1999 end;
2000end;
2001
2002procedure TBSCB.SetComponents;
2003begin {Initial all internals before the process}
2004 QueryPerformanceFrequency(Frequency);
2005 QueryPerformanceCounter(TimeStarted);
2006 ClearAll; {Clearing Internals}
2007 FBSCBTimer := TTimer.Create(nil); {Creating Timer for a TimeOut option}
2008 FBSCBTimer.OnTimer := TimerExpired;
2009 FBSCBTimer.Interval := BscbInfo.infTimeOut;
2010 FTimedOut := False;
2011 LongTimeFormat := Frmt_Time;
2012 if not FSender.IsSynchronous(BscbInfo) then {We are on Asynchronous mode}
2013 begin
2014 FSender.ItemsManager.Add(Self); {Adding asynchronous items}
2015 Inc(BscbInfo.infIndex); {Pass the index}
2016 Inc(FSender.FdlCounter);
2017 end;
2018end;
2019
2020procedure TBSCB.Resume;
2021begin
2022 inherited;
2023 ThreadStatus := tsRunning;
2024end;
2025
2026procedure TBSCB.Suspend;
2027begin
2028 inherited;
2029 ThreadStatus := tsSuspended;
2030end;
2031
2032procedure TBSCB.Terminate;
2033var
2034 bCanc: Boolean;
2035begin
2036 if FSender.ActiveConnections = 0 then
2037 FSender.FBusy := False;
2038 ThreadStatus := tsTerminated;
2039 bCanc := False;
2040 if Assigned(FSender.FOnTerminate) then
2041 FSender.FOnTerminate(Self, ThreadID, BscbInfo.infFileName, bCanc);
2042 if bCanc then
2043 FSender.CancelAll;
2044 inherited;
2045end;
2046
2047procedure TBSCB.Execute;
2048begin
2049 if Terminated then
2050 Exit;
2051 try
2052 {Dont be in shock, as a tread it sometimes fail so we should succeed now}
2053 OleInitialize(nil);
2054 except
2055 end;
2056 ThreadStatus := tsRunning;
2057 Synchronize(ReceiveData);
2058 Synchronize(SetComponents);
2059 case FSender.FDownloadTo of
2060 dtNormal:
2061 begin
2062 Synchronize(DoConnect);
2063 Synchronize(ReturnData);
2064 end;
2065 dtMoniker:
2066 begin
2067 Synchronize(DoConnect);
2068 Synchronize(ReturnData);
2069 end;
2070 dtDownloadToCache: Synchronize(DoDownloadToCache);
2071 dtDownloadToFile: Synchronize(DoDownloadToFile);
2072 end;
2073 try
2074 if (Assigned(BscbInfo)) then
2075 finally
2076 BscbInfo.Clear;
2077 FreeAndNil(BscbInfo);
2078 end;
2079 OleUninitialize;
2080end;
2081
2082procedure TBSCB.ReceiveData;
2083begin
2084 BscbInfo := TInfoData.Create;
2085 GetData(FSender); {Pass Data to the TObject}
2086 FSender := TCustomIEDownload(BscbInfo.Sender);
2087end;
2088
2089procedure TBSCB.ReturnData;
2090begin
2091 with FSender do
2092 begin
2093 FDownloadedFile := BscbInfo.infDownloadFolder + BscbInfo.infFileName;
2094 FFileExtension := ExtractFileExt(FSender.FDownloadedFile);
2095 BscbInfo.infFileExt := FFileExtension;
2096 FFileName := BscbInfo.infFileName;
2097 FDownloadFolder := BscbInfo.infDownloadFolder;
2098 end;
2099end;
2100
2101procedure TBSCB.DoDownloadToCache;
2102var
2103 Buf: array[0..INTERNET_MAX_PATH_LENGTH] of char;
2104begin
2105 if Succeeded(UrlMon.URLDownloadToCacheFile(nil, Pchar(BscbInfo.infUrl),
2106 Buf, SizeOf(Buf), 0, Self)) then
2107 FSender.ExtractDataFromFile(Buf);
2108 FSender.ItemsManager.Extract(Self);
2109end;
2110
2111procedure TBSCB.DoDownloadToFile;
2112var
2113 HR: integer;
2114 tmp: string;
2115begin
2116 tmp:= BscbInfo.infDownloadFolder + BscbInfo.infFileName;
2117 HR := UrlMon.URLDownloadToFile(nil, Pchar(BscbInfo.infUrl),
2118 PChar(tmp), 0, Self);
2119 if Failed(HR) and Assigned(FSender.FOnError) then
2120 FSender.FOnError(GetLastError, Err_ToFile + SysErrorMessage(GetLastError))
2121 else if (Assigned(FSender.FOnConnect)) then
2122 FSender.FOnConnect(Self, HR, DL_ToFile + ResponseCodeToStr(HR));
2123 FSender.ExtractDataFromFile(tmp);
2124 FSender.ItemsManager.Extract(Self);
2125end;
2126
2127procedure TBSCB.DoConnect;
2128var
2129 Ut: TUrl;
2130 HR: HRESULT;
2131 pPrevBSCB, tmpBSC: IBindStatusCallback;
2132begin
2133 FSender.bDone := False;
2134 FSender.hStop := 0;
2135 if FSender.FDownloadTo <> dtMoniker then
2136 begin
2137 HR := CreateURLMonikerEx(nil, BscbInfo.infUrl, FMoniker, URL_MK_UNIFORM {URL_MK_LEGACY});
2138 if Failed(HR) and Assigned(FSender.FOnError) then
2139 begin
2140 FSender.FOnError(GetLastError, Err_URLMEx +
2141 ResponseCodeToStr(HR));
2142 Exit;
2143 end
2144 else if (Assigned(FSender.FOnConnect)) then
2145 FSender.FOnConnect(Self, HR, CreateURLMEx + ResponseCodeToStr(HR));
2146
2147 HR := CreateAsyncBindCtx(0, Self, nil, FBindCtx);
2148 if Failed(HR) and Assigned(FSender.FOnError) then
2149 begin
2150 FSender.FOnError(GetLastError, Err_AsyncBindCtx +
2151 ResponseCodeToStr(HR));
2152 Exit;
2153 end
2154 else if (Assigned(FSender.FOnConnect)) then
2155 FSender.FOnConnect(Self, HR, CreateABindCtx + ResponseCodeToStr(HR));
2156 end;
2157
2158 FSender.FDisplayName := GetDisplayName;
2159 begin
2160 if FSender.FDisplayName <> EmptyStr then
2161 begin
2162 BscbInfo.infUrl := FSender.FDisplayName;
2163 FSender.FUrl := FSender.FDisplayName;
2164 end;
2165 Ut := TUrl.Create(BscbInfo.infUrl);
2166 try
2167 Ut.QueryUrl(BscbInfo.infUrl);
2168 BscbInfo.infFileName := Ut.Document;
2169 BscbInfo.infHost := Ut.HostName;
2170 finally
2171 Ut.Free;
2172 end;
2173 end;
2174
2175 HR := RegisterBindStatusCallback(FBindCtx, Self, pPrevBSCB, 0);
2176 if Failed(HR) and Assigned(pPrevBSCB) then
2177 begin
2178 HR := FBindCtx.RevokeObjectParam('_BSCB_Holder_');
2179 if (Succeeded(HR)) then
2180 begin {Attempt register again, should succeed now}
2181 HR := RegisterBindStatusCallback(FBindCtx, Self, tmpBSC, 0);
2182 if (SUCCEEDED(HR)) then
2183 begin //Need to pass a pointer for BindCtx and previous BSCB to our implementation
2184 m_pPrevBSCB := pPrevBSCB;
2185 Self._AddRef;
2186 m_pPrevBSCB._AddRef;
2187 FBindCtx._AddRef;
2188 if (Assigned(FSender.FOnConnect)) then
2189 FSender.FOnConnect(Self, HR, Reg_BSCB + ResponseCodeToStr(HR));
2190 end
2191 else if Assigned(FSender.FOnError) then
2192 FSender.FOnError(GetLastError, Err_RegBSCB
2193 + ResponseCodeToStr(HR));
2194 end;
2195 end
2196 else if (Assigned(FSender.FOnConnect)) then
2197 FSender.FOnConnect(Self, HR, Reg_BSCB +
2198 ResponseCodeToStr(HR));
2199 FSender.hStop := CreateEvent(nil, True, False, nil);
2200 HR := FMoniker.BindToStorage(FBindCtx, nil, IStream, fOutStream);
2201 if Failed(HR) and Assigned(FSender.FOnError) then
2202 begin
2203 FSender.FOnError(GetLastError, Err_BindToSt +
2204 ResponseCodeToStr(HR));
2205 Exit;
2206 end
2207 else if (Assigned(FSender.FOnConnect)) then
2208 FSender.FOnConnect(Self, HR, Bind_To_St + ResponseCodeToStr(HR));
2209 repeat
2210 try
2211 if FSender.WaitForProcess(FSender.hStop, FSender.FStartTick,
2212 FSender.FTimeOut) then
2213 except
2214 if Assigned(FSender.FOnError) then
2215 FSender.FOnError(E_FAIL, Err_Proc_Ev);
2216 raise;
2217 end;
2218 until (FSender.FCancel) or (FSender.bDone)
2219 {and (stream = nil)}{or (BscbInfo.infIndex = 0)};
2220 HR := RevokeBindStatusCallback(FBindCtx, pPrevBSCB);
2221 if Failed(HR) then
2222 HR := RevokeBindStatusCallback(FBindCtx, tmpBSC);
2223 if Failed(HR) and Assigned(FSender.FOnError) then
2224 FSender.FOnError(HR, Err_Revoke + ResponseCodeToStr(HR))
2225 else if (Assigned(FSender.FOnConnect)) then
2226 FSender.FOnConnect(Self, HR, Revoke_BSCB + ResponseCodeToStr(S_OK));
2227
2228 if FSender.FActiveConnections = 0 then
2229 FSender.FBusy := False;
2230 if not FSender.IsSynchronous(BscbInfo) then {We are on asynchronous mode}
2231 begin
2232 FSender.ItemsManager.Extract(Self);
2233 {Remove the item from our list because we finished}
2234 Dec(BscbInfo.infIndex); {Pass the new index}
2235 end;
2236end;
2237
2238procedure TBSCB.GetData(aSender: TCustomIEDownload);
2239begin {Get data from IEDownload to the iedInfo}
2240 with BscbInfo do
2241 begin
2242 infAdditionalHeader.AddStrings(aSender.FAdditionalHeader);
2243 infBindF_Value := aSender.FBindF_Value;
2244 infBindF2_Value := aSender.FBindF2_Value;
2245 infBindInfoF_Value := aSender.FBindInfoF_Value;
2246 infBindVerb_Value := aSender.FBindVerb_Value;
2247 infBindInfoOptions_Value := aSender.FBindVerb_Value;
2248 infCodePage_Value := aSender.FCodePageValue;
2249 infCustomVerb := aSender.FCustomVerb;
2250 infDescriptor := aSender.Security.FDescriptor;
2251 infDownloadFolder := aSender.FDownloadFolder;
2252 infExtraInfo := aSender.FExtraInfo;
2253 infFileName := aSender.FFileName;
2254 inFFileSize := 0;
2255 infInheritHandle := aSender.Security.FInheritHandle;
2256 infPassword := aSender.FPassword;
2257 infPostData := aSender.FPostData;
2258 infPutFileName := aSender.FPutFileName;
2259 infRangeBegin := aSender.Range.FRangeBegin;
2260 infRangeEnd := aSender.Range.FRangeEnd;
2261 infTimeOut := aSender.FTimeOut;
2262 infUrl := StringToOleStr(aSender.FUrl);
2263 infUserName := aSender.FUserName;
2264 Sender := aSender;
2265 end;
2266end;
2267
2268{Enf of Callback procedure------------------------------------------------------}
2269
2270{BSCBList----------------------------------------------------------------------}
2271
2272function TBSCBList.byURL(Url: string): TBSCB; //by Jury Gerasimov
2273var
2274 i: integer;
2275begin
2276 Result := nil;
2277 for i := 0 to Count - 1 do
2278 if Items[i].BscbInfo.infUrl = Url then
2279 begin
2280 Result := Items[i];
2281 Break;
2282 end;
2283end;
2284
2285function TBSCBList.GetItem(Index: Integer): TBSCB;
2286begin
2287 Result := TBSCB(inherited GetItem(Index));
2288end;
2289
2290procedure TBSCBList.SetItem(Index: Integer; Value: TBSCB);
2291begin
2292 inherited SetItem(Index, Value);
2293end;
2294
2295constructor TBSCBList.Create;
2296begin
2297 inherited Create;
2298 SessionList := TStringList.Create;
2299end;
2300
2301destructor TBSCBList.Destroy;
2302begin
2303 FreeAndNil(SessionList);
2304 inherited Destroy;
2305end;
2306
2307{End of BSCBList---------------------------------------------------------------}
2308
2309{IEDownload--------------------------------------------------------------------}
2310
2311constructor TCustomIEDownload.Create(AOwner: TComponent);
2312begin
2313 inherited;
2314 TimeSeparator := '_'; {For the feRename}
2315 FAbout := IED_INFO;
2316 hProcess := 0;
2317 bDone := False;
2318 bCancelAll := False;
2319 FAdditionalHeader := TStringlist.Create;
2320 FAdditionalHeader.Add('Content-Type: application/x-www-form-urlencoded ');
2321 FBindF := [Asynchronous, AsyncStorage, PullData, NoWriteCache,
2322 GetNewestVersion];
2323 FBindF2 := [ReadDataOver4GB];
2324 FBindVerb := Get;
2325 FCodePageOption := Ansi;
2326 FBindInfoOption_ := [UseBindInfoOptions, AllowConnectMessages];
2327 FDefaultProtocol := 'http://';
2328 FDefaultUrlFileName := 'index.html';
2329 FdlCounter := 0;
2330 FActiveConnections := 0;
2331 FDownloadMethod := dmFile;
2332 FProxySettings := TProxySettings.Create;
2333 FProxySettings.FPort := 80;
2334 FRange := TRange.Create;
2335 FRefCount := 0;
2336 FSecurity := TSecurity.Create;
2337 FState := sReady;
2338 FBindInfoF := [];
2339 ItemsManager := TBSCBList.Create;
2340 SetUserAgent;
2341end;
2342
2343procedure TCustomIEDownload.Loaded;
2344begin
2345 inherited Loaded;
2346 if FTimeOut = 0 then
2347 FTimeOut := MaxInt;
2348 if (FProxySettings.FAutoLoadProxy) and (FProxySettings.FServer <> EmptyStr)
2349 then
2350 FProxySettings.SetProxy(FFullUserAgent, FProxySettings.FServer + ':' +
2351 IntToStr(FProxySettings.FPort));
2352end;
2353
2354procedure TCustomIEDownload.Resume;
2355begin
2356 if BS <> nil then
2357 BS.Resume;
2358end;
2359
2360procedure TCustomIEDownload.Suspend;
2361begin
2362 if BS <> nil then
2363 BS.Suspend;
2364end;
2365
2366destructor TCustomIEDownload.Destroy;
2367begin
2368 FTimeOut := 0;
2369 FRange.Free;
2370 FSecurity.Free;
2371 FProxySettings.Free;
2372 ItemsManager.Free;
2373 if Assigned(FAdditionalHeader) then
2374 FreeAndNil(FAdditionalHeader);
2375 inherited;
2376end;
2377
2378procedure TCustomIEDownload.BeforeDestruction;
2379begin
2380 if FProxySettings.FAutoLoadProxy then
2381 FProxySettings.SetProxy(EmptyStr, EmptyStr); {To restore proxy settings}
2382 inherited BeforeDestruction;
2383end;
2384
2385procedure TCustomIEDownload.Cancel;
2386begin
2387 if (not FBusy) or (FState <> sBusy) then Exit;
2388 FCancel := True;
2389 Application.ProcessMessages;
2390end;
2391
2392procedure TCustomIEDownload.Reset;
2393begin
2394 if (FState = sBusy) then Exit;
2395 FCancel := False;
2396 bCancelAll := False;
2397 Application.ProcessMessages;
2398end;
2399
2400procedure TCustomIEDownload.CancelAll;
2401begin
2402 if (not FBusy) or (FState <> sBusy) then Exit;
2403 bCancelAll := True;
2404 FCancel := True;
2405 Application.ProcessMessages;
2406end;
2407
2408procedure TCustomIEDownload.Cancel(const Item: TBSCB);
2409begin
2410 Item.CheckCancelState;
2411 FCancel := True;
2412end;
2413
2414procedure TCustomIEDownload.Update_BindInfoF_Value;
2415const
2416 Acard_BindInfoF_Values: array[TBindInfoF] of Cardinal = (
2417 $00000001, $00000002);
2418var
2419 i: TBindInfoF;
2420begin
2421 FBindInfoF_Value := 0;
2422 if (FBindInfoF <> []) then
2423 for i := Low(TBindInfoF) to High(TBindInfoF) do
2424 if (i in FBindInfoF) then
2425 Inc(FBindInfoF_Value, Acard_BindInfoF_Values[i]);
2426end;
2427
2428procedure TCustomIEDownload.Update_BindF_Value;
2429const
2430 Acard_BindF_Values: array[TBindF] of Cardinal = (
2431 $00000001, $00000002, $00000004, $00000008, $00000010, $00000020,
2432 $00000040, $00000080, $00000100, $00000200, $00000400, $00000800,
2433 $00001000, $00002000, $00004000, $00008000, $00010000, $00020000,
2434 $00040000, $00080000, $00100000, $00200000, $00400000, $00800000);
2435var
2436 i: TBindF;
2437begin
2438 FBindF_Value := 0;
2439 if (FBindF <> []) then
2440 for i := Low(TBindF) to High(TBindF) do
2441 if (i in FBindF) then
2442 Inc(FBindF_Value, Acard_BindF_Values[i]);
2443end;
2444
2445procedure TCustomIEDownload.Update_BindInfoOptions_Value;
2446const
2447 AcardBindInfoOption_Values: array[TBindInfoOption] of Cardinal = (
2448 $00010000, $00020000, $00040000, $00080000, $00100000, $00200000,
2449 $00400000, $00800000, $01000000, $02000000, $08000000, $10000000,
2450 $40000000, $80000000, $20000000);
2451var
2452 i: TBindInfoOption;
2453begin
2454 FBindInfoOption_Value := 0;
2455 if (FBindInfoOption_ <> []) then
2456 for i := Low(TBindInfoOption) to High(TBindInfoOption) do
2457 if (i in FBindInfoOption_) then
2458 Inc(FBindInfoOption_Value, AcardBindInfoOption_Values[i]);
2459end;
2460
2461
2462procedure TCustomIEDownload.Update_BindF2_Value;
2463const
2464 AcardBindF2_Values: array[TBindF2] of Cardinal = ($00000001,
2465 $00000002, $00000004, $00000008, $40000000, $80000000);
2466var
2467 i: TBindF2;
2468begin
2469 FBindF2_Value := 0;
2470 if (FBindF2 <> []) then
2471 for i := Low(TBindF2) to High(TBindF2) do
2472 if (i in FBindF2) then
2473 Inc(FBindF2_Value, AcardBindF2_Values[i]);
2474end;
2475
2476function TCustomIEDownload.OpenFolder(const aFolderName: string): Boolean;
2477var
2478 Int: integer;
2479begin
2480 Result := False;
2481 if (FDownloadMethod = dmFile) then
2482 begin
2483 Int := ShellExecute(Forms.Application.Handle, PChar('explore'),
2484 PChar(aFolderName), nil, nil, SW_SHOWNORMAL);
2485 Result := (Int > 32);
2486 if not Result and Assigned(FOnError) then
2487 FOnError(Int, Err_Folder);
2488 end;
2489end;
2490
2491procedure TCustomIEDownload.DoUpdate;
2492begin
2493 Update_BindF_Value;
2494 Update_BindF2_Value;
2495 Update_BindInfoF_Value;
2496 Update_BindInfoOptions_Value;
2497end;
2498
2499function TCustomIEDownload.CodeInstallProblemToStr(const ulStatusCode: Integer):
2500 string;
2501begin
2502 Result := IEDownloadTools.CodeInstallProblemToStr(ulStatusCode);
2503end;
2504
2505function TCustomIEDownload.CheckFileExists(const aFileName: string): boolean;
2506begin
2507 Result := FileExists(aFileName);
2508end;
2509
2510procedure TCustomIEDownload.Go(const aUrl: string);
2511begin
2512 GoAction(aUrl, EmptyStr, EmptyStr, nil, nil);
2513 if FOpenDownloadFolder then
2514 OpenFolder(FDownloadFolder);
2515end;
2516
2517procedure TCustomIEDownload.Go(const aUrl: string; const aFileName: string);
2518begin
2519 GoAction(aUrl, aFileName, EmptyStr, nil, nil);
2520 if FOpenDownloadFolder then
2521 OpenFolder(FDownloadFolder);
2522end;
2523
2524procedure TCustomIEDownload.Go(const aUrl: string; const aFileName: string;
2525 const aDownloadFolder: string);
2526begin
2527 GoAction(aUrl, aFileName, aDownloadFolder, nil, nil);
2528 if FOpenDownloadFolder then
2529 OpenFolder(FDownloadFolder);
2530end;
2531
2532procedure TCustomIEDownload.GoList(const UrlsList: TStrings);
2533var
2534 Idx: integer;
2535begin
2536 for Idx := 0 to UrlsList.Count - 1 do
2537 if (UrlsList[Idx] <> EmptyStr) and (not bCancelAll) then
2538 GoAction(UrlsList[Idx], EmptyStr, EmptyStr, nil, nil);
2539 if FOpenDownloadFolder then
2540 OpenFolder(FDownloadFolder);
2541end;
2542
2543procedure TCustomIEDownload.GoList(const UrlsList: TStrings; const FileNameList:
2544 TStrings);
2545var
2546 Idx: integer;
2547begin
2548 for Idx := 0 to UrlsList.Count - 1 do
2549 if (UrlsList[Idx] <> EmptyStr) and (not bCancelAll) then
2550 GoAction(UrlsList[Idx], FileNameList[Idx], EmptyStr, nil, nil);
2551 if FOpenDownloadFolder then
2552 OpenFolder(FDownloadFolder);
2553end;
2554
2555procedure TCustomIEDownload.GoList(const UrlsList: TStrings; const FileNameList:
2556 TStrings;
2557 const DownloadFolderList: TStrings);
2558var
2559 Idx: integer;
2560begin
2561 for Idx := 0 to UrlsList.Count - 1 do
2562 if (UrlsList[Idx] <> EmptyStr) and (not bCancelAll) then
2563 GoAction(UrlsList[Idx], FileNameList[Idx], DownloadFolderList[Idx], nil,
2564 nil);
2565 if FOpenDownloadFolder then
2566 OpenFolder(FDownloadFolder);
2567end;
2568
2569procedure TCustomIEDownload.Download(const pmk: IMoniker; const pbc: IBindCtx);
2570begin
2571 FDownloadTo := dtMoniker;
2572 PrepareForStart;
2573 hProcess := CreateEvent(nil, True, False, nil);
2574 if (not GoInit('', FFileName, FDownloadFolder)) then
2575 begin
2576 PrepareForExit;
2577 Exit;
2578 end;
2579 BS := TBSCB.Create(Self, pmk, pbc, True);
2580 try
2581 BS.Execute;
2582 repeat
2583 try
2584 if WaitForProcess(hProcess, FStartTick, FTimeOut) then
2585 except
2586 if Assigned(FOnError) then
2587 FOnError(E_FAIL, Err_Proc_Ev);
2588 raise;
2589 end;
2590 until (FCancel) or (FActiveConnections = 0);
2591 finally
2592 FreeAndNil(BS);
2593 end;
2594 PrepareForExit;
2595end;
2596
2597function TCustomIEDownload.GoAction(const actUrl, actFileName, actDownloadFolder: string;
2598 pmk: IMoniker; pbc: IBindCtx): boolean;
2599begin
2600 Result := False;
2601 PrepareForStart;
2602 hProcess := CreateEvent(nil, True, False, nil);
2603 if (not GoInit(actUrl, actFileName, actDownloadFolder)) then
2604 begin
2605 PrepareForExit;
2606 Exit;
2607 end;
2608 BS := TBSCB.Create(Self, pmk, pbc, True); {Creating Download Callback}
2609 try //Fix Deadlock?
2610 BS.Execute;
2611 repeat
2612 try
2613 if WaitForProcess(hProcess, FStartTick, FTimeOut) then
2614 except
2615 if Assigned(FOnError) then
2616 FOnError(E_FAIL, Err_Proc_Ev);
2617 raise;
2618 end;
2619 until (FCancel) or (FActiveConnections = 0);
2620 finally
2621 FreeAndNil(BS);
2622 end;
2623 PrepareForExit;
2624 Result := True;
2625end;
2626
2627function TCustomIEDownload.URLDownloadToCacheFile(const aUrl: string): string;
2628begin
2629 Result := EmptyStr;
2630 PrepareForStart;
2631 if not GoInit(aUrl, '', '') then
2632 Exit;
2633 FDownloadTo := dtDownloadToCache;
2634 BS := TBSCB.Create(Self, nil, nil, True);
2635 try
2636 BS.Execute;
2637 BS.Terminate;
2638 Dec(FActiveConnections);
2639 finally
2640 FreeAndNil(BS);
2641 end;
2642 SetBeforeExit;
2643 PrepareForExit;
2644 Result := FDownloadFolder;
2645end;
2646
2647function TCustomIEDownload.UrlDownloadToFile(const aUrl: string): HRESULT;
2648begin
2649 Result := E_FAIL;
2650 PrepareForStart;
2651 if not GoInit(aUrl, '', '') then
2652 Exit;
2653 FDownloadTo := dtDownloadToFile;
2654 BS := TBSCB.Create(Self, nil, nil, True);
2655 try
2656 BS.Execute;
2657 BS.Terminate;
2658 Dec(FActiveConnections);
2659 finally
2660 FreeAndNil(BS);
2661 end;
2662 SetBeforeExit;
2663 PrepareForExit;
2664 Result := S_OK;
2665end;
2666
2667procedure TCustomIEDownload.SetBeforeExit;
2668begin
2669 if FOpenDownloadFolder then
2670 OpenFolder(FDownloadFolder);
2671 if FActiveConnections = 0 then
2672 FBusy := False;
2673 FState := sStopped;
2674 if Assigned(FOnStateChange) then
2675 FOnStateChange(FState);
2676end;
2677
2678function TCustomIEDownload.GoInit(const inUrl: string; const inFileName:
2679 string; const inDownloadFolder: string): boolean;
2680var
2681 tmpNewName: WideString;
2682 Act: TFileExistsOption;
2683begin
2684 act := FFileExistsOption;
2685 tmpNewName := '';
2686 Result := False;
2687 if FDownloadTo <> dtMoniker then
2688 begin
2689 if inUrl = EmptyStr then
2690 begin
2691 PrepareForExit;
2692 Exit;
2693 end;
2694 FUrl := SetHttpProtocol(inUrl); {We pass the Address we got to the component}
2695 if (FValidateUrl) and not (IsUrlValid(FUrl)) then
2696 begin
2697 PrepareForExit;
2698 Exit;
2699 end;
2700 ItemsManager.SessionList.Add(FUrl);
2701 if FDownloadMethod = dmFile then
2702 begin
2703 FDownloadFolder := SetDownloadFolder(inDownloadFolder);
2704 if FDownloadFolder = EmptyStr then Exit;
2705 FFileName := inFileName;
2706 if (FFileName = EmptyStr) then
2707 FFileName := SetFileNameFromUrl(FUrl); {First try}
2708 if (CheckFileExists(FDownloadFolder + FFileName)) then
2709 begin
2710 if Assigned(FOnFileExists) then
2711 FOnFileExists(Act, FDownloadFolder + FFileName, tmpNewName);
2712 case Act of
2713 feSkip:
2714 begin
2715 PrepareForExit;
2716 Exit;
2717 end;
2718 feRename:
2719 begin
2720 if tmpNewName = EmptyStr then
2721 tmpNewName := TimeToStr(now) + '_' + FFileName;
2722 FFileName := tmpNewName;
2723 bRenamed := True;
2724 end;
2725 feOverwrite: FBindF := FBindF + [GetNewestVersion];
2726 end;
2727 end;
2728 end
2729 else
2730 FBindF := FBindF + [GetNewestVersion];
2731 end;
2732 DoUpdate;
2733 Result := True;
2734end;
2735
2736function TCustomIEDownload.WaitForProcess(var EventName: THandle;
2737 var aStartTick, aTimeOut: Integer): Boolean;
2738var
2739 dwResult: DWORD;
2740 Msg: TMsg;
2741 EventList: array[0..0] of THandle;
2742begin
2743 EventList[0] := EventName;
2744 dwResult := MsgWaitForMultipleObjects(1, EventList, False, DWORD(ATimeOut),
2745 QS_ALLEVENTS);
2746
2747 case dwResult of
2748 WAIT_FAILED: {Waiting failed}
2749 begin
2750 if Assigned(FOnError) then
2751 FOnError(GetLastError, SysErrorMessage(GetLastError));
2752 end;
2753 WAIT_TIMEOUT: {Waiting Timo out}
2754 begin
2755 if Assigned(FOnError) then
2756 FOnError(GetLastError, SysErrorMessage(GetLastError));
2757 end;
2758 WAIT_BSCB: {Our state to process messages}
2759 begin
2760 while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
2761 begin
2762 TranslateMessage(Msg);
2763 DispatchMessage(Msg);
2764 if (Integer(GetTickCount) - aStartTick > aTimeOut) then
2765 begin
2766 if Assigned(FOnError) then
2767 FOnError(GetLastError, Err_TimeOut);
2768 end;
2769 end;
2770 if (Integer(GetTickCount) - aStartTick > aTimeOut) then
2771 begin
2772 if Assigned(FOnError) then
2773 FOnError(GetLastError, Err_TimeOut);
2774 end;
2775 end;
2776 end;
2777 Result := (dwResult = WAIT_OBJECT_0); {We are done waiting}
2778end;
2779
2780function TCustomIEDownload.IsSynchronous(iedInfo: TInfoData): boolean;
2781begin {Return True if mode is Synchronous}
2782 if iedInfo.infBindF_Value <> (iedInfo.infBindF_Value or
2783 BINDF_ASYNCHRONOUS) then
2784 Result := True
2785 else
2786 Result := False;
2787end;
2788
2789function TCustomIEDownload.IsAsyncMoniker(const pmk: IMoniker): HRESULT;
2790begin
2791 Result := UrlMon.IsAsyncMoniker(pmk);
2792end;
2793
2794function TCustomIEDownload.FormatSize(const Byte: Double): string;
2795begin
2796 Result := IEDownloadTools.FormatSize(Byte);
2797end;
2798
2799function TCustomIEDownload.FormatTickToTime(const TickCount: Cardinal): string;
2800begin
2801 Result := IEDownloadTools.FormatTickToTime(TickCount);
2802end;
2803
2804function TCustomIEDownload.IsUrlValid(const isUrl: string): Boolean;
2805var
2806 U: TUrl;
2807begin
2808 U := TUrl.Create(isUrl);
2809 try
2810 Result := U.IsUrlValid(isUrl);
2811 if not Result and Assigned(FOnError) then
2812 FOnError(GetLastError, SysErrorMessage(GetLastError) + isUrl);
2813 finally
2814 U.Free;
2815 end;
2816end;
2817
2818procedure TCustomIEDownload.PrepareForExit;
2819begin
2820 if Assigned(FOnComplete) then
2821 FOnComplete(Self, FDownloadedFile, FFileName, FDownloadFolder,
2822 FFileExtension, ActiveConnections);
2823 FState := sReady;
2824 if Assigned(FOnStateChange) then
2825 FOnStateChange(FState);
2826end;
2827
2828procedure TCustomIEDownload.PrepareForStart;
2829begin
2830 FBusy := True;
2831 bRenamed := False;
2832 FCancel := False;
2833 FDownloadedFile := EmptyStr;
2834 FDownloadFolder := EmptyStr;
2835 FFileExtension := EmptyStr;
2836 FFileName := EmptyStr;
2837 FFileSize := 0;
2838 FMimeType := EmptyStr;
2839 FServerAddress := EmptyStr;
2840 FServerIP := EmptyStr;
2841 FUrl := EmptyStr;
2842 FState := sBusy;
2843 if Assigned(FOnStateChange) then
2844 FOnStateChange(FState);
2845 FStartTick := GetTickCount;
2846 Inc(FRefCount);
2847 Inc(FActiveConnections);
2848end;
2849
2850procedure TCustomIEDownload.SetCodePage(const Value: TCodePageOption);
2851begin
2852 FCodePageOption := Value;
2853 case FCodePageOption of
2854 Ansi: FCodePageValue := CP_ACP;
2855 Mac: FCodePageValue := CP_MACCP;
2856 OEM: FCodePageValue := CP_OEMCP;
2857 Symbol: FCodePageValue := CP_SYMBOL;
2858 ThreadsAnsi: FCodePageValue := CP_THREAD_ACP;
2859 UTF7: FCodePageValue := CP_UTF7;
2860 UTF8: FCodePageValue := CP_UTF8;
2861 end;
2862end;
2863
2864procedure TCustomIEDownload.SetBindVerb(const Value: TBindVerb);
2865begin {Contains values that specify an action, such as an HTTP request, to be performed during the binding operation.}
2866 FBindVerb := Value;
2867 case FBindVerb of
2868 Get: FBindVerb_Value := BINDVERB_GET;
2869 Put: FBindVerb_Value := BINDVERB_PUT;
2870 Post: FBindVerb_Value := BINDVERB_POST;
2871 Custom: FBindVerb_Value := BINDVERB_CUSTOM;
2872 end;
2873end;
2874
2875procedure TCustomIEDownload.SetFileName(const Value: string);
2876begin
2877 FFileName := Value;
2878end;
2879
2880function TCustomIEDownload.SetFileNameFromUrl(const aUrl: string): string;
2881var
2882 Ut: TUrl;
2883 sTmp1, sTmp2: string;
2884begin
2885 if FDownloadMethod = dmFile then
2886 begin
2887 Ut := TUrl.Create(aUrl);
2888 try
2889 Ut.CrackUrl(aUrl, ICU_ESCAPE);
2890 if AnsiPos('.', Ut.ExtraInfo) <> 0 then
2891 sTmp1 := Ut.ExtraInfo;
2892 Ut.QueryUrl(aUrl);
2893 sTmp2 := Ut.Document;
2894 finally
2895 Ut.Free;
2896 end;
2897 if sTmp1 <> EmptyStr then
2898 begin
2899 Result := sTmp1;
2900 Exit;
2901 end
2902 else
2903 Result := sTmp2;
2904 end;
2905end;
2906
2907procedure TCustomIEDownload.ExtractDataFromFile(const aFileName: string);
2908begin
2909 FDownloadedFile := aFileName;
2910 FFileName := ExtractFileName(aFileName);
2911 FDownloadFolder := ExtractFilePath(aFileName);
2912 FFileExtension := ExtractFileExt(aFileName);
2913end;
2914
2915procedure TCustomIEDownload.SetAdditionalHeader(const Value: TStrings);
2916begin {Sets additional headers to append to the HTTP request.}
2917 FAdditionalHeader.Assign(Value);
2918end;
2919
2920procedure TCustomIEDownload.SetAbout(Value: string);
2921begin
2922 Exit;
2923end;
2924
2925procedure TCustomIEDownload.SetDefaultProtocol(const Value: string);
2926begin
2927 FDefaultProtocol := (Value);
2928 if FDefaultProtocol = EmptyStr then
2929 FDefaultProtocol := 'http://';
2930end;
2931
2932procedure TCustomIEDownload.SetUserAgent;
2933begin
2934 FFullUserAgent := USER_AGENT_IE6 + '(' + FUserAgent + ')' + #13#10;
2935end;
2936
2937procedure TCustomIEDownload.SetBindInfoF(const Value: TBindInfoF_Options);
2938begin
2939 FBindInfoF := Value;
2940 Update_BindInfoF_Value;
2941end;
2942
2943procedure TCustomIEDownload.SetBindF2(const Value: TBindF2_Options);
2944begin
2945 FBindF2 := Value;
2946 Update_BindF2_Value;
2947end;
2948
2949procedure TCustomIEDownload.SetBindInfoOption(const Value: TBindInfoOptions_Options);
2950begin
2951 FBindInfoOption_ := Value;
2952 Update_BindInfoOptions_Value;
2953end;
2954
2955procedure TCustomIEDownload.SetBindF(const Value: TBindF_Options);
2956begin
2957 if FFileExistsOption = feOverWrite then
2958 FBindF := FBindF + [GetNewestVersion];
2959 FBindF := Value;
2960 Update_BindF_Value;
2961end;
2962
2963procedure TCustomIEDownload.SetDownloadMethod(const Value: TDownloadMethod);
2964begin
2965 FDownloadMethod := Value;
2966end;
2967
2968function TCustomIEDownload.SetHttpProtocol(const aUrl: string): string;
2969type {Insert http to an address like bsalsa.com }
2970 TProtocols = array[1..23] of string;
2971const
2972 Protocols: TProtocols = (
2973 'about', 'cdl', 'dvd', 'file', 'ftp', 'gopher', 'http', 'ipp', 'its',
2974 'javascript', 'local', 'mailto', 'mk', 'msdaipp', 'ms-help', 'ms-its',
2975 'mso', 'res', 'sysimage', 'tv', 'vbscript', 'via', 'https');
2976var
2977 i: Integer;
2978begin
2979 for i := 1 to 23 do
2980 begin
2981 if (AnsiPos(AnsiUpperCase(Protocols[i]), AnsiUpperCase(aUrl)) <> 0) then
2982 begin
2983 Result := aUrl;
2984 Exit;
2985 end;
2986 end;
2987 Result := 'http://' + aUrl;
2988end;
2989
2990function TCustomIEDownload.SetDownloadFolder(const aDownloadFolder: string):
2991 string;
2992begin
2993 if (FDownloadMethod = dmFile) then
2994 begin
2995 Result := aDownloadFolder;
2996 if (Result = EmptyStr) then
2997 Result := ExtractFilePath(Application.ExeName) + DL_DIR;
2998 if Result <> EmptyStr then
2999 try
3000 ForceDirectories(Result);
3001 except
3002 if Assigned(FOnError) then
3003 FOnError(GetLastError, SysErrorMessage(GetLastError) +
3004 Err_Creating_Dir);
3005 end;
3006 end;
3007end;
3008
3009function TCustomIEDownload.ResponseCodeToStr(const dwResponse: Integer): string;
3010begin
3011 Result := IEDownloadTools.ResponseCodeToStr(dwResponse);
3012end;
3013
3014function TCustomIEDownload.WideStringToLPOLESTR(const Source: string): POleStr;
3015begin
3016 Result := IEDownloadTools.WidestringToLPOLESTR(Source);
3017end;
3018
3019initialization
3020 coInitialize(nil);
3021finalization
3022 coUninitialize;
3023end.
3024
Note: See TracBrowser for help on using the repository browser.