source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EWBTools.pas@ 1802

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

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 113.9 KB
Line 
1//***********************************************************
2// EwbTools *
3// *
4// For Delphi *
5// Freeware unit *
6// by *
7// bsalsa, Smot, *
8// per lindso larsen *
9// *
10// Documentation and updated versions: *
11// http://www.bsalsa.com *
12//***********************************************************
13
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
37unit EwbTools;
38
39interface
40
41{$I EWB.inc}
42
43uses
44 EwbAcc, Windows, Classes, ExtCtrls, ShlObj, Graphics, Dialogs, ActiveX,
45{$IFDEF DELPHI6_UP}Variants, {$ENDIF}
46 MSHTML_EWB, SHDocVw_EWB, EmbeddedWB, URLMon;
47
48var
49 PrintingWithOptions: Boolean;
50
51//Document and Frame
52function DocumentLoaded(Document: IDispatch): Boolean;
53procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
54
55//Html
56function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
57function DocumentSourceText(OleObject: Variant; Document: IDispatch): string;
58function DocumentSource(OleObject: Variant): string;
59function GetWordAtCursor(const X, Y: Integer; WebBrowser: TEmbeddedWB): string;
60
61//frames
62function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
63function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2; //By Aladin
64function FrameCount(Document: IDispatch): Longint;
65function FrameCountFromDocument(SourceDoc: IHTMLDocument2): Integer; //By Aladin
66
67//Document Operations
68procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
69function CMD_Copy(Document: IDispatch): Boolean;
70function Cmd_Paste(Document: IDispatch): Boolean;
71function Cmd_Cut(Document: IDispatch): Boolean;
72function SelectAll(Document: IDispatch): Boolean;
73function UnSelectAll(Document: IDispatch): Boolean;
74
75//scroll
76procedure ScrollToTop(OleObject: Variant);
77procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
78procedure ScrollToBottom(Document: IDispatch);
79procedure ScrollToID(ID: Integer; WebBrowser: TEmbeddedWB);
80procedure ScrollToIDEx(ID: string; WebBrowser: TEmbeddedWB);
81procedure GetScrollBarVisibility(WebBrowser: TEmbeddedWB; var HScroll, VScroll: Boolean);
82function GetScrollBarPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
83
84// zoom
85function Zoom(Document: IDispatch; ZoomValue: Integer): Boolean;
86function ZoomValue(Document: IDispatch): Integer;
87function ZoomRangeHigh(Document: IDispatch): Integer;
88function ZoomRangeLow(Document: IDispatch): Integer;
89
90function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string; Refresh: Boolean = True): Boolean;
91procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
92function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
93function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth, TargetHeight, TargetWidth: Integer): Boolean;
94
95//View Document Fields/Properties/Images
96procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
97procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
98procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
99procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);
100
101//Save
102function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HRESULT;
103function SaveDocToStream(Document: IDispatch; var AStream: TStream): HRESULT;
104function SaveDocToFile(Document: IDispatch; const Fname: string): HRESULT;
105
106//Printing
107procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean = False; bCustomHeaderFooter: Boolean = False; Header: string = ''; Footer: string = '');
108procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
109procedure PrintPreview(Webbrowser: IWebBrowser2);
110procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
111procedure PrintPreviewFromTemplate(const TemplateFileName: string; Document: IDispatch);
112function PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean): Boolean;
113procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
114procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
115function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): string;
116procedure RestorePrintValues;
117
118//Dialogs
119function OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): Boolean;
120function SaveDialog(Document: IDispatch): Boolean; overload;
121function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent; ATitle: string = ''; AFilter: string = ''): string; overload;
122
123function ShowInternetOptions(Document: IDispatch): Boolean;
124function ShowPageProperties(Document: IDispatch): Boolean;
125function ShowOrganizeFavorites(Handle: THandle): Boolean;
126procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
127function ShowFindDialog(Document: IDispatch): Boolean;
128procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
129function ViewPageSourceHtml(Document: IDispatch): Boolean;
130procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);
131
132//Open external programs
133procedure OpenAddressBook;
134procedure OpenEudoraMail;
135procedure OpenOutlookExpressMail;
136procedure OpenOutlookMail;
137procedure OpenRegistryEditor;
138function OpenCalendar: Boolean;
139function OpenClient(Client: string): Boolean;
140function OpenNetMeeting: Boolean;
141function OpenNewsClient: Boolean;
142procedure DoExploreFolder(Handle: THandle; Path: string);
143procedure OpenIEBrowserWithAddress(Handle: THandle);
144
145//Open specific webpages
146function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
147function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
148function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
149procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
150procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
151procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);
152
153//Navigate & Download
154procedure Go(WebBrowser: TEmbeddedWB; Url: string);
155procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
156procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
157procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
158procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
159procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
160function DownloadFile(SourceFile, TargetFile: string): Boolean;
161procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
162
163//Get Special Folders/URL paths etc.
164function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
165function GetShellFolderPath(FolderName: Widestring): string;
166function GetIEHomePage: string;
167function GetCachePath: string;
168function GetCachedFileFromURL(ItemUrl: string): string;
169function GetDefaultBrowserFromRegistry: string;
170function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
171
172
173//E-Mail functions
174procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
175function CreateNewMail: Boolean;
176procedure SendUrlInMail(LocationURL, LocationName: WideString);
177
178//Search in Document & Fill Forms
179function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
180//function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; const iPos: Integer = 1): IHTMLTxtRange;
181function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; aTypeSearch: Integer; const iPos: Integer = 1): IHTMLTxtRange;
182
183procedure SearchAndHighlight(Document: IDispatch;
184 AText: string; const ACaption, APrompt: string; Flags: TSearchFlags = [];
185 cbackColor: string = 'yellow'; cForeColor: string = '';
186 ScrollIntoView: TScrollIntoView = sivNoScroll; ShowInputQuery: Boolean = True); overload;
187
188procedure SearchAndHighlight(Document: IDispatch; aText: string; Flags: TSearchFlags = [];
189 cbackColor: string = 'yellow'; cForeColor: string = '';
190 ScrollIntoView: TScrollIntoView = sivNoScroll); overload;
191
192procedure SetTextAreaValue(Document: IDispatch; sName, sValue: string; Options: TFindOptions);
193function FillForm(WebBrowser: TEmbeddedWB; FieldName, FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
194function FillForm(Document: IDispatch; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
195
196function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; Value: Boolean): Boolean; overload;
197
198
199function GetFieldValue(OleObject: Variant; FieldName: string): string;
200procedure ClickInputImage(WebBrowser: TEmbeddedWB; ImageURL: string);
201
202procedure FillIEFormAndExcecute;
203
204//Clearing
205procedure ClearCache;
206procedure ClearTypedUrls;
207
208//Online Status
209function CheckOnlineStatus: Boolean;
210function IsGlobalOffline: Boolean;
211procedure WorkOffline();
212procedure WorkOnline();
213
214//Restricted & Trusted Lists
215function CheckIfInRestricredList(const Host: string; SecureSite: Boolean): Boolean;
216function CheckIfInTrustedList(const Host: string; SecureSite: Boolean): Boolean;
217procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
218procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
219
220//Zone Icon, Security Zone, SSL Status
221procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
222function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
223function GetZoneAttributes(const URL: string): TZoneAttributes;
224function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
225function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;
226
227//Proxy & User agent
228function SetProxy(UserAgent, Address: string): Boolean; overload;
229function SetProxy(UserAgent, Address, UserName, Password: string; Port: Integer): Boolean; overload;
230function SetProxyFromPAC(UserAgent, PACFile: string): Boolean;
231
232function RemoveProxy(): Boolean;
233procedure RemoveUserAgent(UserAgent: string);
234
235//MIME Filter & NameSpace
236function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
237function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
238function RegisterNameSpace(clsid: TGUID): HRESULT;
239function UnregisterNameSpace: HRESULT;
240
241//Cookies
242function GetCookiesPath: string;
243procedure ClearSessionCookies;
244
245//Favorites
246function OrganizeFavorite(h: THandle; Path: PAnsiChar): Boolean; stdcall; overload;
247{$IFDEF UNICODE}
248function OrganizeFavorite(h: THandle; Path: PWideChar): Boolean; overload;
249{$ENDIF UNICODE}
250
251function URLFromFavorites(const dotURL: string): string;
252function GetFavoritesPath: string;
253procedure AddToFavorites(URL, Title: string);
254
255//History
256function GetHistoryPath: string;
257function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
258procedure ClearHistory;
259
260//Pages
261procedure SetNewHomePage(HomePage: string);
262function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
263function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;
264
265//Code accessories
266procedure Wait(WebBrowser: TEmbeddedWB);
267function InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant): HRESULT;
268function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;
269
270//Execute Script
271procedure ExecScript(WebBrowser: TEmbeddedWB; sExpression, sLanguage: string);
272function ExecScriptEx(WebBrowser: TEmbeddedWB; MethodName: string; ParamValues: array of const): OleVariant;
273function WBExecScript(TargetObj: IDispatch; MethodName: string; ParamValues: array of const): OleVariant;
274
275//Miscellaneous
276procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
277procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
278procedure ShowIEVersionInfo(Handle: THandle);
279procedure CreateDesktopShortcut(Handle: THandle);
280procedure DisableNavSound(bDisable: Boolean);
281
282//----- add to ewb-------------------------------------------------------
283function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
284function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
285function CopyPIDL(IDList: PItemIDList): PItemIDList;
286function CreatePIDL(Size: Integer): PItemIDList;
287function DeleteUrl(Url: PWideChar): HResult;
288function Encode(const S: string): string;
289function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
290function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
291function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
292function GetIEVersion: string;
293function GetIEVersionMajor: Integer;
294function GetImageIndex(pidl: PItemIDList): Integer;
295function GetMailClients: TStrings;
296function GetPIDLSize(IDList: PItemIDList): Integer;
297function IE5_Installed: Boolean;
298function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
299function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
300function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
301
302
303
304
305function NextPIDL(IDList: PItemIDList): PItemIDList;
306function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
307function ResolveLink(const Path: string): string;
308function ResolveUrlIni(FileName: string): string;
309function ResolveUrlIntShCut(FileName: string): string;
310function StringToVarArray(const S: string): Variant;
311function URLFromShortcut(const dotURL: string): string;
312function VarArrayToString(const V: Variant): string;
313procedure DisposePIDL(ID: PItemIDList);
314procedure StripLastID(IDList: PItemIDList);
315function IsWinXPSP2OrLater(): Boolean;
316function EncodeUrl(const InputStr: string; const bQueryStr: Boolean): string;
317function DecodeURL(const InputStr: string): string;
318function IsValidProtocol(URL: string): Boolean;
319function ImportCertFile(AFileName, AStoreType: string): Boolean;
320//--end of add to ewb---------------------------------
321
322implementation
323
324uses
325 Registry, ShellAPI, Controls, Messages, Forms, SysUtils,
326 OleCtrls, WinInet, SendMail_For_EWB, ComObj, IEConst, IniFiles, JPEG, WinSock,
327 Wcrypt2, Browse4Folder, EWBCoreTools;
328
329type
330 OSVERSIONINFOEX = packed record
331 dwOSVersionInfoSize: DWORD;
332 dwMajorVersion: DWORD;
333 dwMinorVersion: DWORD;
334 dwBuildNumber: DWORD;
335 dwPlatformId: DWORD;
336 szCSDVersion: array[0..127] of Char;
337 wServicePackMajor: WORD;
338 wServicePackMinor: WORD;
339 wSuiteMask: WORD;
340 wProductType: BYTE;
341 wReserved: BYTE;
342 end;
343 TOSVersionInfoEx = OSVERSIONINFOEX;
344 POSVersionInfoEx = ^TOSVersionInfoEx;
345
346
347type
348 fn_VerifyVersionInfo = function(var VersionInformation: OSVERSIONINFOEX;
349 dwTypeMask: DWORD; dwlConditionMask: LONGLONG): BOOL; stdcall;
350 fn_VerSetConditionMask = function(ConditionMask: LONGLONG; TypeMask: DWORD;
351 Condition: Byte): LONGLONG; stdcall;
352
353function ImportCertFile(AFileName, AStoreType: string): Boolean;
354var
355 f: file; //by Ray
356 encCert: PByte;
357 encCertLen: DWORD;
358 store: HCERTSTORE;
359 context: PCCERT_CONTEXT;
360 n: PCCERT_CONTEXT;
361 encType: DWORD;
362begin
363 Result := False;
364 if FileExists(AFileName) then
365 begin
366 AssignFile(f, AFileName);
367 Reset(f, 1);
368 encCertLen := FileSize(f);
369 GetMem(encCert, encCertLen);
370 BlockRead(f, encCert^, encCertLen);
371 CloseFile(f);
372 try
373 encType := PKCS_7_ASN_ENCODING or X509_ASN_ENCODING;
374 context := CertCreateCertificateContext(encType, encCert, encCertLen);
375 if context <> nil then
376 begin
377 store := CertOpenSystemStore(0, PChar(AStoreType));
378 if store <> nil then
379 begin
380 n := nil;
381 Result := CertAddCertificateContextToStore(store, context,
382 CERT_STORE_ADD_REPLACE_EXISTING, n);
383 CertCloseStore(store, 0);
384 CertFreeCertificateContext(context);
385 end;
386 end;
387 finally
388 FreeMem(encCert, encCertLen);
389 end;
390 end;
391end;
392
393function IsWinXPSP2OrLater(): Boolean;
394var
395 osvi: TOSVersionInfoEx;
396 dwlConditionMask: LONGLONG;
397 op: Integer;
398 hlib: THandle;
399 VerifyVersionInfo: fn_VerifyVersionInfo;
400 VerSetConditionMask: fn_VerSetConditionMask;
401begin
402 Result := False;
403 hLib := LoadLibrary('kernel32.dll');
404 if (hLib <> 0) then
405 begin
406 @VerifyVersionInfo := GetProcAddress(hLib, 'VerifyVersionInfoA');
407 @VerSetConditionMask := GetProcAddress(hLib, 'VerSetConditionMask');
408 if ((@VerifyVersionInfo = nil) or (@VerSetConditionMask = nil)) then
409 Exit;
410
411 dwlConditionMask := 0;
412 op := VER_GREATER_EQUAL;
413
414 // Initialize the OSVERSIONINFOEX structure.
415 ZeroMemory(@osvi, SizeOf(OSVERSIONINFOEX));
416 osvi.dwOSVersionInfoSize := SizeOf(OSVERSIONINFOEX);
417 osvi.dwMajorVersion := 5;
418 osvi.dwMinorVersion := 1;
419 osvi.wServicePackMajor := 2;
420 osvi.wServicePackMinor := 0;
421
422 // Initialize the condition mask.
423 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MAJORVERSION, op);
424 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MINORVERSION, op);
425 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMAJOR, op);
426 dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMINOR, op);
427
428 // Perform the test.
429 Result := VerifyVersionInfo(osvi, VER_MAJORVERSION or VER_MINORVERSION or
430 VER_SERVICEPACKMAJOR or VER_SERVICEPACKMINOR, dwlConditionMask);
431 end;
432end;
433
434function EncodeURL(const InputStr: string; const bQueryStr: Boolean): string;
435var
436 Idx: Integer;
437begin
438 Result := '';
439 for Idx := 1 to Length(InputStr) do
440 begin
441 case InputStr[Idx] of
442 'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
443 Result := Result + InputStr[Idx];
444 ' ':
445 if bQueryStr then
446 Result := Result + '+'
447 else
448 Result := Result + '%20';
449 else
450 Result := Result + '%' + SysUtils.IntToHex(Ord(InputStr[Idx]), 2);
451 end;
452 end;
453end;
454
455function DecodeURL(const InputStr: string): string;
456var
457 Idx: Integer;
458 Hex: string;
459 Code: Integer;
460begin
461 Result := '';
462 Idx := 1;
463 while Idx <= Length(InputStr) do
464 begin
465 case InputStr[Idx] of
466 '%':
467 begin
468 if Idx <= Length(InputStr) - 2 then
469 begin
470 Hex := InputStr[Idx + 1] + InputStr[Idx + 2];
471 Code := SysUtils.StrToIntDef('$' + Hex, -1);
472 Inc(Idx, 2);
473 end
474 else
475 Code := -1;
476 if Code = -1 then
477 raise SysUtils.EConvertError.Create('Invalid HEX digit in URL');
478 Result := Result + Chr(Code);
479 end;
480 '+':
481 Result := Result + ' '
482 else
483 Result := Result + InputStr[Idx];
484 end;
485 Inc(Idx);
486 end;
487end;
488
489function IsValidProtocol(URL: string): Boolean;
490const
491 Protocols: array[1..11] of string = ('ftp://', 'http://', 'https://',
492 'gopher://', 'mailto:', 'news:', 'nntp://', 'telnet://', 'wais://',
493 'file://', 'prospero://');
494var
495 I: Integer;
496begin
497 Result := False;
498 URL := SysUtils.LowerCase(URL);
499 for I := Low(Protocols) to High(Protocols) do
500 if Pos(Protocols[I], URL) <> 0 then
501 begin
502 Result := True;
503 Break;
504 end;
505end;
506
507function DocumentLoaded(Document: IDispatch): Boolean;
508var
509 iDoc: IHTMLDocument2;
510begin
511 Result := False;
512 if Assigned(Document) then
513 begin
514 Document.QueryInterface(IHTMLDocument2, iDoc);
515 Result := Assigned(iDoc);
516 end;
517end;
518
519procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
520begin
521 WebBrowser.Go('about:blank');
522end;
523
524function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
525var
526 Flags, TargetFrameName, PostData, Headers: OleVariant;
527begin
528 WebBrowser.Navigate('about:' + StringToHtml, Flags, TargetFrameName, PostData, Headers);
529 Result := True;
530end;
531
532function GetWordAtCursor(const X, Y: Integer; WebBrowser: TEmbeddedWB): string;
533var
534 Doc: IHTMLDocument2;
535 Selection: IHTMLSelectionObject;
536 Range: IHTMLTxtRange;
537begin
538 Result := '';
539 if WebBrowser.DocumentLoaded(Doc) then
540 begin
541 Selection := (Doc as IHTMLDocument2).selection;
542 if Assigned(Selection) then
543 begin
544 Range := Selection.createRange as IHTMLTxtRange;
545 Range.moveToPoint(X, Y);
546 Range.moveStart('word', -1);
547 Range.moveEnd('word', 1);
548 Result := Trim(Range.text);
549 end;
550 end;
551end;
552
553procedure PrintPreviewFromTemplate(const TemplateFileName: string; Document: IDispatch);
554var
555 OleCommandTarget: IOleCommandTarget;
556 ParamIn, EmptyParam: OleVariant;
557begin
558 if Assigned(Document) then
559 begin
560 EmptyParam := EmptyStr;
561 Document.QueryInterface(IID_IoleCommandTarget, OLECOMMANDTARGET);
562 ParamIn := TemplateFileName;
563 OleCommandTarget.Exec(
564 nil,
565 OLECMDID_PRINTPREVIEW,
566 OLECMDEXECOPT_PROMPTUSER,
567 ParamIn, EmptyParam);
568 end;
569end;
570
571procedure ScrollToIDEx(ID: string; WebBrowser: TEmbeddedWB);
572var
573 Doc3: IHTMLDocument3;
574 Elem: IHTMLElement;
575 RV: IHTMLRect;
576begin
577 Doc3 := WebBrowser.Doc3;
578 if Assigned(Doc3) then
579 begin
580 Elem := Doc3.getElementById(ID);
581 if Assigned(Elem) then
582 begin
583 RV := (Elem as IHTMLElement2).getBoundingClientRect;
584 Webbrowser.Doc2.parentWindow.scrollBy(RV.left, RV.top);
585 end;
586 end;
587end;
588
589procedure ScrollToID(ID: Integer; WebBrowser: TEmbeddedWB);
590var
591 Doc: IHTMLDocument2;
592 ACollection: IHTMLElementCollection;
593 Elem: IHTMLElement;
594 Match: IHTMLElement2;
595 I: Integer;
596 S: string;
597 RV: IHTMLRect;
598begin
599 if WebBrowser.DocumentLoaded(Doc) then
600 begin
601 ACollection := Doc.all;
602 if Assigned(ACollection) then
603 begin
604 Match := nil;
605 S := IntToStr(ID);
606 for I := 0 to ACollection.length - 1 do
607 begin
608 Elem := ACollection.item(I, '') as IHTMLElement;
609 if Assigned(Elem) and (Elem.id = S) then
610 begin
611 Match := Elem as IHTMLElement2;
612 Break;
613 end;
614 end;
615 if Assigned(Match) then
616 begin
617 RV := Match.getBoundingClientRect;
618 WebBrowser.Doc2.parentWindow.scrollBy(RV.left, RV.top);
619 end;
620 end;
621 end;
622end;
623
624// Get SysListView32 Child from the Webbrowser Control
625
626function GetWBLV(WBHandle: HWND): HWND;
627var
628 WND: HWND;
629begin
630 Result := 0;
631 Wnd := GetNextWindow(WBHandle, GW_CHILD);
632 while (Result = 0) and (WND <> 0) do
633 begin
634 Result := FindWindowEx(Wnd, 0, 'SysListView32', nil);
635 Wnd := GetNextWindow(Wnd, GW_CHILD)
636 end;
637end;
638
639// Check if the horizontal / vertical Scrollbars are visible
640
641procedure GetScrollBarVisibility(WebBrowser: TEmbeddedWB; var HScroll, VScroll: Boolean);
642var
643 WndLV: HWND;
644 IDoc: IHTMLDocument2;
645begin
646 VScroll := False;
647 HScroll := False;
648 WndLV := GetWBLV(WebBrowser.Handle);
649 if WndLV = 0 then
650 begin
651 if Assigned(WebBrowser.Document) and (Succeeded(WebBrowser.Document.QueryInterface(IHTMLDocument2, IDoc))) then
652 begin
653 IDoc := WebBrowser.Document as IHTMLDocument2;
654 if Assigned(IDoc) and Assigned((IHTMLDocument2(IDoc).Body)) then
655 begin
656 VScroll := WebBrowser.OleObject.Document.body.ScrollHeight > WebBrowser.OleObject.Document.Body.ClientHeight;
657 HScroll := (WebBrowser.OleObject.Document.body.ScrollWidth > WebBrowser.OleObject.Document.Body.ClientWidth);
658 end;
659 end;
660 end else
661 begin
662 // if the WB is in "ListView" mode:
663 VScroll := ((GetWindowLong(WndLV, GWL_STYLE) and WS_VSCROLL) <> 0);
664 HScroll := ((GetWindowLong(WndLV, GWL_STYLE) and WS_HSCROLL) <> 0)
665 end;
666end;
667
668// Get TEmbeddedWB Scrollbar X,Y Position
669
670function GetScrollBarPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
671
672 // Get Scrollbar X,Y Position of the ListView
673 function WB_GetLVScrollPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
674 var
675 lpsi: TScrollInfo;
676 WndLV: HWND;
677 begin
678 Result := False;
679 // Retrieve SysListView32 Child of TEmbeddedWB
680 WndLV := GetWBLV(WebBrowser.Handle);
681 if WndLV <> 0 then // SysListView32 found
682 begin
683 // initialize TScrollInfo
684 FillChar(lpsi, SizeOf(lpsi), 0);
685 with lpsi do
686 begin
687 cbSize := SizeOf(lpsi);
688 fMask := SIF_POS;
689 end;
690 // Get ScrollInfos from the vertical Scrollbar
691 if GetScrollInfo(WndLV, SB_VERT, lpsi) then
692 begin
693 ScrollPos.Y := lpsi.nPos;
694 // Get ScrollInfos from the horizontal Scrollbar
695 if GetScrollInfo(WndLV, SB_HORZ, lpsi) then
696 begin
697 ScrollPos.X := lpsi.nPos;
698 Result := True;
699 end;
700 end;
701 end;
702 end;
703
704 // Get Scrollbar X,Y Position of the HTML Document
705 function WB_GetDOCScrollPosition(WB: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
706 var
707 IDoc: IHTMLDocument2;
708 IDoc3: IHTMLDocument3;
709 IElement: IHTMLElement;
710 begin
711 ScrollPos := Point(-1, -1);
712 Result := False;
713 if Assigned(WebBrowser.Document) and (Succeeded(WebBrowser.Document.QueryInterface(IHTMLDocument2, IDoc))) then
714 begin
715 IDoc := WebBrowser.Document as IHTMLDocument2;
716 if Assigned(IDoc) and Assigned((IHTMLDocument2(IDoc).Body)) then
717 begin
718 if (IDoc.QueryInterface(IHTMLDocument3, IDoc3) = S_OK) then
719 if Assigned(IDoc3) then
720 IElement := IDoc3.get_documentElement;
721 if (Assigned(IElement)) and (Variant(IDoc).DocumentElement.scrollTop = 0) then
722 ScrollPos.Y := IHTMLDocument2(IDoc).Body.getAttribute('ScrollTop', 0)
723 else
724 ScrollPos.Y := Variant(IDoc).DocumentElement.scrollTop;
725 if Assigned(IElement) and (Variant(IDoc).DocumentElement.scrollLeft = 0) then
726 ScrollPos.X := IHTMLDocument2(IDoc).Body.getAttribute('ScrollLeft', 0)
727 else
728 ScrollPos.X := Variant(IDoc).DocumentElement.scrollLeft
729 end;
730 Result := (ScrollPos.X <> -1) and (ScrollPos.Y <> -1)
731 end;
732 end;
733
734begin
735 Result := WB_GetDOCScrollPosition(WebBrowser, ScrollPos);
736 if not Result then
737 Result := WB_GetLVScrollPosition(WebBrowser, ScrollPos);
738end;
739
740function DocumentSource(OleObject: Variant): string;
741var
742 Strings: TStringList;
743begin
744 Strings := TStringList.Create;
745 try
746 ViewPageSourceHTMLToStrings(OleObject, OleObject.Document, Strings);
747 Result := Strings.Text;
748 finally
749 FreeAndNil(Strings);
750 end;
751end;
752
753function DocumentSourceText(OleObject: Variant; Document: IDispatch): string;
754var
755 Strings: TStringList;
756begin
757 Strings := TStringList.Create;
758 try
759 EwbTools.ViewPageSourceTextToStrings(OleObject, Document, Strings);
760 Result := Strings.Text;
761 finally
762 FreeAndNil(Strings);
763 end;
764end;
765
766function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
767var
768 OleContainer: IOleContainer;
769 enum: ActiveX.IEnumUnknown;
770 unk: IUnknown;
771 Fetched: PLongint;
772begin
773 if Assigned(Document) then
774 begin
775 Fetched := nil;
776 OleContainer := Document as IOleContainer;
777 if OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum) = S_OK then
778 begin
779 Enum.Skip(FrameNo);
780 Enum.Next(1, Unk, Fetched);
781 Result := Unk as IWebBrowser2;
782 end else
783 Result := nil;
784 end
785 else
786 Result := nil;
787end;
788
789function FrameCount(Document: IDispatch): LongInt;
790var //fix by Aladin
791 OleContainer: IOleContainer;
792 enum: ActiveX.IEnumUnknown;
793 FetchedContrs: LongInt;
794 Unknown: IUnknown;
795 IWeb: IWebBrowser2;
796begin
797 Result := 0; //bsalsa
798 if not DocumentLoaded(Document) then Exit;
799 OleContainer := Document as IOleContainer;
800 if OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum) = S_OK then
801 begin
802 while Enum.Next(1, Unknown, @FetchedContrs) = S_OK do
803 begin
804 if Unknown.QueryInterface(IID_IWebBrowser2, IWeb) = S_OK then //check if it is frame
805 Inc(Result);
806 end;
807 end;
808end;
809
810function FrameCountFromDocument(SourceDoc: IHTMLDocument2): Integer;
811var //by Aladin
812 OleContainer: IOleContainer;
813 enum: ActiveX.IEnumUnknown;
814 unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
815 EnumResult: HRESULT;
816begin
817 Result := 0;
818 if not DocumentLoaded(SourceDoc) then Exit;
819 OleContainer := SourceDoc as IOleContainer;
820 EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
821 if EnumResult = S_OK then
822 // Added per OLE help
823 Enum.Next(100, Unk, @Result)
824 else // Added per OLE help
825 Enum := nil;
826end;
827
828procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
829begin
830 if DocumentLoaded(Document) then
831 with (Dispatch as IOleObject) do
832 DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser, 0, WebBrowser.Handle, WebBrowser.ClientRect);
833end;
834
835function CMD_Copy(Document: IDispatch): Boolean;
836var
837 vaIn, vaOut: OleVariant;
838begin
839 Result := InvokeCmd(Document, False, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
840end;
841
842function CMD_Paste(Document: IDispatch): Boolean;
843var
844 vaIn, vaOut: OleVariant;
845begin
846 Result := InvokeCmd(Document, False, OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
847end;
848
849function CMD_Cut(Document: IDispatch): Boolean;
850var
851 vaIn, vaOut: OleVariant;
852begin
853 Result := InvokeCmd(Document, False, OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
854end;
855
856function SelectAll(Document: IDispatch): Boolean;
857var
858 vaIn, vaOut: OleVariant;
859begin
860 Result := InvokeCmd(Document, False, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
861end;
862
863function UnSelectAll(Document: IDispatch): Boolean;
864var
865 vaIn, vaOut: OleVariant;
866begin
867 Result := InvokeCmd(Document, False, OLECMDID_CLEARSELECTION, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
868end;
869
870procedure ScrollToTop(OleObject: Variant);
871begin
872 try
873 if DocumentLoaded(OleObject.Document) then
874 OleObject.Document.ParentWindow.ScrollTo(0, 0);
875 except
876 end;
877end;
878
879procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
880begin
881 try
882 if DocumentLoaded(OleObject.Document) then
883 OleObject.Document.ParentWindow.ScrollTo(X, Y);
884 except
885 end;
886end;
887
888procedure ScrollToBottom(Document: IDispatch);
889var
890 HTMLParentWin: IHTMLWindow2;
891 Doc2: IHTMLDocument2;
892begin
893 try
894 if Supports(Document, IHTMLDocument2, Doc2) then
895 begin
896 // OleObject.Document.ParentWindow.ScrollTo(0, MaxInt); doesn't work in IE8
897 HTMLParentWin := IHTMLWindow2((Doc2 as IHTMLDocument2).parentWindow);
898 HTMLParentWin.scrollBy(0, (Doc2.body as IHTMLElement2).scrollHeight);
899 end;
900 except
901 end;
902end;
903
904function Zoom(Document: IDispatch; ZoomValue: Integer): Boolean;
905var
906 vaIn, vaOut: OleVariant;
907begin
908 if ZoomValue < ZoomRangeLow(Document) then
909 vaIn := ZoomRangeLow(Document)
910 else
911 if ZoomValue > ZoomRangeHigh(Document) then
912 vaIn := ZoomRangeHigh(Document)
913 else
914 vaIn := ZoomValue;
915 Result := InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut) = S_OK;
916end;
917
918function ZoomValue(Document: IDispatch): Integer;
919var
920 vaIn, vaOut: OleVariant;
921begin
922 vaIn := null;
923 InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
924 Result := vaOut;
925end;
926
927function ZoomRangeHigh(Document: IDispatch): Integer;
928var
929 vaIn, vaOut: OleVariant;
930begin
931 InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
932 Result := HiWord(DWORD(vaOut));
933end;
934
935function ZoomRangeLow(Document: IDispatch): Integer;
936var
937 vaIn, vaOut: OleVariant;
938begin
939 InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
940 Result := LoWord(DWORD(vaOut));
941end;
942
943function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string; Refresh: Boolean = True): Boolean;
944var
945 RefreshLevel: OleVariant;
946begin
947 Wait(WebBrowser);
948 Result := False;
949 if DocumentLoaded(Document) then
950 begin
951 try
952 WebBrowser.Doc2.Set_CharSet(ACharactersSet);
953 Result := True;
954 if Refresh then
955 begin
956 RefreshLevel := 7;
957 WebBrowser.Refresh2(RefreshLevel);
958 end;
959 except
960 end;
961 end;
962end;
963
964{
965function GetCookie(OleObject: Variant): string;
966begin
967 Result := '';
968 if DocumentLoaded(OleObject.Document) then
969 try
970 Result := OleObject.Document.Cookie;
971 except
972 end;
973end; }
974
975procedure ClearSessionCookies;
976begin
977 InternetSetOption(nil, INTERNET_OPTION_END_BROWSER_SESSION, nil, 0);
978end;
979
980procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
981var
982 DrawRect: TRect;
983begin
984 if Image = nil then
985 Exit;
986 DrawRect := Rect(0, 0, Image.Height, Image.Width);
987 Image.Picture.Bitmap.Height := Image.Height;
988 Image.Picture.Bitmap.Width := Image.Width;
989 (Dispatch as IViewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0,
990 Image.Canvas.Handle, @DrawRect, nil, nil, 0);
991 Image.Refresh;
992end;
993
994function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
995var
996 ViewObject: IViewObject;
997 sourceDrawRect: TRect;
998 ScreenImg: Graphics.TBitmap;
999begin
1000 Result := False;
1001 if DocumentLoaded(Document) then
1002 try
1003 Document.QueryInterface(IViewObject, ViewObject);
1004 if Assigned(ViewObject) then
1005 try
1006 ScreenImg := TBitmap.Create;
1007 ScreenImg.Height := Height;
1008 ScreenImg.Width := Width;
1009 sourceDrawRect := Rect(0, 0, ScreenImg.Width, ScreenImg.Height);
1010 ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Handle,
1011 ScreenImg.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
1012 ScreenImg.SaveToFile(FileName);
1013 Result := True;
1014 finally
1015 ViewObject._Release;
1016 end;
1017 except
1018 Result := False;
1019 end;
1020end;
1021
1022function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth,
1023 TargetHeight, TargetWidth: Integer): Boolean;
1024var
1025 sourceDrawRect: TRect;
1026 targetDrawRect: TRect;
1027 sourceBitmap: Graphics.TBitmap;
1028 targetBitmap: Graphics.TBitmap;
1029 aJPG: TJPEGImage;
1030 aViewObject: IViewObject;
1031 IWeb: IWebBrowser2;
1032begin
1033 Result := False;
1034 sourceBitmap := Graphics.TBitmap.Create;
1035 targetBitmap := Graphics.TBitmap.Create;
1036 aJPG := TJPEGImage.Create;
1037 IWeb := ControlInterface;
1038 try
1039 try
1040 sourceDrawRect := Rect(0, 0, SourceWidth, SourceHeight);
1041 sourceBitmap.Width := SourceWidth;
1042 sourceBitmap.Height := SourceHeight;
1043 aViewObject := IWeb as IViewObject;
1044 if aViewObject = nil then
1045 Exit;
1046 OleCheck(aViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil,
1047 Forms.Application.Handle,
1048 sourceBitmap.Canvas.Handle,
1049 @sourceDrawRect, nil, nil, 0));
1050 targetDrawRect := Rect(0, 0, TargetWidth, TargetHeight);
1051 targetBitmap.Height := TargetHeight;
1052 targetBitmap.Width := TargetWidth;
1053 targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);
1054 aJPG.Assign(targetBitmap);
1055 aJPG.SaveToFile(FileName);
1056 Result := True;
1057 finally
1058 aJPG.Free;
1059 sourceBitmap.Free;
1060 targetBitmap.Free;
1061 end;
1062 except
1063 Result := False;
1064 end;
1065end;
1066
1067procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
1068var //by smot
1069 UNum: Variant;
1070 s: string;
1071
1072 procedure RecurseLinks(htmlDoc: Variant);
1073 var
1074 BodyElement, ElementCo, HTMLFrames, HTMLWnd, doc: OleVariant;
1075 j, i: Integer;
1076 begin
1077 if VarIsEmpty(htmlDoc) then Exit;
1078 BodyElement := htmlDoc.body;
1079 if BodyElement.tagName = 'BODY' then
1080 begin
1081 ElementCo := htmlDoc.links;
1082 j := ElementCo.Length - 1;
1083 for i := 0 to j do
1084 begin
1085 UNum := ElementCo.item(i);
1086 s := UNum.href;
1087 if j = 0 then
1088 s := 'No Links found in the page body';
1089 LinksList.Add(s);
1090 end;
1091 end;
1092 HTMLFrames := htmlDoc.Frames;
1093 j := HTMLFrames.Length - 1;
1094 for i := 0 to j do
1095 begin
1096 HTMLWnd := HTMLFrames.Item(i);
1097 try
1098 doc := HTMLWnd.Document;
1099 RecurseLinks(doc);
1100 except
1101 Continue;
1102 end;
1103 end;
1104 end;
1105begin
1106 LinksList.Clear;
1107 if not DocumentLoaded(OleObject.Document) then
1108 Exit;
1109 RecurseLinks(OleObject.Document);
1110end;
1111
1112procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
1113begin
1114 HtmlList.Clear;
1115 if DocumentLoaded(Document) then
1116 begin
1117 try
1118 HtmlList.Add(VarToStr(OleObject.Document.documentElement.innerHTML));
1119 except
1120 end;
1121 end;
1122end;
1123
1124procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
1125begin
1126 TextList.Clear;
1127 if DocumentLoaded(Document) then
1128 begin
1129 try
1130 TextList.Add(VarToStr(OleObject.Document.documentElement.innerText));
1131 except
1132 end;
1133 end;
1134end;
1135
1136procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);
1137var
1138 TextLst: TStringList;
1139begin
1140 TextLst := TStringList.Create;
1141 try
1142 if DocumentLoaded(Document) then
1143 begin
1144 TextLst.Add(VarToStr(OleObject.Document.documentElement.innerText));
1145 MessageDlg(TextLst.Text, mtCustom, [mbOK], 0);
1146 end;
1147 finally
1148 TextLst.Free;
1149 end;
1150end;
1151
1152function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HResult;
1153var
1154 IpStream: IPersistStreamInit;
1155 AStream: TMemoryStream;
1156begin
1157 Result := S_FALSE;
1158 if not DocumentLoaded(Document) then
1159 Exit;
1160 AStream := TMemoryStream.Create;
1161 try
1162 IpStream := Document as IPersistStreamInit;
1163 if not Assigned(IpStream) then
1164 Result := S_FALSE
1165 else
1166 if Succeeded(IpStream.save(TStreamadapter.Create(AStream), True))
1167 then
1168 begin
1169 AStream.Seek(0, 0);
1170 AStrings.LoadFromStream(AStream);
1171 Result := S_OK;
1172 end;
1173 except
1174 end;
1175 AStream.Free;
1176end;
1177
1178function SaveDocToStream(Document: IDispatch; var AStream: TStream): HResult;
1179var
1180 IpStream: IPersistStreamInit;
1181begin
1182 if DocumentLoaded(Document) then
1183 begin
1184 IpStream := Document as IPersistStreamInit;
1185 Result := IpStream.Save(TStreamAdapter.Create(AStream), True);
1186 end
1187 else
1188 Result := S_FALSE;
1189end;
1190
1191function SaveDocToFile(Document: IDispatch; const Fname: string): HResult;
1192var
1193 PFile: IPersistFile;
1194begin
1195 Result := S_FALSE;
1196 if DocumentLoaded(Document) then
1197 begin
1198 PFile := Document as IPersistFile;
1199 Result := PFile.Save(StringToOleStr(FName), False);
1200 end;
1201end;
1202
1203procedure PrintWithHeaderFooter(ControlInterface: IWebBrowser2; Header, Footer: PWideChar; Options: OLECMDEXECOPT);
1204var
1205 saBound: TSafeArrayBound;
1206 psaHeadFoot: PSafeArray;
1207 vaIn, vaOut: TVariantArg;
1208 vHeadStr, vFootStr: TVariantArg;
1209 rgIndex: LongInt;
1210begin
1211 try
1212 saBound.lLbound := 0;
1213 saBound.cElements := 2;
1214 psaHeadFoot := SafeArrayCreate(VT_VARIANT, 1, saBound);
1215 vHeadStr.vt := VT_BSTR;
1216 vHeadStr.bstrVal := SysAllocString(Header);
1217 vFootStr.vt := VT_BSTR;
1218 vFootStr.bstrVal := SysAllocString(Footer);
1219 rgIndex := 0;
1220 OleCheck(SafeArrayPutElement(psaHeadFoot, rgIndex, vHeadStr));
1221 rgIndex := 1;
1222 OleCheck(SafeArrayPutElement(psaHeadFoot, rgIndex, vFootStr));
1223 vaIn.vt := VT_ARRAY or VT_BYREF;
1224 vaIn.parray := psaHeadFoot;
1225 ControlInterFace.ExecWB(OLECMDID_PRINT, Options,
1226 OleVariant(vaIn), OleVariant(vaOut));
1227 if vHeadStr.bstrVal <> nil then
1228 SysFreeString(vHeadStr.bstrVal);
1229 if vFootStr.bstrVal <> nil then
1230 SysFreeString(vFootStr.bstrVal);
1231 except
1232 end;
1233end;
1234
1235procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean = False; bCustomHeaderFooter: Boolean = False; Header: string = ''; Footer: string = '');
1236var
1237 vaIn, vaOut: OleVariant;
1238begin
1239 if DocumentLoaded(ControlInterface.Document) then
1240 begin
1241 if bCustomHeaderFooter then
1242 begin
1243 if bHideSetup then
1244 PrintWithHeaderFooter(ControlInterface, TaskAllocWideString(Header), TaskAllocWideString(Footer), OLECMDEXECOPT_DONTPROMPTUSER)
1245 else
1246 PrintWithHeaderFooter(ControlInterface, TaskAllocWideString(Header), TaskAllocWideString(Footer), OLECMDEXECOPT_PROMPTUSER);
1247 end
1248 else
1249 if bHideSetup then
1250 ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut)
1251 else
1252 ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut)
1253 end;
1254end;
1255
1256procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
1257begin
1258 PrintingWithOptions := True;
1259 PageSetup(Document, UsePrintOptions, PrintOptionsEnabled, InvokingPagesetup);
1260 Print(ControlInterface, HideSetup);
1261end;
1262
1263procedure PrintPreview(Webbrowser: IWebBrowser2);
1264// IE 5.5 only
1265var
1266 vaIn, vaOut: Olevariant;
1267begin
1268 if DocumentLoaded(Webbrowser.Document) then
1269 Webbrowser.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
1270end;
1271
1272function OpenClient(Client: string): Boolean;
1273var
1274 s, params, Exec: string;
1275begin
1276 Result := False;
1277 with TRegistry.Create do
1278 try
1279 RootKey := HKEY_LOCAL_MACHINE;
1280 OpenKey('Software\Clients\' + Client, False);
1281 S := ReadString('');
1282 CloseKey;
1283 OpenKey('Software\Clients\' + Client + '\' + S + '\shell\open\command', False);
1284 S := ReadString('');
1285 CloseKey;
1286 if S <> '' then
1287 begin
1288 if Pos('/', S) > 0 then
1289 begin
1290 Exec := system.Copy(S, 1, Pos('/', S) - 2);
1291 Params := system.Copy(s, Length(exec) + 1, length(S));
1292 end
1293 else
1294 begin
1295 Exec := S;
1296 Params := '';
1297 end;
1298 Result := True;
1299 ShellExecute(Application.handle, 'open', PChar(Exec), PChar(Params), '', SW_SHOW);
1300 end;
1301 finally
1302 Free;
1303 end;
1304end;
1305
1306procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
1307var
1308 Preview_HWND, App_HWND: THandle;
1309 ClassName: array[0..255] of Char;
1310 StartTime, EndTime: DWORD; //Smot
1311 vaIn, vaOut: OleVariant;
1312begin
1313 if DocumentLoaded(ControlInterface.Document) then
1314 begin
1315 if HideSetup then
1316 ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut) //jerzy
1317 else
1318 ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);
1319 Preview_HWND := 0;
1320 StartTime := GetTickCount;
1321 repeat
1322 App_HWND := GetForegroundWindow();
1323 GetClassName(App_HWND, ClassName, SizeOf(ClassName));
1324 if lstrcmp(@ClassName[0], @IE_PPREVIEWCLASS[1]) = 0 then
1325 Preview_HWND := App_HWND;
1326 Forms.Application.ProcessMessages;
1327 EndTime := GetTickCount;
1328 until (Preview_HWND <> 0) or (EndTime - StartTime > 7000);
1329 if Preview_HWND <> 0 then
1330 ShowWindow(Preview_HWND, nCmdShow);
1331 end;
1332end;
1333
1334function PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean): Boolean;
1335var
1336 vaIn, vaOut: OleVariant;
1337begin
1338 Result := False;
1339 if DocumentLoaded(Document) then
1340 begin
1341 if PrintOptionsEnabled and UsePrintOptions then
1342 InvokingPageSetup := True;
1343 Result := InvokeCmd(Document, False, OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK
1344 end;
1345end;
1346
1347procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
1348var
1349 vaIn, vaOut: OleVariant;
1350begin
1351 if DocumentLoaded(ControlInterface.Document) then
1352 begin
1353 if HideSetup then
1354 ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut)
1355 else
1356 ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut)
1357 end;
1358end;
1359
1360procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
1361var
1362 S: string;
1363 Registry: TRegistry;
1364
1365 function ReadMargin(key: string): Real;
1366 begin
1367 S := Registry.ReadString(key);
1368 if S = '' then
1369 S := '0.750000'; // <-- default margin value by takeru_tk_81
1370 S := StringReplace(S, ' ', '', [rfReplaceAll]);
1371 if DecimalSeparator <> '.' then
1372 S := StringReplace(S, '.', DecimalSeparator, []);
1373 if Measure = mMetric then
1374 Result := StrToFloat(S) * InchToMetric
1375 else
1376 Result := StrToFloat(S);
1377 end;
1378
1379begin
1380 Registry := TRegistry.Create;
1381 try
1382 with Registry do
1383 begin
1384 RootKey := HKEY_CURRENT_USER;
1385 if OpenKey('Software\Microsoft\Internet Explorer\PageSetup', False) then
1386 begin
1387 with PrintOptions do
1388 begin
1389 Header := ReadString('header');
1390 Footer := ReadString('footer');
1391 Margins.Left := ReadMargin('margin_left');
1392 Margins.Right := ReadMargin('margin_right');
1393 Margins.Top := ReadMargin('margin_top');
1394 Margins.Bottom := ReadMargin('margin_bottom');
1395 end;
1396 end;
1397 Registry.Free;
1398 end;
1399 except
1400
1401 end;
1402end;
1403
1404function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): string;
1405begin
1406 if Measure <> RuntimeMeasure then
1407 begin
1408 if RuntimeMeasure = mMetric then
1409 Result := FloatToStr(M * InchToMetric)
1410 else
1411 Result := FloatToStr(M / InchToMetric);
1412 end
1413 else
1414 Result := FloatToStr(M);
1415end;
1416
1417procedure RestorePrintValues;
1418var
1419 Reg: TRegistry;
1420begin
1421 Reg := TRegistry.Create;
1422 try
1423 with Reg do
1424 begin
1425 RootKey := HKEY_CURRENT_USER;
1426 if OpenKey('Software\Microsoft\Internet Explorer\PageSetup', True) then
1427 begin
1428 WriteString('header', '&w&bPage &p of &P');
1429 WriteString('footer', '&u&b&d');
1430 WriteString('margin_left', '0.750000');
1431 WriteString('margin_right', '0.750000');
1432 WriteString('margin_top', '0.750000');
1433 WriteString('margin_bottom', '0.750000');
1434 end;
1435 Reg.Free;
1436 end;
1437 except
1438 MessageDlg('Error while writing page print values to the registry!', mtError, [mbOK], 0);
1439 end;
1440end;
1441
1442function OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): Boolean;
1443var
1444 OD: TOpenDialog;
1445begin
1446 OD := TOpenDialog.Create(AOwner);
1447 try
1448 with OD do
1449 begin
1450 Filter := 'Internet Files|*.htm; *.html; *.url; *.mht; *.mhtml; *.php *.asp'
1451 + #10 + #13 + '|Image Files| *.gif;*.bmp;*.ico;*.jpg;*.png;*.wmf; *.emf; '
1452 + #10 + #13 + '|Text & Documents Files| *.txt;*.doc;*.xls;*.dot;'
1453 + #10 + #13 + '|Compressed Files| *.zip;'
1454 + #10 + #13 + '|XML Files| *.xml;'
1455 + #10 + #13 + '|Any Files|*.*';
1456 Options := Options + [ofShowHelp, ofEnableSizing];
1457 Title := 'Browser - Open Dialog';
1458 HelpContext := 0;
1459 Result := Execute;
1460 if Result then
1461 WebBrowser.Go(OD.FileName);
1462 end;
1463 finally
1464 OD.Free;
1465 end;
1466end;
1467
1468function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent; ATitle: string = ''; AFilter: string = ''): string;
1469var
1470 SD: TSaveDialog;
1471begin
1472 SD := TSaveDialog.Create(AOwner);
1473 try
1474 with SD do
1475 begin
1476 if AFilter = '' then
1477 Filter := 'Internet Files|*.htm; *.html;*.mht; *.mhtml; *.php *.asp'
1478 + #10 + #13 + '|Text & Documents Files| *.txt;*.doc;*.xls;*.dot;'
1479 + #10 + #13 + '|XML Files| *.xml;'
1480 + #10 + #13 + '|Any Files|*.*'
1481 else
1482 Filter := AFilter;
1483 Options := Options + [ofShowHelp, ofEnableSizing];
1484 if ATitle = '' then
1485 Title := 'Browser - Save Dialog';
1486 HelpContext := 0;
1487 if Execute then
1488 Result := SD.FileName;
1489 if SD.FileName <> '' then
1490 WebBrowser.SaveToFile(SD.FileName);
1491 end;
1492 finally
1493 SD.Free;
1494 end;
1495end;
1496
1497function SaveDialog(Document: IDispatch): Boolean;
1498var
1499 vaIn, vaOut: OleVariant;
1500begin
1501 Result := InvokeCmd(Document, False, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
1502end;
1503
1504function ShowInternetOptions(Document: IDispatch): Boolean;
1505var
1506 vaIn, vaOut: OleVariant;
1507begin
1508 Result := InvokeCmd(Document, True, HTMLID_OPTIONS, 0, vaIn, vaOut) = S_OK;
1509end;
1510
1511function ShowPageProperties(Document: IDispatch): Boolean;
1512var
1513 vaIn, vaOut: OleVariant;
1514begin // OLECMDID_SHOWPAGEACTIONMENU
1515 Result := InvokeCmd(Document, False, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
1516end;
1517
1518function ShowOrganizeFavorites(Handle: THandle): Boolean;
1519begin
1520 Result := OrganizeFavorite(Handle, GetSpecialFolderPath(Handle, CSIDL_FAVORITES));
1521end;
1522
1523procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
1524begin
1525 SendMessage(Handle, WM_COMMAND, ID_IE_FILE_IMPORTEXPORT, 0);
1526end;
1527
1528function ShowFindDialog(Document: IDispatch): Boolean;
1529var
1530 vaIn, vaOut: OleVariant;
1531begin
1532 Result := InvokeCmd(Document, True, HTMLID_FIND, 0, vaIn, vaOut) = S_OK;
1533end;
1534
1535procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
1536var
1537 k, p: Integer;
1538 path, Source, dest, ext: string;
1539begin
1540 if DocumentLoaded(Document) then
1541 begin
1542 // path := TBrowse4Folder.('Web Browser - Please select a destination folder' + #10 + #13
1543 // + 'for the images', 'Desktop');
1544 MessageDlg(Path, mtCustom, [mbYes, mbAll, mbCancel], 0);
1545 begin
1546 for k := 0 to OleObject.Document.Images.Length - 1 do
1547 begin
1548 Source := OleObject.Document.Images.Item(k).Src;
1549 p := LastDelimiter('.', Source);
1550 ext := UpperCase(System.Copy(Source, p + 1, Length(Source)));
1551 if (ext = 'GIF') or (ext = 'JPG') or (ext = 'BMP') or (ext = 'PNG') then
1552 begin
1553 p := LastDelimiter('/', Source);
1554 dest := path + '/Images' + System.Copy(Source, p + 1, Length(Source));
1555 DownloadFile(Source, dest);
1556 end;
1557 end;
1558 end;
1559 end;
1560end;
1561
1562function ViewPageSourceHtml(Document: IDispatch): Boolean;
1563var
1564 vaIn, vaOut: OleVariant;
1565begin
1566 Result := InvokeCmd(Document, True, HTMLID_VIEWSOURCE, 0, vaIn, vaOut) = S_OK;
1567end;
1568
1569procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);
1570var
1571 sd: TSaveDialog;
1572 textStr: TStringList;
1573begin
1574 if not DocumentLoaded(Document) then Exit;
1575 textstr := TStringList.Create;
1576 try
1577 textStr.Add(VarToStr(OleObject.Document.documentElement.innerText));
1578 begin
1579 sd := TSaveDialog.Create(AOwner);
1580 try
1581 sd.Filter := 'Text file|*.txt|Word file|*.doc';
1582 sd.DefaultExt := 'txt';
1583 sd.FilterIndex := 1;
1584 sd.FileName := 'WebSiteText.txt';
1585 sd.Title := 'Web Site Text';
1586 if sd.Execute then
1587 begin
1588 textStr.SaveToFile(sd.FileName);
1589 end;
1590 finally
1591 sd.Free;
1592 end;
1593 end;
1594 finally
1595 textStr.Free;
1596 end;
1597end;
1598
1599procedure ShellExecuteOpen(const sApplication: string);
1600begin
1601 ShellExecute(Application.Handle, 'open', PChar(sApplication), nil, nil, SW_SHOW);
1602end;
1603
1604procedure OpenOutlookMail;
1605begin
1606 ShellExecuteOpen('outlook.exe');
1607end;
1608
1609procedure OpenOutlookExpressMail;
1610begin
1611 ShellExecuteOpen('msimn.exe');
1612end;
1613
1614procedure OpenEudoraMail;
1615begin
1616 ShellExecuteOpen('eudora.exe');
1617end;
1618
1619procedure OpenRegistryEditor;
1620begin
1621 ShellExecuteOpen('regedit.exe');
1622end;
1623
1624function OpenNewsClient: Boolean;
1625begin
1626 Result := OpenClient('News');
1627end;
1628
1629procedure OpenAddressBook;
1630begin
1631 ShellExecuteOpen('wab.exe');
1632end;
1633
1634function OpenCalendar: Boolean;
1635begin
1636 Result := OpenClient('Calendar');
1637end;
1638
1639function OpenNetMeeting: Boolean;
1640begin
1641 Result := OpenClient('Internet Call');
1642end;
1643
1644procedure DoExploreFolder(Handle: THandle; Path: string);
1645begin
1646 ShellExecute(handle, 'explore', PChar(Path), nil, nil, SW_SHOWNORMAL);
1647end;
1648
1649procedure OpenIEBrowserWithAddress(Handle: THandle);
1650begin
1651 SendMessage(Handle, WM_COMMAND, ID_IE_FILE_NEWWINDOW, 0);
1652end;
1653
1654function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
1655begin
1656 Result := True;
1657 Go(WebBrowser, 'http://lc1.law5.hotmail.passport.com/cgi-bin/login');
1658end;
1659
1660function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
1661begin
1662 Result := True;
1663 Go(WebBrowser, 'http://mail.google.com/mail/');
1664end;
1665
1666function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
1667begin
1668 Result := True;
1669 Go(WebBrowser, 'http://mail.yahoo.com/');
1670end;
1671
1672procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
1673const
1674 GOOGLE_QUERY = 'http://www.google.com/search?ie=ISO-8859-1&q=';
1675var
1676 sQuery: string;
1677begin
1678 sQuery := GOOGLE_QUERY + SearchTerm;
1679 Go(WebBrowser, sQuery);
1680end;
1681
1682procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
1683const
1684 MSN_QUERY = 'http://search.live.com/results.aspx?q=';
1685 MSN_Const = '&FORM=CBPW&first=1&noredir=1';
1686var
1687 sQuery: string;
1688begin
1689 sQuery := MSN_QUERY + SearchTerm + MSN_Const;
1690 Go(WebBrowser, sQuery);
1691end;
1692
1693procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);
1694const
1695 YAHOO_QUERY = 'http://search.yahoo.com/bin/search?p=';
1696var
1697 sQuery: string;
1698begin
1699 sQuery := YAHOO_QUERY + SearchTerm;
1700 WebBrowser.Go(sQuery);
1701end;
1702
1703procedure Go(WebBrowser: TEmbeddedWB; Url: string);
1704var
1705 _URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
1706begin
1707 _URL := Url;
1708 Flags := 0;
1709 TargetFrameName := 0;
1710 Postdata := 0;
1711 Headers := 0;
1712 if (Trim(_URL) <> '') then
1713 WebBrowser.Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
1714end;
1715
1716procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
1717var
1718 _URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
1719begin
1720 _URL := Url + Query;
1721 TargetFrameName := 0;
1722 headers := StringtoVarArray('Content-Type:application/x-www-form-urlencoded'#13#10);
1723 Postdata := StringToVarArray('version=current&name=myname' + #13#10);
1724 Flags := 0;
1725 WebBrowser.Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
1726end;
1727
1728procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
1729
1730 function StrToChr(Str: string; Pos: Integer): Char;
1731 begin
1732 Result := Str[Pos];
1733 end;
1734
1735var
1736 Flags: OleVariant;
1737 HistoryStg: IUrlHistoryStg;
1738begin
1739 Flags := navNoHistory;
1740 WebBrowser.Navigate(WideString(URL), Flags);
1741 Wait(WebBrowser);
1742 HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg;
1743 HistoryStg.DeleteUrl(PWideChar(StrToChr(URL, 0)), 0);
1744end;
1745
1746procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
1747var
1748 VaEmpty, vaPidl: OleVariant;
1749 psa: PSafeArray;
1750 cbData: UINT;
1751begin
1752 cbdata := GetPIDLSize(pidl);
1753 psa := SafeArrayCreateVector(VT_UI1, 0, cbData);
1754 if (psa <> nil) then
1755 begin
1756 CopyMemory(psa.pvData, pidl, cbData);
1757 VariantInit(vaPidl);
1758 TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1;
1759 TVariantArg(vaPidl).parray := psa;
1760 WebBrowser.Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty);
1761 VariantClear(vaPidl);
1762 end;
1763end;
1764
1765function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2;
1766var //by Aladin
1767 OleContainer: IOleContainer;
1768 enum: ActiveX.IEnumUnknown;
1769 unk: IUnknown;
1770 Fetched: PLongint;
1771begin
1772 Result := nil;
1773 Fetched := nil;
1774 if DocumentLoaded(SourceDoc) then
1775 begin
1776 OleContainer := SourceDoc as IOleContainer;
1777 OleContainer.EnumObjects(OLECONTF_EMBEDDINGS or OLECONTF_OTHERS, Enum);
1778 Enum.Skip(FrameNo);
1779 Enum.Next(1, Unk, Fetched);
1780 if Supports(Unk, IWebBrowser2, Result) then //perva 2008/12/10
1781 Result := Unk as IWebBrowser2;
1782 end;
1783end;
1784
1785procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
1786begin
1787 WebBrowser.Go('about:blank');
1788 Wait(WebBrowser);
1789end;
1790
1791procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
1792begin
1793 WebBrowser.SaveToFile(mFileName);
1794 Sleep(800);
1795 with TEwbMapiMail.Create(AOwner) do
1796 begin
1797 try
1798 Subject := mSubject;
1799 Body := mBody;
1800 Attachments.Add(mFileName);
1801 EditDialog := True;
1802 Send;
1803 finally
1804 // Free;
1805 end;
1806 end;
1807end;
1808
1809procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
1810var
1811 Flags: OleVariant;
1812begin
1813 Flags := navNoHistory or navNoReadFromCache or navNoWriteToCache
1814 or navAllowAutosearch or navBrowserBar;
1815 WebBrowser.Navigate(URL, Flags);
1816end;
1817
1818function DownloadFile(SourceFile, TargetFile: string): Boolean;
1819begin
1820 try
1821 Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(TargetFile), 0, nil) = 0;
1822 except
1823 Result := False;
1824 end;
1825end;
1826
1827procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
1828begin
1829 if Notify then
1830 begin
1831 if DownloadFile(SourceFile, TargetFile) then
1832 MessageBox(0, PChar('Downloading: ' + SourceFile + #10 + #13 +
1833 'To: ' + TargetFile + #10 + #13 + 'was successfully finished.'),
1834 PChar('Download successful.'), MB_OK)
1835 else
1836 MessageBox(0, PChar(
1837 'An error ocurred while downloading the file.' + SourceFile),
1838 PChar('Downloading Error!!'), MB_ICONERROR or MB_OK);
1839 end
1840 else
1841 DownloadFile(SourceFile, TargetFile);
1842end;
1843
1844procedure AddToFavorites(URL, Title: string);
1845// The URL parameter must specify a valid URL using HTTP, Secure Hypertext Transfer Protocol (HTTPS),
1846// or File Transfer Protocol (FTP) protocols only. Calling the IShellUIHelper::AddFavorite method with a
1847// file:// or javascript: URL returns E_ACCESSDENIED.
1848const
1849 CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
1850var
1851 ShellUIHelper: ISHellUIHelper;
1852 Url1, Title1: OleVariant;
1853begin
1854 if (Trim(URL) <> '') and (Trim(Title) <> '') then
1855 begin
1856 Title1 := Title;
1857 Url1 := Url;
1858 CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER, IID_IShellUIHelper, ShellUIHelper);
1859 try
1860 ShellUIHelper.AddFavorite(URL1, Title1);
1861 except
1862 end;
1863 end;
1864end;
1865
1866function GetFavoritesPath: string;
1867begin
1868 Result := GetShellFolderPath('Favorites');
1869end;
1870
1871function GetCookiesPath: string;
1872begin
1873 Result := GetShellFolderPath('Cookies');
1874end;
1875
1876function GetHistoryPath: string;
1877begin
1878 Result := GetShellFolderPath('History');
1879end;
1880
1881function GetCachePath: string;
1882begin
1883 Result := GetShellFolderPath('Cache');
1884end;
1885
1886function GetShellFolderPath(FolderName: Widestring): string;
1887const
1888 REG_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
1889var
1890 Reg: TRegistry;
1891begin
1892 Result := '';
1893 Reg := TRegistry.Create(KEY_READ);
1894 with Reg do
1895 try
1896 Rootkey := HKEY_CURRENT_USER;
1897 OpenKey(REG_PATH, False);
1898 if (ValueExists(FolderName)) and not (length(trim(ReadString(FolderName))) = 0) then
1899 Result := ReadString(FolderName);
1900 finally
1901 CloseKey;
1902 Free;
1903 end;
1904end;
1905
1906function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
1907var
1908 exInfo: TShellExecuteInfo;
1909 Buf: PChar;
1910begin
1911 FillChar(exInfo, SizeOf(exInfo), 0);
1912 with exInfo do
1913 begin
1914 cbSize := SizeOf(exInfo);
1915 fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST;
1916 Wnd := CallerHandle;
1917 nShow := SW_SHOWNORMAL;
1918 Buf := StrAlloc(MAX_PATH);
1919 try
1920{$IFDEF UNICODE}
1921 FillChar(Buf^, MAX_PATH * SizeOf(Char), 0);
1922{$ELSE}
1923 FillChar(Buf^, MAX_PATH, 0);
1924{$ENDIF UNICODE}
1925 if SHGetSpecialFolderPath(wnd, Buf, CSIDL, True) then
1926 Result := Buf
1927 else
1928 Result := '';
1929 finally
1930 StrDispose(Buf);
1931 end;
1932 end;
1933end;
1934
1935
1936
1937function GetIEHomePage: string;
1938var
1939 HomePage: string;
1940begin
1941 HomePage := '';
1942 with TRegistry.Create do
1943 try
1944 RootKey := HKEY_CURRENT_USER;
1945 OpenKey('\Software\Microsoft\Internet Explorer\Main', False);
1946 HomePage := ReadString('Start Page');
1947 CloseKey;
1948 finally
1949 Free;
1950 end;
1951 Result := HomePage;
1952end;
1953
1954function GetCachedFileFromURL(ItemUrl: string): string;
1955var
1956 IntCacheInfo: PInternetCacheEntryInfo;
1957 CacheEntry, dwEntrySize, dwLastError: LongWord;
1958begin
1959 dwEntrySize := 0;
1960 FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
1961 GetMem(IntCacheInfo, dwEntrySize);
1962 CacheEntry := FindFirstUrlCacheEntry(nil, IntCacheInfo^, dwEntrySize);
1963 if (CacheEntry <> 0) and (ItemUrl = IntCacheInfo^.lpszSourceUrlName) then
1964 Result := IntCacheInfo^.lpszLocalFileName;
1965 FreeMem(IntCacheInfo);
1966 if Result = '' then
1967 repeat
1968 dwEntrySize := 0;
1969 FindNextUrlCacheEntry(CacheEntry, TInternetCacheEntryInfo(nil^), dwEntrySize);
1970 dwLastError := GetLastError();
1971 if (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
1972 begin
1973 GetMem(IntCacheInfo, dwEntrySize);
1974 if (FindNextUrlCacheEntry(CacheEntry, IntCacheInfo^, dwEntrySize)) then
1975 begin
1976 if ItemUrl = IntCacheInfo^.lpszSourceUrlName then
1977 begin
1978 Result := IntCacheInfo^.lpszLocalFileName;
1979 Break;
1980 end;
1981 end;
1982 FreeMem(IntCacheInfo);
1983 end;
1984 until (dwLastError = ERROR_NO_MORE_ITEMS);
1985end;
1986
1987function OrganizeFavorite(h: THandle; Path: PAnsiChar): Boolean; stdcall;
1988 external 'shdocvw.dll' name 'DoOrganizeFavDlg'; overload;
1989
1990{$IFDEF UNICODE}
1991
1992function OrganizeFavorite(h: THandle; Path: PWideChar): Boolean;
1993begin
1994 Result := OrganizeFavorite(h, PAnsiChar(AnsiString(UnicodeString(Path))));
1995end;
1996
1997{$ENDIF UNICODE}
1998
1999function URLFromFavorites(const dotURL: string): string;
2000begin
2001 Result := '';
2002 with TIniFile.Create(dotURL) do
2003 try
2004 try
2005 Result := ReadString('InternetShortcut', 'URL', '');
2006 except;
2007 end;
2008 finally
2009 Free;
2010 end;
2011end;
2012
2013function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
2014var
2015 Handle: THandle;
2016 Info: IQueryInfo;
2017 W: PWideChar;
2018begin
2019 Result := '';
2020 Handle := 0;
2021 Info := nil;
2022 ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));
2023 if Assigned(Info) then
2024 begin
2025 Info.GetInfoTip(0, w);
2026 Result := W;
2027 end;
2028 Result := Trim(System.Copy(Result, Pos(#10, Result) + 1, length(Result)));
2029end;
2030
2031function GetDefaultBrowserFromRegistry: string;
2032var
2033 Reg: TRegistry;
2034 KeyName: string;
2035begin
2036 Reg := TRegistry.Create;
2037 try
2038 Reg.RootKey := HKEY_CLASSES_ROOT;
2039 KeyName := 'htmlfile\shell\open\command';
2040 if Reg.OpenKey(KeyName, False) then
2041 begin
2042 Result := Reg.ReadString('');
2043 Reg.CloseKey;
2044 end
2045 else
2046 Result := 'No default browser found.';
2047 finally
2048 Reg.Free;
2049 end;
2050end;
2051
2052function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
2053var
2054 WSAResult: Integer;
2055 WSAData: TWSAData;
2056 HostEnt: PHostEnt;
2057 Host: AnsiString;
2058 SockAddr: TSockAddrIn;
2059begin
2060 Result := False;
2061 WSAResult := WSAStartup(MakeWord(1, 1), WSAData);
2062 if WSAResult <> 0 then
2063 begin
2064 WSAErr := 'Winsock is not responding."';
2065 end else
2066 try
2067 if Host = '' then
2068 begin
2069 SetLength(Host, MAX_PATH);
2070 GetHostName(PAnsiChar(Host), MAX_PATH);
2071 end;
2072 HostEnt := GetHostByName(PAnsiChar(Host));
2073 if HostEnt <> nil then
2074 begin
2075 HostName := string(AnsiString(Host));
2076 SetLength(HostName, StrLen(PChar(HostName)));
2077 SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
2078 IPaddr := string(AnsiString(inet_ntoa(SockAddr.sin_addr)));
2079 Result := True;
2080 end else
2081 begin
2082 begin
2083 case WSAGetLastError of
2084 WSANOTINITIALISED: WSAErr := 'WSANotInitialised';
2085 WSAENETDOWN: WSAErr := 'WSAENetDown';
2086 WSAEINPROGRESS: WSAErr := 'WSAEInProgress';
2087 end;
2088 end;
2089 end;
2090 finally
2091 WSACleanup;
2092 end;
2093end;
2094
2095function CreateNewMail: Boolean;
2096var
2097 em_subject, em_body, em_mail: string;
2098begin
2099 em_subject := '';
2100 em_body := '';
2101 em_mail := 'mailto:?subject=' + em_subject + '&body=' + em_body;
2102 Result := ShellExecute(0, 'open', PChar(em_mail), nil, nil, SW_SHOWNORMAL) > 32;
2103end;
2104
2105procedure SendUrlInMail(LocationURL, LocationName: WideString);
2106begin
2107 with TEwbMapiMail.Create(nil) do
2108 begin
2109 try
2110 Subject := LocationName;
2111 Body := LocationURL;
2112 EditDialog := True;
2113 Send;
2114 finally
2115 end;
2116 end;
2117end;
2118
2119
2120function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; aTypeSearch: Integer; const iPos: Integer = 1): IHTMLTxtRange;
2121//by JJM
2122{ aTypeSearch can have the following values
2123(*
21240 Default. Match partial words.
21251 Match backwards.
21262 Match whole words only.
21274 Match case.
2128*)
2129}
2130var
2131 B: Boolean;
2132begin
2133 Wait(WebBrowser);
2134 Result := nil;
2135 try
2136 if DocumentLoaded(Document) then
2137 if Assigned((Document as IHTMLDocument2).body) then
2138 begin
2139 Result := ((Document as IHTMLDocument2).body as IHTMLBodyElement).CreateTextRange;
2140 if Result.moveStart('character', ipos) = S_OK then
2141 B := Result.findText(Value, 1, aTypeSearch)
2142 else
2143 B := Result.findText(Value, iPos, aTypeSearch);
2144 if B then
2145 Result.ScrollIntoView(True)
2146 else
2147 Result := nil;
2148 end;
2149 except
2150 on e: Exception do ;
2151 end;
2152end;
2153
2154function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
2155var
2156 tr: IHTMLTxtRange;
2157begin
2158 Wait(WebBrowser);
2159 Result := False;
2160 try
2161 if Assigned(Webbrowser.Document) then
2162 begin
2163 tr := ((Webbrowser.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
2164 Result := tr.findText(strText, 1, 0);
2165 end;
2166 except
2167 on e: Exception do
2168 ;
2169 end;
2170end;
2171
2172function DoSearchAndHighlight(Document: IDispatch; sFind: string;
2173 Flags: TSearchFlags = []; cbackColor: string = 'yellow'; cForeColor: string = '';
2174 ScrollIntoView: TScrollIntoView = sivNoScroll): Integer;
2175var
2176 Doc2: IHTMLDocument2;
2177 pElem: IHTMLElement;
2178 pBodyelem: IHTMLBodyElement;
2179 pTxtRange: IHTMLTxtRange;
2180 searchdir, searchcase, iMatches: Integer;
2181begin
2182 iMatches := 0;
2183 if (Length(sFind) <> 0) and
2184 Supports(Document, IHTMLDocument2, Doc2) then
2185 begin
2186 searchdir := 1;
2187 searchcase := 0;
2188 //Set up search case
2189 if (sfMatchWholeWord in Flags) and (sfMatchCase in Flags) then
2190 searchcase := 6
2191 else if sfMatchWholeWord in Flags then
2192 searchcase := 2
2193 else if sfMatchCase in Flags then
2194 searchcase := 4;
2195
2196 pElem := Doc2.body;
2197 if (pElem <> nil) then
2198 begin
2199 pBodyelem := pElem as IHTMLBodyElement;
2200 if (pBodyelem <> nil) then
2201 begin
2202 pTxtRange := pBodyelem.createTextRange();
2203 if (pTxtRange <> nil) then
2204 begin
2205 while (pTxtRange.findText(sFind, searchdir, searchcase)) do
2206 begin
2207 if (cbackColor <> '') then
2208 pTxtRange.execCommand('BackColor', False, cbackColor);
2209 if (cForeColor <> '') then
2210 pTxtRange.execCommand('ForeColor', False, cForeColor);
2211 pTxtRange.moveStart('Character', 1);
2212 pTxtRange.moveEnd('Textedit', 1);
2213 iMatches := iMatches + 1;
2214 if (iMatches = 1) and (ScrollIntoView = sivFirstMatch) then
2215 pTxtRange.scrollIntoView(True);
2216 end;
2217 if (iMatches > 1) and (ScrollIntoView = sivLastMatch) then
2218 pTxtRange.scrollIntoView(True);
2219 end;
2220 end;
2221 end;
2222 end;
2223 Result := iMatches;
2224end;
2225
2226procedure SearchAndHighlight(Document: IDispatch;
2227 AText: string; const ACaption, APrompt: string; Flags: TSearchFlags = [];
2228 cbackColor: string = 'yellow'; cForeColor: string = '';
2229 ScrollIntoView: TScrollIntoView = sivNoScroll; ShowInputQuery: Boolean = True); overload;
2230var
2231// tr: IHTMLTxtRange;
2232 FrameCount, i: Integer;
2233 Wb2: IWebBrowser2;
2234begin
2235 if DocumentLoaded(Document) then
2236 begin
2237 if ShowInputQuery then
2238 if not InputQuery(ACaption, APrompt, AText) then Exit;
2239
2240 if Length(aText) = 0 then Exit;
2241 try
2242 FrameCount := FrameCountFromDocument(Document as IHTMLDocument2);
2243 if FrameCount > 0 then
2244 begin
2245 for i := 0 to Pred(FrameCount) do
2246 begin
2247 Wb2 := GetFrameFromDocument(Document as IHTMLDocument2, i);
2248 if Assigned(Wb2) then
2249 SearchAndHighlight(Wb2.Document, AText, ACaption, APrompt, Flags,
2250 cbackColor, cForeColor, ScrollIntoView, False);
2251 end;
2252 end
2253 else
2254 begin
2255 DoSearchAndHighlight(Document, AText, Flags,
2256 cbackColor, cForeColor, ScrollIntoView);
2257 { tr := ((Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
2258 while tr.findText(aText, 1, 0) do
2259 begin
2260 tr.pasteHTML('<span style="background-color: ' + aColor + '; font-weight: bolder;">' +
2261 tr.htmlText + '</span>');
2262 tr.scrollIntoView(True);
2263 end; }
2264 end;
2265 except
2266 end;
2267 end;
2268end;
2269
2270procedure SearchAndHighlight(Document: IDispatch; aText: string; Flags: TSearchFlags = [];
2271 cbackColor: string = 'yellow'; cForeColor: string = '';
2272 ScrollIntoView: TScrollIntoView = sivNoScroll); overload;
2273begin
2274 SearchAndHighlight(Document, '', '', aText, Flags, cbackColor, cForeColor, ScrollIntoView, False);
2275end;
2276
2277{function FillForm(OleObject: Variant; FieldName: string; Value: string): Boolean;
2278var
2279 I, j: Integer;
2280 FormItem: Variant;
2281begin
2282 Result := False;
2283 if not DocumentLoaded(OleObject.Document) or OleObject.Document.all.tags('FORM').Length = 0 then
2284 Exit;
2285 for I := 0 to OleObject.Document.forms.Length - 1 do
2286 begin
2287 FormItem := OleObject.Document.forms.Item(I);
2288 for j := 0 to FormItem.Length - 1 do
2289 begin
2290 try
2291 if (FormItem.Item(j).Name = FieldName) and
2292 (FormItem.Item(j).Name <> 'length') then
2293 begin
2294 FormItem.Item(j).Value := Value;
2295 Result := True;
2296 end;
2297 except
2298 Exit;
2299 end;
2300 end;
2301 end;
2302end; }
2303
2304procedure SetTextAreaValue(Document: IDispatch; sName, sValue: string; Options: TFindOptions);
2305var
2306 Doc2: IHTMLDocument2;
2307 i: Integer;
2308 field: IHTMLElement;
2309 textarea: IHTMLTextAreaElement;
2310begin
2311 if Supports(Document, IHTMLDocument2, Doc2) then
2312 for i := 0 to Doc2.all.length - 1 do
2313 begin
2314 field := Doc2.all.item(i, '') as IHTMLElement;
2315 if Assigned(field) then
2316 begin
2317 if SameText(field.tagName, 'TEXTAREA') then
2318 begin
2319 textarea := field as IHTMLTextAreaElement;
2320 if Assigned(textarea) then
2321 begin
2322 if ((frWholeWord in Options) and (sName = textarea.Name))
2323 or ((Options = []) and (AnsiPos(sName, textarea.Name) <> 0)) then
2324 textarea.Value := sValue;
2325 end;
2326 end;
2327 end;
2328 end;
2329end;
2330
2331function FillForm(Document: IDispatch; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
2332var
2333 Inputs: IHTMLElementCollection;
2334 HTMLElement: IHTMLElement;
2335 TagName: string;
2336 k, iItemNr, iInputCount: Integer;
2337begin
2338 Result := False;
2339 Inputs := IHTMLDocument3(Document).getElementsByName(FieldName);
2340 if Assigned(Inputs) then
2341 begin
2342 try
2343 if ElementNr = -1 then
2344 iInputCount := Inputs.Length
2345 else
2346 iInputCount := ElementNr;
2347
2348 if iInputCount = -1 then iInputCount := 0;
2349
2350 for k := 0 to iInputCount - 1 do
2351 begin
2352 if ElementNr = -1 then
2353 iItemNr := k
2354 else
2355 iItemNr := ElementNr;
2356
2357 HTMLElement := Inputs.item(iItemNr, '') as IHTMLElement;
2358 if Assigned(HTMLElement) then
2359 begin
2360 TagName := AnsiUpperCase(HTMLElement.tagName);
2361 if TagName = 'INPUT' then
2362 begin
2363 (HTMLElement as IHTMLInputElement).Value := FieldValue;
2364 Result := True;
2365 Exit;
2366 end
2367 else if TagName = 'SELECT' then
2368 begin
2369 (HTMLElement as IHTMLSelectElement).Value := FieldValue;
2370 Result := True;
2371 Exit;
2372 end
2373 else if TagName = 'TEXTAREA' then
2374 begin
2375 (HTMLElement as IHTMLTextAreaElement).Value := FieldValue;
2376 Result := True;
2377 Exit;
2378 end;
2379 end;
2380 if ElementNr <> -1 then Exit;
2381 end;
2382 except
2383 end;
2384 end;
2385end;
2386
2387function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
2388var
2389 Doc3: IHTMLDocument3;
2390begin
2391 Result := False;
2392 if Assigned(WebBrowser.Document) and
2393 (Succeeded(WebBrowser.Document.QueryInterface(IHTMLDocument3, Doc3))) then
2394 begin
2395 FillForm(Doc3, FieldName, FieldValue, ElementNr)
2396 end;
2397end;
2398
2399
2400function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; Value: Boolean): Boolean;
2401var
2402 I, j: Integer;
2403 FormItem: Variant;
2404begin
2405 Result := False;
2406 if not DocumentLoaded(WebBrowser.Document) then
2407 if WebBrowser.OleObject.Document.all.tags('FORM').Length = 0 then
2408 if (FieldName = '') and (FieldValue = '') then
2409 for I := 0 to WebBrowser.OleObject.Document.forms.Length - 1 do
2410 begin
2411 FormItem := WebBrowser.OleObject.Document.forms.Item(I);
2412 for j := 0 to FormItem.Length - 1 do
2413 begin
2414 try
2415 if (FormItem.Item(j).Name = FieldName) or (Fieldname = '') then
2416 if (FormItem.Item(j).Value = FieldValue) or (Fieldvalue = '') then
2417 begin
2418 FormItem.Item(j).checked := Value;
2419 Result := True;
2420 end;
2421 except
2422 Continue;
2423 end;
2424 end;
2425 end;
2426end;
2427
2428procedure ClickInputImage(WebBrowser: TEmbeddedWB; ImageURL: string);
2429var
2430 iDoc: IHTMLDocument2;
2431 iDisp: IDispatch;
2432 iColl: IHTMLElementCollection;
2433 InputImage: htmlInputImage;
2434 i: Integer;
2435begin
2436 if WebBrowser.DocumentLoaded then
2437 begin
2438 if Supports(WebBrowser.Document, IHTMLDocument2, iDoc) then
2439 begin
2440 iDisp := iDoc.all.tags('INPUT');
2441 if Assigned(iDisp) then
2442 begin
2443 if Supports(iDisp, IHTMLElementCollection, iColl) then
2444 begin
2445 ImageURL := AnsiUpperCase(ImageURL);
2446 for i := 1 to iColl.Get_length do
2447 begin
2448 iDisp := iColl.item(Pred(i), 0);
2449 if Supports(iDisp, HTMLInputImage, ImageURL) then
2450 begin
2451 if Pos(ImageURL, AnsiUpperCase(InputImage.src)) <> 0 then
2452 begin
2453 InputImage.Click;
2454 end;
2455 end;
2456 end;
2457 end;
2458 end;
2459 end;
2460 end;
2461end;
2462
2463function GetFieldValue(OleObject: Variant; FieldName: string): string;
2464var
2465 I, j: Integer;
2466 FormItem: Variant;
2467begin
2468 Result := '';
2469 if DocumentLoaded(OleObject.Document) then
2470 if OleObject.Document.all.tags('FORM').Length = 0 then
2471 for I := 0 to OleObject.Document.forms.Length - 1 do
2472 begin
2473 FormItem := OleObject.Document.forms.Item(I);
2474 for j := 0 to FormItem.Length - 1 do
2475 begin
2476 try
2477 if FormItem.Item(j).Name = FieldName then
2478 Result := FormItem.Item(j).Value;
2479 except
2480 Continue;
2481 end;
2482 end;
2483 end;
2484end;
2485
2486procedure FillIEFormAndExcecute;
2487var
2488 ShellWindow: IShellWindows;
2489 IWeb: IWebBrowser2;
2490 spDisp: IDispatch;
2491 IDoc1: IHTMLDocument2;
2492 Document: Variant;
2493 k, m: Integer;
2494 ovElements: OleVariant;
2495 i: Integer;
2496begin
2497 ShellWindow := CoShellWindows.Create;
2498 // get the running instance of Internet Explorer
2499 for k := 0 to ShellWindow.Count do
2500 begin
2501 spDisp := ShellWindow.Item(k);
2502 if spDisp = nil then
2503 Continue;
2504 // QueryInterface determines if an interface can be used with an object
2505 spDisp.QueryInterface(IWebBrowser2, IWeb);
2506
2507 if IWeb <> nil then
2508 begin
2509 IWeb.Document.QueryInterface(IHTMLDocument2, iDoc1);
2510 if iDoc1 <> nil then
2511 begin
2512 IWeb := ShellWindow.Item(k) as IWebBrowser2;
2513 begin
2514 Document := IWeb.Document;
2515 // count forms on document and iterate through its forms
2516 for m := 0 to Document.Forms.Length - 1 do
2517 begin
2518 ovElements := Document.Forms.Item(m).Elements;
2519 // iterate through elements
2520 for i := 0 to ovElements.Length - 1 do
2521 begin
2522 // when input fieldname is found, try to fill out
2523 try
2524 if (CompareText(ovElements.Item(i).tagName, 'INPUT') = 0) and
2525 (CompareText(ovElements.Item(i).type, 'text') = 0) then
2526 begin
2527 ovElements.Item(i).Value := 'FindWindow';
2528 end;
2529 except
2530 end;
2531 // when Submit button is found, try to click
2532 try
2533 if (CompareText(ovElements.Item(i).tagName, 'INPUT') = 0) and
2534 (CompareText(ovElements.Item(i).type, 'SUBMIT') = 0) and
2535 (ovElements.Item(i).Value = 'Search') then // Suchen for German
2536 begin
2537 ovElements.Item(i).Click;
2538 end;
2539 except
2540 end;
2541 end;
2542 end;
2543 end;
2544 end;
2545 end;
2546 end;
2547end;
2548
2549procedure ClearHistory;
2550var
2551 HistoryStg: IUrlHistoryStg2;
2552begin
2553 HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
2554 HistoryStg.ClearHistory;
2555end;
2556
2557function DeleteFirstCacheEntry(var H: THandle): DWORD;
2558var
2559 T: PInternetCacheEntryInfo;
2560 D: DWord;
2561begin
2562 Result := S_OK;
2563 H := 0;
2564 D := 0;
2565 FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, nil, @D, nil, nil, nil);
2566 GetMem(T, D);
2567 try
2568 H := FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, T, @D, nil, nil, nil);
2569 if (H = 0) then
2570 Result := GetLastError
2571 else
2572 DeleteUrlCacheEntry(T^.lpszSourceUrlname);
2573 finally
2574 FreeMem(T, D)
2575 end;
2576end;
2577
2578function DeleteNextCacheEntry(H: THandle): DWORD;
2579var
2580 T: PInternetCacheEntryInfo;
2581 D: DWORD;
2582begin
2583 Result := S_OK;
2584 D := 0;
2585 FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);
2586 GetMem(T, D);
2587 try
2588 if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil) then
2589 Result := GetLastError
2590 else
2591 DeleteUrlCacheEntry(T^.lpszSourceUrlname);
2592 finally
2593 FreeMem(T, D)
2594 end;
2595end;
2596
2597procedure ClearCache;
2598var
2599 H: THandle;
2600begin
2601 if DeleteFirstCacheEntry(H) = S_OK then
2602 repeat
2603 until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS;
2604 FindCloseUrlCache(H);
2605end;
2606
2607procedure ClearTypedUrls;
2608begin
2609 with TRegistry.Create do
2610 try
2611 RootKey := HKEY_CURRENT_USER;
2612 DeleteKey('Software\Microsoft\Internet Explorer\TypedURLs');
2613 finally
2614 Free;
2615 end;
2616end;
2617
2618function CheckOnlineStatus: Boolean;
2619var
2620 dwConnectionTypes: Integer;
2621begin
2622 Result := False;
2623 try
2624 dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN + INTERNET_CONNECTION_PROXY;
2625 Result := InternetGetConnectedState(@dwConnectionTypes, 0);
2626 except
2627 end;
2628end;
2629
2630procedure SetGlobalOffline(Value: Boolean);
2631const
2632 INTERNET_STATE_DISCONNECTED_BY_USER = $10;
2633 ISO_FORCE_DISCONNECTED = $1;
2634 INTERNET_STATE_CONNECTED = $1;
2635var
2636 ci: TInternetConnectedInfo;
2637 dwSize: DWORD;
2638begin
2639 dwSize := SizeOf(ci);
2640 if Value then
2641 begin
2642 ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
2643 ci.dwFlags := ISO_FORCE_DISCONNECTED;
2644 end else
2645 begin
2646 ci.dwFlags := 0;
2647 ci.dwConnectedState := INTERNET_STATE_CONNECTED;
2648 end;
2649 InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, dwSize);
2650end;
2651
2652procedure WorkOffline();
2653begin
2654 SetGlobalOffline(False);
2655end;
2656
2657procedure WorkOnline();
2658begin
2659 SetGlobalOffline(True);
2660end;
2661
2662function IsGlobalOffline: Boolean;
2663var
2664 dwState: DWORD;
2665 dwSize: DWORD;
2666begin
2667 dwState := 0;
2668 dwSize := SizeOf(dwState);
2669 Result := False;
2670 if (InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwState, dwSize)) then
2671 Result := ((dwState and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0);
2672end;
2673
2674function GetTLDFromHost(Host: string): string;
2675var
2676 i, Dots: Integer;
2677begin
2678 Dots := 0;
2679 for i := Length(Host) downto 1 do
2680 begin
2681 if Copy(Host, i, 1) = '.' then
2682 Inc(Dots);
2683 if Dots = 2 then
2684 break;
2685 Result := Copy(Host, i, 1) + Result;
2686 end;
2687end;
2688
2689function CheckIfInRestricredList(const Host: string; SecureSite: Boolean): Boolean;
2690const
2691 Path = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\';
2692var
2693 TLD: string;
2694begin // todo: check for IPs IN RANGES
2695 Result := False;
2696 TLD := GetTLDFromHost(Host);
2697 with TRegistry.Create(KEY_READ) do
2698 begin
2699 try
2700 RootKey := HKEY_CURRENT_USER;
2701 if not OpenKey(Path + 'Domains' + '\' + TLD + '\' +
2702 Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then
2703 begin
2704 CloseKey;
2705 if not OpenKey(Path + 'EscDomains' + '\' + TLD + '\' +
2706 Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then // found on IE6, W2003
2707 begin
2708 CloseKey;
2709 Exit;
2710 end;
2711 end;
2712 if SecureSite then
2713 Result := ReadInteger('https') = 4
2714 else
2715 Result := ReadInteger('http') = 4
2716 finally
2717 CloseKey;
2718 Free;
2719 end;
2720 end;
2721end;
2722
2723function CheckIfInTrustedList(const Host: string; SecureSite: Boolean): Boolean;
2724const
2725 Path = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\';
2726var
2727 TLD: string;
2728begin // todo: check for IPs in RANGES
2729 Result := False;
2730 TLD := GetTLDFromHost(Host);
2731 with TRegistry.Create(KEY_READ) do
2732 begin
2733 try
2734 RootKey := HKEY_CURRENT_USER;
2735 if not OpenKey(Path + 'Domains' + '\' + TLD + '\' +
2736 Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then
2737 begin
2738 CloseKey;
2739 if not OpenKey(Path + 'EscDomains' + '\' + TLD + '\' +
2740 Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then // found on IE6, W2003
2741 begin
2742 CloseKey;
2743 Exit;
2744 end;
2745 end;
2746 if SecureSite then
2747 Result := ReadInteger('https') = 2
2748 else
2749 Result := ReadInteger('http') = 2
2750 finally
2751 CloseKey;
2752 Free;
2753 end;
2754 end;
2755end;
2756
2757procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
2758const
2759 REG_PATH = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains';
2760var
2761 Reg: TRegistryIniFile;
2762begin
2763 if AnsiPos('HTTPS', AnsiUpperCase(URL)) = 0 then
2764 MessageDlg('Only sites with https:// prefix (secured sites) can be added to the trusted sites list zone!', mtError, [mbOK], 0)
2765 else
2766 begin
2767 try
2768 Reg := TRegistryIniFile.Create(REG_PATH);
2769 try
2770 Reg.WriteInteger(URL, 'https', (2));
2771 finally
2772 Reg.Free;
2773 end;
2774 except
2775 end;
2776 end;
2777end;
2778
2779procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
2780const
2781 REG_PATH = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains';
2782var
2783 st: string;
2784 I: Integer;
2785 Reg: TRegistryIniFile;
2786begin
2787 I := LastDelimiter(':', Url) + 2;
2788 st := Copy(Url, I + 1, MaxInt);
2789 if AnsiPos('www', st) > 0 then
2790 begin
2791 I := 4;
2792 st := Copy(st, I + 1, MaxInt);
2793 end;
2794 try
2795 Reg := TRegistryIniFile.Create(REG_PATH);
2796 try
2797 Reg.WriteInteger(st, '*', (4));
2798 finally
2799 Reg.Free;
2800 end;
2801 except
2802 end;
2803end;
2804
2805
2806function GetZoneAttributes(const URL: string): TZoneAttributes;
2807var
2808 dwZone: Cardinal;
2809 ZoneAttr: TZoneAttributes;
2810var
2811 ZoneManager: IInternetZoneManager;
2812 SecManager: IInternetSecurityManager;
2813begin
2814 ZeroMemory(@ZoneAttr, SizeOf(TZoneAttributes));
2815 if CoInternetCreateSecuritymanager(nil, SecManager, 0) = S_OK then
2816 if CoInternetCreateZoneManager(nil, ZoneManager, 0) = S_OK then
2817 begin
2818 SecManager.MapUrlToZone(PWideChar(WideString(URL)), dwZone, 0);
2819 ZoneManager.GetZoneAttributes(dwZone, Result);
2820 end;
2821end;
2822
2823function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
2824var
2825 ZoneAttr: TZoneAttributes;
2826 ZoneIcon: TIcon;
2827begin
2828 ZoneAttr := GetZoneAttributes(LocationURL);
2829 ZoneIcon := TIcon.Create;
2830 try
2831 GetZoneIcon(ZoneAttr.szIconPath, ZoneIcon);
2832 Caption := ZoneAttr.szDisplayName;
2833 Hint := ZoneAttr.szDisplayName;
2834 Forms.Application.Icon := ZoneIcon;
2835 finally
2836 ZoneIcon.Free;
2837 end;
2838 Result := True;
2839end;
2840
2841procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
2842var
2843 FName, ImageName: string;
2844 h: hInst;
2845begin
2846 FName := Copy(IconPath, 1, Pos('#', IconPath) - 1);
2847 ImageName := Copy(IconPath, Pos('#', IconPath), Length(IconPath));
2848 h := LoadLibrary(PChar(FName));
2849 try
2850 if h <> 0 then
2851 Icon.Handle := LoadImage(h, PChar(ImageName), IMAGE_ICON, 16, 16, 0);
2852 finally
2853 FreeLibrary(h);
2854 end;
2855end;
2856
2857function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;
2858var
2859 ZoneAttr: TZoneAttributes;
2860begin
2861 Assert(Icon <> nil);
2862 ZoneAttr := GetZoneAttributes(LocationURL);
2863 try
2864 try
2865 GetZoneIcon(ZoneAttr.szIconPath, Icon);
2866 ZoneName := ZoneAttr.szDisplayName;
2867 ZoneDescription := ZoneAttr.szDescription;
2868 Result := True;
2869 except
2870 Result := False;
2871 end;
2872 finally
2873 end;
2874end;
2875
2876function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
2877begin
2878 Result := False;
2879 if (Pos('https://', LocationURL) > 0) then
2880 begin
2881 if OleObject.Document.Location.Protocol = 'https:' then
2882 begin
2883 SSLName := 'SSL';
2884 SSLDescription := 'It is a secure web page.';
2885 Result := True;
2886 end;
2887 end
2888 else
2889 begin
2890 SSLName := 'None';
2891 SSLDescription := 'The page is not secured.';
2892 Result := False;
2893 end
2894end;
2895
2896function SetProxy(UserAgent, Address: string): Boolean; // mladen
2897var
2898 list: INTERNET_PER_CONN_OPTION_LIST;
2899 dwBufSize: DWORD;
2900 hInternet: Pointer;
2901 Options: array[1..3] of INTERNET_PER_CONN_OPTION;
2902begin
2903 Result := False;
2904 dwBufSize := SizeOf(list);
2905 list.dwSize := SizeOf(list);
2906 list.pszConnection := nil;
2907 list.dwOptionCount := High(Options); // the highest index of the array (in this case 3)
2908 Options[1].dwOption := INTERNET_PER_CONN_FLAGS;
2909 Options[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
2910 Options[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
2911 Options[2].Value.pszValue := PAnsiChar(AnsiString(Address));
2912 Options[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
2913 Options[3].Value.pszValue := '<local>';
2914 list.pOptions := @Options;
2915 hInternet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
2916 if hInternet <> nil then
2917 try
2918 Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
2919 Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
2920 finally
2921 InternetCloseHandle(hInternet)
2922 end;
2923end;
2924
2925function SetProxy(UserAgent, Address, UserName, Password: string; Port: Integer): Boolean;
2926var
2927 list: INTERNET_PER_CONN_OPTION_LIST;
2928 dwBufSize: DWORD;
2929 hInternet, hInternetConnect: Pointer;
2930 Options: array[1..3] of INTERNET_PER_CONN_OPTION;
2931begin
2932 Result := False;
2933 dwBufSize := SizeOf(list);
2934 list.dwSize := SizeOf(list);
2935 list.pszConnection := nil;
2936 list.dwOptionCount := High(Options);
2937 Options[1].dwOption := INTERNET_PER_CONN_FLAGS;
2938 Options[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
2939 Options[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
2940 Options[2].Value.pszValue := PAnsiChar(AnsiString(Address));
2941 Options[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
2942 Options[3].Value.pszValue := '<local>';
2943 list.pOptions := @Options;
2944 hInternet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
2945 if hInternet <> nil then
2946 try
2947 hInternetConnect := InternetConnect(hInternet, PChar(Address), Port, PChar(UserName), PChar(Password),
2948 INTERNET_SERVICE_HTTP, 0, 0);
2949 if hInternetConnect <> nil then
2950 begin
2951 Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
2952 Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
2953 end;
2954 finally
2955 InternetCloseHandle(hInternet)
2956 end;
2957end;
2958
2959function SetProxyFromPAC(UserAgent, PACFile: string): Boolean;
2960var
2961 list: INTERNET_PER_CONN_OPTION_LIST;
2962 dwBufSize: DWORD;
2963 hInternet: Pointer;
2964 Options: array[1..2] of INTERNET_PER_CONN_OPTION;
2965begin
2966 Result := False;
2967 dwBufSize := SizeOf(list);
2968 list.dwSize := SizeOf(list);
2969 list.pszConnection := nil;
2970 list.dwOptionCount := High(Options);
2971 Options[1].dwOption := INTERNET_PER_CONN_AUTOCONFIG_URL;
2972 Options[1].Value.pszValue := PAnsiChar(AnsiString(PacFile));
2973 Options[2].dwOption := INTERNET_PER_CONN_FLAGS;
2974 Options[2].Value.dwValue := PROXY_TYPE_AUTO_PROXY_URL;
2975 list.dwOptionCount := 2;
2976 list.dwOptionError := 0;
2977 list.pOptions := @Options;
2978 hInternet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
2979 if hInternet <> nil then
2980 try
2981 Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
2982 Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
2983 finally
2984 InternetCloseHandle(hInternet)
2985 end;
2986end;
2987
2988function RemoveProxy(): Boolean;
2989var
2990 list: INTERNET_PER_CONN_OPTION_LIST;
2991 dwBufSize: DWORD;
2992 hInternet: Pointer;
2993 Options: array[1..3] of INTERNET_PER_CONN_OPTION;
2994begin
2995 Result := False;
2996 dwBufSize := SizeOf(list);
2997 list.dwSize := SizeOf(list);
2998 list.pszConnection := nil;
2999 list.dwOptionCount := High(Options);
3000 Options[1].dwOption := INTERNET_PER_CONN_FLAGS;
3001 Options[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
3002 Options[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
3003 Options[2].Value.pszValue := PAnsiChar('');
3004 Options[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
3005 Options[3].Value.pszValue := '<local>';
3006 list.pOptions := @Options;
3007 hInternet := InternetOpen(PChar(''), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
3008 if hInternet <> nil then
3009 try
3010 InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
3011 InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
3012 Result := True;
3013 finally
3014 InternetCloseHandle(hInternet)
3015 end;
3016end;
3017
3018procedure RemoveUserAgent(UserAgent: string);
3019var
3020 reg: TRegistry;
3021begin
3022 Reg := TRegistry.Create;
3023 with Reg do
3024 begin
3025 RootKey := HKEY_CURRENT_USER;
3026 try
3027 if OpenKey(USER_AGENT_PATH, False)
3028 then
3029 DeleteValue(UserAgent);
3030 finally
3031 CloseKey;
3032 Free;
3033 end;
3034 end;
3035end;
3036
3037var
3038 MimeFactory, NSFactory: IClassFactory;
3039 MimeInternetSession, NSInternetSession: IInternetSession;
3040
3041function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
3042begin
3043 CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory);
3044 CoInternetGetSession(0, MimeInternetSession, 0);
3045 Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME);
3046end;
3047
3048function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
3049begin
3050 Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME);
3051end;
3052
3053function RegisterNameSpace(clsid: TGUID): HRESULT;
3054begin
3055 CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory);
3056 CoInternetGetSession(0, NSInternetSession, 0);
3057 Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0);
3058end;
3059
3060function UnregisterNameSpace: HRESULT;
3061begin
3062 Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http');
3063end;
3064
3065procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
3066var
3067 ws: Integer;
3068 RegPath: string;
3069begin
3070 with TRegistry.Create do
3071 begin
3072 RootKey := HKEY_LOCAL_MACHINE;
3073 RegPath := 'SOFTWARE\' + Forms.Application.Title + '\FormSize';
3074 if OpenKey(RegPath, False) then
3075 try
3076 with Forms.Application.MainForm do
3077 begin
3078 Left := ReadInteger('Left');
3079 Top := ReadInteger('Top');
3080 Width := ReadInteger('Width');
3081 Height := ReadInteger('Height');
3082 ws := ReadInteger('WindowState');
3083 case ws of
3084 0: WindowState := wsNormal;
3085 1: WindowState := wsMinimized;
3086 2: WindowState := wsMaximized;
3087 end;
3088 end;
3089 except
3090 end;
3091 CloseKey;
3092 Free;
3093 end;
3094end;
3095
3096procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
3097var
3098 RegPath: string;
3099begin
3100 with TRegistry.Create do
3101 begin
3102 RootKey := HKEY_LOCAL_MACHINE;
3103 RegPath := 'SOFTWARE\' + Forms.Application.Title + '\FormSize';
3104 if OpenKey(RegPath, True) then
3105 try
3106 with Forms.Application.MainForm do
3107 begin
3108 WriteInteger('Top', Top);
3109 WriteInteger('Left', Left);
3110 WriteInteger('Width', Width);
3111 WriteInteger('Height', Height);
3112 with Forms.Application.MainForm do
3113 case WindowState of
3114 wsNormal: WriteInteger('WindowState', 0);
3115 wsMinimized: WriteInteger('WindowState', 0);
3116 wsMaximized: WriteInteger('WindowState', 0);
3117 end;
3118 end;
3119 CloseKey;
3120 Free;
3121 except
3122 end;
3123 end;
3124end;
3125
3126procedure Wait(WebBrowser: TEmbeddedWB);
3127begin
3128 WebBrowser.Wait;
3129end;
3130
3131function InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant): HRESULT;
3132var
3133 CmdTarget: IOleCommandTarget;
3134 PtrGUID: PGUID;
3135begin
3136 // New(PtrGUID);
3137 Result := S_FALSE;
3138 if InvokeIE then
3139 begin
3140 New(PtrGUID);
3141 PtrGUID^ := CLSID_WebBrowser;
3142 end
3143 else
3144 PtrGuid := PGUID(nil);
3145 if DocumentLoaded(Document) then
3146 try
3147 Document.QueryInterface(IOleCommandTarget, CmdTarget);
3148 if CmdTarget <> nil then
3149 try
3150 Result := CmdTarget.Exec(PtrGuid, Value1, Value2, vaIn, vaOut);
3151 finally
3152 CmdTarget._Release;
3153 end;
3154 except
3155 end;
3156 Dispose(PtrGUID);
3157end;
3158
3159function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;
3160begin
3161 Result := WebBrowser.GetIEHandle(WebBrowser, ClassName);
3162end;
3163
3164procedure ShowIEVersionInfo(Handle: THandle);
3165begin
3166 SendMessage(Handle, WM_COMMAND, ID_IE_HELP_VERSIONINFO, 0);
3167end;
3168
3169procedure SetNewHomePage(HomePage: string);
3170begin
3171 with TRegistry.Create do
3172 begin
3173 try
3174 OpenKey('\Software\Microsoft\Internet Explorer\Main', True);
3175 WriteString('Start Page', HomePage);
3176 CloseKey;
3177 finally
3178 Free;
3179 end;
3180 end;
3181end;
3182
3183function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
3184begin
3185 Result := False;
3186 with TRegistry.Create do
3187 begin
3188 LastVisitedPage := '';
3189 RootKey := HKEY_LOCAL_MACHINE;
3190 try
3191 if OpenKey('SOFTWARE\' + Forms.Application.Title + '\WebPages', False) then
3192 begin
3193 LastVisitedPage := ReadString('LastVisitedPage');
3194 CloseKey;
3195 Result := (LastVisitedPage <> '') and (AnsiPos('.', LastVisitedPage) > 0);
3196 end;
3197 finally
3198 Free;
3199 end;
3200 end;
3201end;
3202
3203function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;
3204var
3205 RegPath: string;
3206begin
3207 Result := False;
3208 with TRegistry.Create do
3209 begin
3210 RootKey := HKEY_LOCAL_MACHINE;
3211 RegPath := 'SOFTWARE\' + Forms.Application.Title + '\WebPages';
3212 if OpenKey(RegPath, False) then
3213 try
3214 DeleteKey('LastVisitedPage');
3215 except
3216 end;
3217 Free;
3218 end;
3219 with TRegIniFile.Create do
3220 begin
3221 RootKey := HKEY_LOCAL_MACHINE;
3222 RegPath := 'SOFTWARE\' + Forms.Application.Title;
3223 if OpenKey(RegPath, True) then
3224 begin
3225 try
3226 WriteString('WebPages', 'LastVisitedPage', LocationURL);
3227 Result := True;
3228 except
3229 end;
3230 CloseKey;
3231 end;
3232 Free;
3233 end;
3234end;
3235
3236procedure CreateDesktopShortcut(Handle: THandle);
3237begin
3238 SendMessage(Handle, WM_COMMAND, ID_IE_FILE_SENDDESKTOPSHORTCUT, 0);
3239end;
3240
3241procedure DisableNavSound(bDisable: Boolean);
3242const
3243 REG_PATH = 'AppEvents\Schemes\Apps\Explorer\Navigating\';
3244var
3245 Reg: TRegIniFile;
3246begin
3247 Reg := TRegIniFile.Create;
3248 with Reg do
3249 begin
3250 RootKey := HKEY_CURRENT_USER;
3251 try
3252 if bDisable then
3253 begin
3254 if KeyExists(REG_PATH + '.Current') then
3255 if OpenKey(REG_PATH, True) then
3256 MoveKey('.Current', 'Old_Current', True);
3257 end
3258 else
3259 begin
3260 if KeyExists(REG_PATH + 'Old_Current') then
3261 if OpenKey(REG_PATH, False) then
3262 MoveKey('Old_Current', '.Current', True);
3263 end;
3264 finally
3265 CloseKey;
3266 Free;
3267 end;
3268 end;
3269end;
3270
3271function WBExecScript(
3272 TargetObj: IDispatch;
3273 MethodName: string;
3274 ParamValues: array of const): OleVariant;
3275var
3276 wide: WideString;
3277 disps: TDispIDList;
3278 panswer: ^OleVariant;
3279 answer: OleVariant;
3280 dispParams: TDispParams;
3281 aexception: TExcepInfo;
3282 pVarArg: PVariantArgList;
3283 res: HRESULT;
3284 ParamCount, i: Integer;
3285begin
3286 Result := False;
3287
3288 // prepare for function call
3289 ParamCount := High(ParamValues) + 1;
3290 wide := MethodName;
3291 pVarArg := nil;
3292 if ParamCount > 0 then
3293 GetMem(pVarArg, ParamCount * sizeof(TVariantArg));
3294
3295 try
3296 // get dispid of requested method
3297 if not Succeeded(TargetObj.GetIDsOfNames(GUID_NULL, @wide, 1, 0, @disps)) then
3298 raise Exception.Create('This object does not support this method');
3299 pAnswer := @answer;
3300
3301 // prepare parameters
3302 for i := 0 to Pred(ParamCount) do
3303 begin
3304 case ParamValues[ParamCount - 1 - i].VType of
3305 vtBoolean: begin
3306 pVarArg^[i].vt := VT_BOOL;
3307 pVarArg^[i].vbool := ParamValues[ParamCount - 1 - i].VBoolean;
3308 end;
3309 vtCurrency: begin
3310 pVarArg^[i].vt := VT_CY;
3311 pVarArg^[i].cyVal := ParamValues[ParamCount - 1 - i].VCurrency^;
3312 end;
3313 vtInt64: begin
3314 pVarArg^[i].vt := VT_I8;
3315 PInt64(@pVarArg^[i].cyVal)^ := ParamValues[ParamCount - 1 - i].VInt64^;
3316 end;
3317 vtInteger: begin
3318 pVarArg^[i].vt := VT_I4;
3319 pVarArg^[i].lVal := ParamValues[ParamCount - 1 - i].VInteger;
3320 end;
3321 vtExtended: begin
3322 pVarArg^[i].vt := VT_R8;
3323 pVarArg^[i].dblVal := ParamValues[ParamCount - 1 - i].VExtended^;
3324 end;
3325 vtVariant: begin
3326 pVarArg^[i].vt := VT_BYREF or VT_VARIANT;
3327 pVarArg^[i].pvarVal := ParamValues[ParamCount - 1 - i].VVariant;
3328 end;
3329 vtChar: begin
3330 {pVarArg^[i].vt := VT_I1;
3331 pVarArg^[i].cVal := ParamValues[ParamCount - 1 - i].VChar;}
3332 pVarArg^[i].vt := VT_BSTR;
3333 pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VChar));
3334 end;
3335 vtWideChar: begin
3336 pVarArg^[i].vt := VT_BSTR;
3337 pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VWideChar));
3338 end;
3339 vtPChar: begin
3340 pVarArg^[i].vt := VT_BSTR;
3341 pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VPChar));
3342 end;
3343 vtPWideChar: begin
3344 pVarArg^[i].vt := VT_BSTR;
3345 pVarArg^[i].bstrVal := ParamValues[ParamCount - 1 - i].VPWideChar;
3346 end;
3347 vtAnsiString: begin
3348 pVarArg^[i].vt := VT_BSTR;
3349 pVarArg^[i].bstrVal := PWideChar(WideString(PAnsiChar(ParamValues[ParamCount - 1 - i].VAnsiString)));
3350 end;
3351 vtWideString: begin
3352 pVarArg^[i].vt := VT_BSTR;
3353 pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VWideString));
3354 end;
3355 vtString: begin
3356 pVarArg^[i].vt := VT_BSTR;
3357 pVarArg^[i].bstrVal := PWideChar(WideString(PAnsiChar(ParamValues[ParamCount - 1 - i].VString)));
3358 end;
3359{$IFDEF UNICODE}
3360 vtUnicodeString: begin
3361 pVarArg^[i].vt := VT_BSTR;
3362 pVarArg^[i].bstrVal := PWideChar(UnicodeString(ParamValues[ParamCount - 1 - i].VUnicodeString));
3363 end;
3364{$ENDIF UNICODE}
3365 else
3366 raise Exception.CreateFmt('Unsupported type for Parameter with Index %d', [i]);
3367 end;
3368 end;
3369
3370 // prepare dispatch parameters
3371 dispparams.rgvarg := pVarArg;
3372 dispparams.rgdispidNamedArgs := nil;
3373 dispparams.cArgs := ParamCount;
3374 dispparams.cNamedArgs := 0;
3375
3376 // make IDispatch call
3377 res := TargetObj.Invoke(disps[0],
3378 GUID_NULL, 0, DISPATCH_METHOD or DISPATCH_PROPERTYGET,
3379 dispParams, pAnswer, @aexception, nil);
3380
3381 // check the Result
3382 if res <> 0 then
3383 raise Exception.CreateFmt(
3384 'Method call unsuccessful. %s (%s).',
3385 [string(aexception.bstrDescription), string(aexception.bstrSource)]);
3386
3387 // return the Result
3388 Result := answer;
3389 finally
3390 if ParamCount > 0 then
3391 FreeMem(pVarArg, ParamCount * sizeof(TVariantArg));
3392 end;
3393end;
3394
3395function ExecScriptEx(WebBrowser: TEmbeddedWB; MethodName: string; ParamValues: array of const): OleVariant;
3396var
3397 doc: IHTMLDocument2;
3398 dScript: IDispatch;
3399begin
3400 if WebBrowser.DocumentLoaded(Doc) then
3401 begin
3402 dScript := doc.Script;
3403 if Assigned(dScript) then
3404 Result := WBExecScript(DScript, MethodName, ParamValues);
3405 end;
3406end;
3407
3408procedure ExecScript(WebBrowser: TEmbeddedWB; sExpression, sLanguage: string);
3409// e.g. sLanguage = 'JavaScript';
3410var
3411 Doc: IHTMLDocument2; // current HTML document
3412 HTMLWin: IHTMLWindow2; // parent window of current HTML document
3413begin
3414 if WebBrowser.DocumentLoaded(Doc) then
3415 begin
3416 HTMLWin := Doc.parentWindow;
3417 if Assigned(HTMLWin) then
3418 begin
3419 try
3420 HTMLWin.execScript(sExpression, sLanguage);
3421 except
3422 end;
3423 end;
3424 end;
3425end;
3426
3427//To Add--------------------------------------------------
3428
3429function URLFromShortcut(const dotURL: string): string;
3430begin
3431 Result := '';
3432 with TIniFile.Create(dotURL) do
3433 try
3434 Result := ReadString('InternetShortcut', 'URL', '');
3435 finally
3436 Free;
3437 end;
3438end;
3439
3440function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
3441var
3442 Handle: THandle;
3443 Info: IQueryInfo;
3444 W: PWideChar;
3445begin
3446 Handle := 0;
3447 Info := nil;
3448 Result := '';
3449 ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));
3450 if Assigned(Info) then
3451 begin
3452 Info.GetInfoTip(0, w);
3453 Result := W;
3454 end;
3455 Result := Trim(Copy(Result, Pos(#10, Result) + 1, length(Result)));
3456end;
3457
3458function StringToVarArray(const S: string): Variant;
3459begin
3460 Result := Unassigned;
3461 if S <> '' then
3462 begin
3463 Result := VarArrayCreate([0, Length(S) - 1], varByte);
3464 Move(Pointer(S)^, VarArrayLock(Result)^, Length(S));
3465 VarArrayUnlock(Result);
3466 end;
3467end;
3468
3469function VarArrayToString(const V: Variant): string;
3470var
3471 i, j: Integer;
3472begin
3473 if VarIsArray(V) then
3474 for i := 0 to VarArrayHighBound(V, 1) do
3475 begin
3476 j := V[i];
3477 Result := Result + chr(j);
3478 end;
3479end;
3480
3481function Encode(const S: string): string;
3482var
3483 I: Integer;
3484 Hex: string;
3485begin
3486 for I := 1 to Length(S) do
3487 case S[i] of
3488 ' ': Result := Result + '+';
3489 'A'..'Z', 'a'..'z', '*', '@', '.', '_', '-',
3490 '0'..'9', '$', '!', '''', '(', ')':
3491 Result := Result + s[i];
3492 else
3493 begin
3494 Hex := IntToHex(ord(S[i]), 2);
3495 if Length(Hex) = 2 then
3496 Result := Result + '%' + Hex
3497 else
3498 Result := Result + '%0' + hex;
3499 end;
3500 end;
3501end;
3502
3503function IE5_Installed: Boolean;
3504var
3505 Reg: TRegistry;
3506 S: string;
3507begin
3508 Reg := TRegistry.Create;
3509 with Reg do
3510 begin
3511 RootKey := HKEY_LOCAL_MACHINE;
3512 OpenKey('Software\Microsoft\Internet Explorer', False);
3513 if ValueExists('Version') then
3514 S := ReadString('Version')
3515 else
3516 S := '0';
3517 CloseKey;
3518 Free;
3519 end;
3520 Result := (StrToInt(S[1]) > 4);
3521end;
3522
3523function GetIEVersionMajor: Integer;
3524var
3525 i: Integer;
3526 s: string;
3527begin
3528 s := GetIEVersion;
3529 i := Pos('.', s);
3530 Result := -1;
3531 if i <> 0 then
3532 begin
3533 try
3534 Result := StrToInt(Copy(s, 1, Pos('.', s) - 1));
3535 except
3536 Result := -1;
3537 end;
3538 end;
3539end;
3540
3541function GetIEVersion: string;
3542var
3543 SysDir: PChar;
3544 Info: Pointer;
3545 InfoData: Pointer;
3546 InfoSize: LongInt;
3547 Len: DWORD;
3548 FName: Pchar;
3549 SystemDir, Infotype: string;
3550 LangPtr: Pointer;
3551begin
3552 Len := MAX_PATH + 1;
3553 GetMem(SysDir, Len);
3554 try
3555 if Windows.GetSystemDirectory(SysDir, Len) <> 0 then
3556 SystemDir := SysDir;
3557 finally
3558 FreeMem(SysDir);
3559 end;
3560 Result := '';
3561 InfoType := 'FileVersion';
3562 if FileExists(SystemDir + '\ieframe.dll') then
3563 FName := PChar(SystemDir + '\ieframe.dll')
3564 else
3565 FName := PChar(SystemDir + '\shdocvw.dll');
3566 InfoSize := GetFileVersionInfoSize(Fname, Len);
3567 if (InfoSize > 0) then
3568 begin
3569 GetMem(Info, InfoSize);
3570 try
3571 if GetFileVersionInfo(FName, Len, InfoSize, Info) then
3572 begin
3573 Len := 255;
3574 if VerQueryValue(Info, '\VarFileInfo\Translation', LangPtr, Len) then
3575 InfoType := Format('\StringFileInfo\%0.4x%0.4x\%s'#0, [LoWord(LongInt(LangPtr^)),
3576 HiWord(LongInt(LangPtr^)), InfoType]);
3577 if VerQueryValue(Info, Pchar(InfoType), InfoData, len) then
3578{$IFDEF UNICODE}
3579 Result := Trim(PWideChar(InfoData));
3580{$ELSE}
3581 Result := StrPas(PAnsiChar(InfoData));
3582{$ENDIF UNICODE}
3583 end;
3584 finally
3585 FreeMem(Info, InfoSize);
3586 end;
3587 end;
3588end;
3589
3590function ResolveUrlIni(Filename: string): string;
3591var
3592 ini: TiniFile;
3593begin
3594 Result := '';
3595 ini := TIniFile.Create(Filename);
3596 try
3597 Result := ini.ReadString('InternetShortcut', 'URL', '');
3598 finally
3599 ini.Free;
3600 end;
3601end;
3602
3603function ResolveUrlIntShCut(Filename: string): string;
3604var
3605 IURL: IUniformResourceLocator;
3606 PersistFile: IPersistfile;
3607 FName: array[0..MAX_PATH] of WideChar;
3608 p: PChar;
3609begin
3610 if Succeeded(CoCreateInstance(CLSID_InternetShortcut, nil, CLSCTX_INPROC_SERVER,
3611 IID_IUniformResourceLocator, IURL)) then
3612 begin
3613 Persistfile := IUrl as IPersistFile;
3614 StringToWideChar(FileName, FName, MAX_PATH);
3615 PersistFile.Load(FName, STGM_READ);
3616 IUrl.GetUrl(@P);
3617 Result := P;
3618 end;
3619end;
3620
3621function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
3622var
3623 pidlChannel: PItemIDList;
3624 psfDesktop: IShellFolder;
3625 pShellLink: IShellLink;
3626begin
3627 Result := S_FALSE;
3628 if Succeeded(pFolder.GetUIObjectOf(0, 1, pidl, IShellLink, nil, Pointer(pShellLink)))
3629 then
3630 if Succeeded(pShellLink.GetIDList(pidlChannel)) then
3631 if Succeeded(SHGetDesktopFolder(psfDesktop)) then
3632 begin
3633 lpszURL := getDisplayName(psfDesktop, PidlChannel);
3634 Result := S_OK;
3635 end;
3636 DisposePidl(PidlChannel);
3637end;
3638
3639function ResolveLink(const Path: string): string;
3640var
3641 link: IShellLink;
3642 storage: IPersistFile;
3643 filedata: TWin32FindData;
3644 buf: array[0..MAX_PATH] of Char;
3645 widepath: WideString;
3646begin
3647 OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link));
3648 OleCheck(link.QueryInterface(IPersistFile, storage));
3649 widepath := path;
3650 Result := '';
3651 if Succeeded(storage.Load(@widepath[1], STGM_READ)) then
3652 if Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) then
3653 if Succeeded(link.GetPath(buf, SizeOf(buf), filedata, SLGP_UNCPRIORITY)) then
3654 Result := buf;
3655 storage := nil;
3656 link := nil;
3657end;
3658
3659function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
3660var
3661 Flags: UINT;
3662begin
3663 Flags := SFGAO_FOLDER;
3664 ShellFolder.GetAttributesOf(1, ID, Flags);
3665 Result := SFGAO_FOLDER and Flags <> 0;
3666end;
3667
3668function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
3669var
3670 FileInfo: TShFileInfo;
3671begin
3672 SHGetFileInfo(Pchar(ID), 0, FileInfo, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_TYPENAME);
3673 Result := BOOL(fileinfo.szTypeName = ChannelShortcut);
3674end;
3675
3676function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
3677var
3678 Flags: UINT;
3679begin
3680 Flags := SFGAO_FOLDER;
3681 ShellFolder.GetAttributesOf(1, ID, Flags);
3682 if SFGAO_FOLDER and Flags <> 0 then
3683 Result := not isChannel(ChannelShortcut, Shellfolder, id)
3684 else
3685 Result := False;
3686end;
3687
3688function GetImageIndex(pidl: PItemIDList): Integer;
3689var
3690 Flags: UINT;
3691 FileInfo: TSHFileInfo;
3692begin
3693 Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON or SHGFI_SMALLICON;
3694 if SHGetFileInfo(PChar(pidl), 0, FileInfo, SizeOf(TSHFileInfo), Flags) = 0 then
3695 Result := -1
3696 else
3697 Result := FileInfo.iIcon;
3698end;
3699
3700{function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
3701var
3702 StrRet: TStrRet;
3703begin
3704 Result := '';
3705 Folder.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);
3706 case StrRet.uType of
3707 STRRET_CSTR:
3708 SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
3709 STRRET_OFFSET:
3710 Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);
3711 STRRET_WSTR:
3712 Result := StrRet.pOleStr;
3713 end;
3714end; }
3715
3716function GetDisplayName(Folder: IShellFolder; PIDL: PItemIDList): string;
3717var
3718 StrRet: TStrRet;
3719 P: PChar;
3720 Flags: Integer;
3721begin
3722 Result := '';
3723 Flags := SHGDN_NORMAL;
3724 Folder.GetDisplayNameOf(PIDL, Flags, StrRet);
3725 case StrRet.uType of
3726 STRRET_CSTR:
3727 SetString(Result, StrRet.cStr, lStrLenA(StrRet.cStr));
3728 STRRET_OFFSET:
3729 begin
3730 P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
3731 SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
3732 end;
3733 STRRET_WSTR:
3734 Result := StrRet.pOleStr;
3735 end;
3736end;
3737
3738{function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
3739var
3740 StrRet: TStrRet;
3741begin
3742 Folder.GetDisplayNameOf(pidl, SHGDN_FORPARSING, StrRet);
3743 case StrRet.uType of
3744 STRRET_CSTR:
3745 SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
3746 STRRET_OFFSET:
3747 Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);
3748 STRRET_WSTR:
3749 Result := StrRet.pOleStr;
3750 end;
3751end; }
3752
3753function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
3754var
3755 StrRet: TStrRet;
3756 P: PChar;
3757begin
3758 Result := '';
3759 Folder.GetDisplayNameOf(PIDL, SHGDN_FORPARSING, StrRet);
3760 case StrRet.uType of
3761 STRRET_CSTR:
3762 SetString(Result, StrRet.cStr, lStrLenA(StrRet.cStr));
3763 STRRET_OFFSET:
3764 begin
3765 P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
3766 SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
3767 end;
3768 STRRET_WSTR:
3769 Result := StrRet.pOleStr;
3770 end;
3771end;
3772
3773procedure DisposePIDL(ID: PItemIDList);
3774var
3775 Malloc: IMalloc;
3776begin
3777 if ID <> nil then
3778 begin
3779 OLECheck(SHGetMalloc(Malloc));
3780 Malloc.Free(ID);
3781 end;
3782end;
3783
3784function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
3785begin
3786 Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb));
3787 CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));
3788end;
3789
3790function NextPIDL(IDList: PItemIDList): PItemIDList;
3791begin
3792 Result := IDList;
3793 Inc(PAnsiChar(Result), IDList^.mkid.cb);
3794end;
3795
3796function GetPIDLSize(IDList: PItemIDList): Integer;
3797begin
3798 Result := 0;
3799 if Assigned(IDList) then
3800 begin
3801 Result := SizeOf(IDList^.mkid.cb);
3802 while IDList^.mkid.cb <> 0 do
3803 begin
3804 Result := Result + IDList^.mkid.cb;
3805 IDList := NextPIDL(IDList);
3806 end;
3807 end;
3808end;
3809
3810procedure StripLastID(IDList: PItemIDList);
3811var
3812 MarkerID: PItemIDList;
3813begin
3814 MarkerID := IDList;
3815 if Assigned(IDList) then
3816 begin
3817 while IDList.mkid.cb <> 0 do
3818 begin
3819 MarkerID := IDList;
3820 IDList := NextPIDL(IDList);
3821 end;
3822 MarkerID.mkid.cb := 0;
3823 end;
3824end;
3825
3826function CreatePIDL(Size: Integer): PItemIDList;
3827var
3828 Malloc: IMalloc;
3829 HR: HResult;
3830begin
3831 Result := nil;
3832 HR := SHGetMalloc(Malloc);
3833 if Failed(HR) then
3834 Exit;
3835 try
3836 Result := Malloc.Alloc(Size);
3837 if Assigned(Result) then
3838 FillChar(Result^, Size, 0);
3839 finally
3840 end;
3841end;
3842
3843function CopyPIDL(IDList: PItemIDList): PItemIDList;
3844var
3845 Size: Integer;
3846begin
3847 Size := GetPIDLSize(IDList);
3848 Result := CreatePIDL(Size);
3849 if Assigned(Result) then
3850 CopyMemory(Result, IDList, Size);
3851end;
3852
3853function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
3854var
3855 cb1, cb2: Integer;
3856begin
3857 if Assigned(IDList1) then
3858 cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
3859 else
3860 cb1 := 0;
3861 cb2 := GetPIDLSize(IDList2);
3862 Result := CreatePIDL(cb1 + cb2);
3863 if Assigned(Result) then
3864 begin
3865 if Assigned(IDList1) then
3866 CopyMemory(Result, IDList1, cb1);
3867 CopyMemory(PAnsiChar(Result) + cb1, IDList2, cb2);
3868 end;
3869end;
3870
3871function DeleteUrl(Url: PWideChar): HResult;
3872begin
3873 Result := DeleteUrl(Url);
3874end;
3875
3876function GetMailClients: TStrings;
3877var
3878 Reg: TRegistry;
3879 ts: TStrings;
3880 i: Integer;
3881begin
3882 ts := TStringList.Create;
3883 Reg := TRegistry.Create;
3884 with Reg do
3885 begin
3886 RootKey := HKEY_CURRENT_USER;
3887 try
3888 OpenKey(RegMail, False);
3889 if HasSubKeys then
3890 begin
3891 GetKeyNames(ts);
3892 CloseKey;
3893 for i := 0 to ts.Count - 1 do
3894 OpenKey(RegMail + ts.Strings[i], False);
3895 end;
3896 Result := ts;
3897 finally
3898 CloseKey;
3899 Free;
3900 end;
3901 end;
3902end;
3903
3904
3905
3906end.
3907
Note: See TracBrowser for help on using the repository browser.