Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

EWBTools.pas@ 673

Last change on this file since 673 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:
16	THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
17	EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
18	WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
19	YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
20	AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
21	AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
22	OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
23	OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
24	INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
25	OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
26	AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
27	DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
28
29	You may use, change or modify the component under 4 conditions:
30	1. In your website, add a link to "http://www.bsalsa.com"
31	2. In your application, add credits to "Embedded Web Browser"
32	3. Mail me (bsalsa@gmail.com) any code change in the unit
33	for the benefit of the other users.
34	4. Please, consider donation in our web site!
35	{*******************************************************************************}
36
37	unit EwbTools;
38
39	interface
40
41	{$I EWB.inc}
42
43	uses
44	EwbAcc, Windows, Classes, ExtCtrls, ShlObj, Graphics, Dialogs, ActiveX,
45	{$IFDEF DELPHI6_UP}Variants, {$ENDIF}
46	MSHTML_EWB, SHDocVw_EWB, EmbeddedWB, URLMon;
47
48	var
49	PrintingWithOptions: Boolean;
50
51	//Document and Frame
52	function DocumentLoaded(Document: IDispatch): Boolean;
53	procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
54
55	//Html
56	function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
57	function DocumentSourceText(OleObject: Variant; Document: IDispatch): string;
58	function DocumentSource(OleObject: Variant): string;
59	function GetWordAtCursor(const X, Y: Integer; WebBrowser: TEmbeddedWB): string;
60
61	//frames
62	function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
63	function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2; //By Aladin
64	function FrameCount(Document: IDispatch): Longint;
65	function FrameCountFromDocument(SourceDoc: IHTMLDocument2): Integer; //By Aladin
66
67	//Document Operations
68	procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
69	function CMD_Copy(Document: IDispatch): Boolean;
70	function Cmd_Paste(Document: IDispatch): Boolean;
71	function Cmd_Cut(Document: IDispatch): Boolean;
72	function SelectAll(Document: IDispatch): Boolean;
73	function UnSelectAll(Document: IDispatch): Boolean;
74
75	//scroll
76	procedure ScrollToTop(OleObject: Variant);
77	procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
78	procedure ScrollToBottom(Document: IDispatch);
79	procedure ScrollToID(ID: Integer; WebBrowser: TEmbeddedWB);
80	procedure ScrollToIDEx(ID: string; WebBrowser: TEmbeddedWB);
81	procedure GetScrollBarVisibility(WebBrowser: TEmbeddedWB; var HScroll, VScroll: Boolean);
82	function GetScrollBarPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
83
84	// zoom
85	function Zoom(Document: IDispatch; ZoomValue: Integer): Boolean;
86	function ZoomValue(Document: IDispatch): Integer;
87	function ZoomRangeHigh(Document: IDispatch): Integer;
88	function ZoomRangeLow(Document: IDispatch): Integer;
89
90	function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string; Refresh: Boolean = True): Boolean;
91	procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
92	function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
93	function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth, TargetHeight, TargetWidth: Integer): Boolean;
94
95	//View Document Fields/Properties/Images
96	procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
97	procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
98	procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
99	procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);
100
101	//Save
102	function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HRESULT;
103	function SaveDocToStream(Document: IDispatch; var AStream: TStream): HRESULT;
104	function SaveDocToFile(Document: IDispatch; const Fname: string): HRESULT;
105
106	//Printing
107	procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean = False; bCustomHeaderFooter: Boolean = False; Header: string = ''; Footer: string = '');
108	procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
109	procedure PrintPreview(Webbrowser: IWebBrowser2);
110	procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
111	procedure PrintPreviewFromTemplate(const TemplateFileName: string; Document: IDispatch);
112	function PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean): Boolean;
113	procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
114	procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
115	function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): string;
116	procedure RestorePrintValues;
117
118	//Dialogs
119	function OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): Boolean;
120	function SaveDialog(Document: IDispatch): Boolean; overload;
121	function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent; ATitle: string = ''; AFilter: string = ''): string; overload;
122
123	function ShowInternetOptions(Document: IDispatch): Boolean;
124	function ShowPageProperties(Document: IDispatch): Boolean;
125	function ShowOrganizeFavorites(Handle: THandle): Boolean;
126	procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
127	function ShowFindDialog(Document: IDispatch): Boolean;
128	procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
129	function ViewPageSourceHtml(Document: IDispatch): Boolean;
130	procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);
131
132	//Open external programs
133	procedure OpenAddressBook;
134	procedure OpenEudoraMail;
135	procedure OpenOutlookExpressMail;
136	procedure OpenOutlookMail;
137	procedure OpenRegistryEditor;
138	function OpenCalendar: Boolean;
139	function OpenClient(Client: string): Boolean;
140	function OpenNetMeeting: Boolean;
141	function OpenNewsClient: Boolean;
142	procedure DoExploreFolder(Handle: THandle; Path: string);
143	procedure OpenIEBrowserWithAddress(Handle: THandle);
144
145	//Open specific webpages
146	function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
147	function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
148	function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
149	procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
150	procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
151	procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);
152
153	//Navigate & Download
154	procedure Go(WebBrowser: TEmbeddedWB; Url: string);
155	procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
156	procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
157	procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
158	procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
159	procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
160	function DownloadFile(SourceFile, TargetFile: string): Boolean;
161	procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
162
163	//Get Special Folders/URL paths etc.
164	function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
165	function GetShellFolderPath(FolderName: Widestring): string;
166	function GetIEHomePage: string;
167	function GetCachePath: string;
168	function GetCachedFileFromURL(ItemUrl: string): string;
169	function GetDefaultBrowserFromRegistry: string;
170	function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
171
172
173	//E-Mail functions
174	procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
175	function CreateNewMail: Boolean;
176	procedure SendUrlInMail(LocationURL, LocationName: WideString);
177
178	//Search in Document & Fill Forms
179	function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
180	//function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; const iPos: Integer = 1): IHTMLTxtRange;
181	function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; aTypeSearch: Integer; const iPos: Integer = 1): IHTMLTxtRange;
182
183	procedure 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
188	procedure SearchAndHighlight(Document: IDispatch; aText: string; Flags: TSearchFlags = [];
189	cbackColor: string = 'yellow'; cForeColor: string = '';
190	ScrollIntoView: TScrollIntoView = sivNoScroll); overload;
191
192	procedure SetTextAreaValue(Document: IDispatch; sName, sValue: string; Options: TFindOptions);
193	function FillForm(WebBrowser: TEmbeddedWB; FieldName, FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
194	function FillForm(Document: IDispatch; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
195
196	function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; Value: Boolean): Boolean; overload;
197
198
199	function GetFieldValue(OleObject: Variant; FieldName: string): string;
200	procedure ClickInputImage(WebBrowser: TEmbeddedWB; ImageURL: string);
201
202	procedure FillIEFormAndExcecute;
203
204	//Clearing
205	procedure ClearCache;
206	procedure ClearTypedUrls;
207
208	//Online Status
209	function CheckOnlineStatus: Boolean;
210	function IsGlobalOffline: Boolean;
211	procedure WorkOffline();
212	procedure WorkOnline();
213
214	//Restricted & Trusted Lists
215	function CheckIfInRestricredList(const Host: string; SecureSite: Boolean): Boolean;
216	function CheckIfInTrustedList(const Host: string; SecureSite: Boolean): Boolean;
217	procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
218	procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
219
220	//Zone Icon, Security Zone, SSL Status
221	procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
222	function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
223	function GetZoneAttributes(const URL: string): TZoneAttributes;
224	function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
225	function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;
226
227	//Proxy & User agent
228	function SetProxy(UserAgent, Address: string): Boolean; overload;
229	function SetProxy(UserAgent, Address, UserName, Password: string; Port: Integer): Boolean; overload;
230	function SetProxyFromPAC(UserAgent, PACFile: string): Boolean;
231
232	function RemoveProxy(): Boolean;
233	procedure RemoveUserAgent(UserAgent: string);
234
235	//MIME Filter & NameSpace
236	function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
237	function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
238	function RegisterNameSpace(clsid: TGUID): HRESULT;
239	function UnregisterNameSpace: HRESULT;
240
241	//Cookies
242	function GetCookiesPath: string;
243	procedure ClearSessionCookies;
244
245	//Favorites
246	function OrganizeFavorite(h: THandle; Path: PAnsiChar): Boolean; stdcall; overload;
247	{$IFDEF UNICODE}
248	function OrganizeFavorite(h: THandle; Path: PWideChar): Boolean; overload;
249	{$ENDIF UNICODE}
250
251	function URLFromFavorites(const dotURL: string): string;
252	function GetFavoritesPath: string;
253	procedure AddToFavorites(URL, Title: string);
254
255	//History
256	function GetHistoryPath: string;
257	function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
258	procedure ClearHistory;
259
260	//Pages
261	procedure SetNewHomePage(HomePage: string);
262	function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
263	function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;
264
265	//Code accessories
266	procedure Wait(WebBrowser: TEmbeddedWB);
267	function InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant): HRESULT;
268	function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;
269
270	//Execute Script
271	procedure ExecScript(WebBrowser: TEmbeddedWB; sExpression, sLanguage: string);
272	function ExecScriptEx(WebBrowser: TEmbeddedWB; MethodName: string; ParamValues: array of const): OleVariant;
273	function WBExecScript(TargetObj: IDispatch; MethodName: string; ParamValues: array of const): OleVariant;
274
275	//Miscellaneous
276	procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
277	procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
278	procedure ShowIEVersionInfo(Handle: THandle);
279	procedure CreateDesktopShortcut(Handle: THandle);
280	procedure DisableNavSound(bDisable: Boolean);
281
282	//----- add to ewb-------------------------------------------------------
283	function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
284	function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
285	function CopyPIDL(IDList: PItemIDList): PItemIDList;
286	function CreatePIDL(Size: Integer): PItemIDList;
287	function DeleteUrl(Url: PWideChar): HResult;
288	function Encode(const S: string): string;
289	function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
290	function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
291	function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
292	function GetIEVersion: string;
293	function GetIEVersionMajor: Integer;
294	function GetImageIndex(pidl: PItemIDList): Integer;
295	function GetMailClients: TStrings;
296	function GetPIDLSize(IDList: PItemIDList): Integer;
297	function IE5_Installed: Boolean;
298	function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
299	function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
300	function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
301
302
303
304
305	function NextPIDL(IDList: PItemIDList): PItemIDList;
306	function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
307	function ResolveLink(const Path: string): string;
308	function ResolveUrlIni(FileName: string): string;
309	function ResolveUrlIntShCut(FileName: string): string;
310	function StringToVarArray(const S: string): Variant;
311	function URLFromShortcut(const dotURL: string): string;
312	function VarArrayToString(const V: Variant): string;
313	procedure DisposePIDL(ID: PItemIDList);
314	procedure StripLastID(IDList: PItemIDList);
315	function IsWinXPSP2OrLater(): Boolean;
316	function EncodeUrl(const InputStr: string; const bQueryStr: Boolean): string;
317	function DecodeURL(const InputStr: string): string;
318	function IsValidProtocol(URL: string): Boolean;
319	function ImportCertFile(AFileName, AStoreType: string): Boolean;
320	//--end of add to ewb---------------------------------
321
322	implementation
323
324	uses
325	Registry, ShellAPI, Controls, Messages, Forms, SysUtils,
326	OleCtrls, WinInet, SendMail_For_EWB, ComObj, IEConst, IniFiles, JPEG, WinSock,
327	Wcrypt2, Browse4Folder, EWBCoreTools;
328
329	type
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
347	type
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
353	function ImportCertFile(AFileName, AStoreType: string): Boolean;
354	var
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;
362	begin
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;
391	end;
392
393	function IsWinXPSP2OrLater(): Boolean;
394	var
395	osvi: TOSVersionInfoEx;
396	dwlConditionMask: LONGLONG;
397	op: Integer;
398	hlib: THandle;
399	VerifyVersionInfo: fn_VerifyVersionInfo;
400	VerSetConditionMask: fn_VerSetConditionMask;
401	begin
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;
432	end;
433
434	function EncodeURL(const InputStr: string; const bQueryStr: Boolean): string;
435	var
436	Idx: Integer;
437	begin
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;
453	end;
454
455	function DecodeURL(const InputStr: string): string;
456	var
457	Idx: Integer;
458	Hex: string;
459	Code: Integer;
460	begin
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;
487	end;
488
489	function IsValidProtocol(URL: string): Boolean;
490	const
491	Protocols: array[1..11] of string = ('ftp://', 'http://', 'https://',
492	'gopher://', 'mailto:', 'news:', 'nntp://', 'telnet://', 'wais://',
493	'file://', 'prospero://');
494	var
495	I: Integer;
496	begin
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;
505	end;
506
507	function DocumentLoaded(Document: IDispatch): Boolean;
508	var
509	iDoc: IHTMLDocument2;
510	begin
511	Result := False;
512	if Assigned(Document) then
513	begin
514	Document.QueryInterface(IHTMLDocument2, iDoc);
515	Result := Assigned(iDoc);
516	end;
517	end;
518
519	procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
520	begin
521	WebBrowser.Go('about:blank');
522	end;
523
524	function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
525	var
526	Flags, TargetFrameName, PostData, Headers: OleVariant;
527	begin
528	WebBrowser.Navigate('about:' + StringToHtml, Flags, TargetFrameName, PostData, Headers);
529	Result := True;
530	end;
531
532	function GetWordAtCursor(const X, Y: Integer; WebBrowser: TEmbeddedWB): string;
533	var
534	Doc: IHTMLDocument2;
535	Selection: IHTMLSelectionObject;
536	Range: IHTMLTxtRange;
537	begin
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;
551	end;
552
553	procedure PrintPreviewFromTemplate(const TemplateFileName: string; Document: IDispatch);
554	var
555	OleCommandTarget: IOleCommandTarget;
556	ParamIn, EmptyParam: OleVariant;
557	begin
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;
569	end;
570
571	procedure ScrollToIDEx(ID: string; WebBrowser: TEmbeddedWB);
572	var
573	Doc3: IHTMLDocument3;
574	Elem: IHTMLElement;
575	RV: IHTMLRect;
576	begin
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;
587	end;
588
589	procedure ScrollToID(ID: Integer; WebBrowser: TEmbeddedWB);
590	var
591	Doc: IHTMLDocument2;
592	ACollection: IHTMLElementCollection;
593	Elem: IHTMLElement;
594	Match: IHTMLElement2;
595	I: Integer;
596	S: string;
597	RV: IHTMLRect;
598	begin
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;
622	end;
623
624	// Get SysListView32 Child from the Webbrowser Control
625
626	function GetWBLV(WBHandle: HWND): HWND;
627	var
628	WND: HWND;
629	begin
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;
637	end;
638
639	// Check if the horizontal / vertical Scrollbars are visible
640
641	procedure GetScrollBarVisibility(WebBrowser: TEmbeddedWB; var HScroll, VScroll: Boolean);
642	var
643	WndLV: HWND;
644	IDoc: IHTMLDocument2;
645	begin
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;
666	end;
667
668	// Get TEmbeddedWB Scrollbar X,Y Position
669
670	function 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
734	begin
735	Result := WB_GetDOCScrollPosition(WebBrowser, ScrollPos);
736	if not Result then
737	Result := WB_GetLVScrollPosition(WebBrowser, ScrollPos);
738	end;
739
740	function DocumentSource(OleObject: Variant): string;
741	var
742	Strings: TStringList;
743	begin
744	Strings := TStringList.Create;
745	try
746	ViewPageSourceHTMLToStrings(OleObject, OleObject.Document, Strings);
747	Result := Strings.Text;
748	finally
749	FreeAndNil(Strings);
750	end;
751	end;
752
753	function DocumentSourceText(OleObject: Variant; Document: IDispatch): string;
754	var
755	Strings: TStringList;
756	begin
757	Strings := TStringList.Create;
758	try
759	EwbTools.ViewPageSourceTextToStrings(OleObject, Document, Strings);
760	Result := Strings.Text;
761	finally
762	FreeAndNil(Strings);
763	end;
764	end;
765
766	function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
767	var
768	OleContainer: IOleContainer;
769	enum: ActiveX.IEnumUnknown;
770	unk: IUnknown;
771	Fetched: PLongint;
772	begin
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;
787	end;
788
789	function FrameCount(Document: IDispatch): LongInt;
790	var //fix by Aladin
791	OleContainer: IOleContainer;
792	enum: ActiveX.IEnumUnknown;
793	FetchedContrs: LongInt;
794	Unknown: IUnknown;
795	IWeb: IWebBrowser2;
796	begin
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;
808	end;
809
810	function FrameCountFromDocument(SourceDoc: IHTMLDocument2): Integer;
811	var //by Aladin
812	OleContainer: IOleContainer;
813	enum: ActiveX.IEnumUnknown;
814	unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
815	EnumResult: HRESULT;
816	begin
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;
826	end;
827
828	procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
829	begin
830	if DocumentLoaded(Document) then
831	with (Dispatch as IOleObject) do
832	DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser, 0, WebBrowser.Handle, WebBrowser.ClientRect);
833	end;
834
835	function CMD_Copy(Document: IDispatch): Boolean;
836	var
837	vaIn, vaOut: OleVariant;
838	begin
839	Result := InvokeCmd(Document, False, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
840	end;
841
842	function CMD_Paste(Document: IDispatch): Boolean;
843	var
844	vaIn, vaOut: OleVariant;
845	begin
846	Result := InvokeCmd(Document, False, OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
847	end;
848
849	function CMD_Cut(Document: IDispatch): Boolean;
850	var
851	vaIn, vaOut: OleVariant;
852	begin
853	Result := InvokeCmd(Document, False, OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
854	end;
855
856	function SelectAll(Document: IDispatch): Boolean;
857	var
858	vaIn, vaOut: OleVariant;
859	begin
860	Result := InvokeCmd(Document, False, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
861	end;
862
863	function UnSelectAll(Document: IDispatch): Boolean;
864	var
865	vaIn, vaOut: OleVariant;
866	begin
867	Result := InvokeCmd(Document, False, OLECMDID_CLEARSELECTION, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
868	end;
869
870	procedure ScrollToTop(OleObject: Variant);
871	begin
872	try
873	if DocumentLoaded(OleObject.Document) then
874	OleObject.Document.ParentWindow.ScrollTo(0, 0);
875	except
876	end;
877	end;
878
879	procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
880	begin
881	try
882	if DocumentLoaded(OleObject.Document) then
883	OleObject.Document.ParentWindow.ScrollTo(X, Y);
884	except
885	end;
886	end;
887
888	procedure ScrollToBottom(Document: IDispatch);
889	var
890	HTMLParentWin: IHTMLWindow2;
891	Doc2: IHTMLDocument2;
892	begin
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;
902	end;
903
904	function Zoom(Document: IDispatch; ZoomValue: Integer): Boolean;
905	var
906	vaIn, vaOut: OleVariant;
907	begin
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;
916	end;
917
918	function ZoomValue(Document: IDispatch): Integer;
919	var
920	vaIn, vaOut: OleVariant;
921	begin
922	vaIn := null;
923	InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
924	Result := vaOut;
925	end;
926
927	function ZoomRangeHigh(Document: IDispatch): Integer;
928	var
929	vaIn, vaOut: OleVariant;
930	begin
931	InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
932	Result := HiWord(DWORD(vaOut));
933	end;
934
935	function ZoomRangeLow(Document: IDispatch): Integer;
936	var
937	vaIn, vaOut: OleVariant;
938	begin
939	InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
940	Result := LoWord(DWORD(vaOut));
941	end;
942
943	function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string; Refresh: Boolean = True): Boolean;
944	var
945	RefreshLevel: OleVariant;
946	begin
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;
962	end;
963
964	{
965	function GetCookie(OleObject: Variant): string;
966	begin
967	Result := '';
968	if DocumentLoaded(OleObject.Document) then
969	try
970	Result := OleObject.Document.Cookie;
971	except
972	end;
973	end; }
974
975	procedure ClearSessionCookies;
976	begin
977	InternetSetOption(nil, INTERNET_OPTION_END_BROWSER_SESSION, nil, 0);
978	end;
979
980	procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
981	var
982	DrawRect: TRect;
983	begin
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;
992	end;
993
994	function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
995	var
996	ViewObject: IViewObject;
997	sourceDrawRect: TRect;
998	ScreenImg: Graphics.TBitmap;
999	begin
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;
1020	end;
1021
1022	function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth,
1023	TargetHeight, TargetWidth: Integer): Boolean;
1024	var
1025	sourceDrawRect: TRect;
1026	targetDrawRect: TRect;
1027	sourceBitmap: Graphics.TBitmap;
1028	targetBitmap: Graphics.TBitmap;
1029	aJPG: TJPEGImage;
1030	aViewObject: IViewObject;
1031	IWeb: IWebBrowser2;
1032	begin
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;
1065	end;
1066
1067	procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
1068	var //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;
1105	begin
1106	LinksList.Clear;
1107	if not DocumentLoaded(OleObject.Document) then
1108	Exit;
1109	RecurseLinks(OleObject.Document);
1110	end;
1111
1112	procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
1113	begin
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;
1122	end;
1123
1124	procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
1125	begin
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;
1134	end;
1135
1136	procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);
1137	var
1138	TextLst: TStringList;
1139	begin
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;
1150	end;
1151
1152	function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HResult;
1153	var
1154	IpStream: IPersistStreamInit;
1155	AStream: TMemoryStream;
1156	begin
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;
1176	end;
1177
1178	function SaveDocToStream(Document: IDispatch; var AStream: TStream): HResult;
1179	var
1180	IpStream: IPersistStreamInit;
1181	begin
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;
1189	end;
1190
1191	function SaveDocToFile(Document: IDispatch; const Fname: string): HResult;
1192	var
1193	PFile: IPersistFile;
1194	begin
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;
1201	end;
1202
1203	procedure PrintWithHeaderFooter(ControlInterface: IWebBrowser2; Header, Footer: PWideChar; Options: OLECMDEXECOPT);
1204	var
1205	saBound: TSafeArrayBound;
1206	psaHeadFoot: PSafeArray;
1207	vaIn, vaOut: TVariantArg;
1208	vHeadStr, vFootStr: TVariantArg;
1209	rgIndex: LongInt;
1210	begin
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;
1233	end;
1234
1235	procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean = False; bCustomHeaderFooter: Boolean = False; Header: string = ''; Footer: string = '');
1236	var
1237	vaIn, vaOut: OleVariant;
1238	begin
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;
1254	end;
1255
1256	procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
1257	begin
1258	PrintingWithOptions := True;
1259	PageSetup(Document, UsePrintOptions, PrintOptionsEnabled, InvokingPagesetup);
1260	Print(ControlInterface, HideSetup);
1261	end;
1262
1263	procedure PrintPreview(Webbrowser: IWebBrowser2);
1264	// IE 5.5 only
1265	var
1266	vaIn, vaOut: Olevariant;
1267	begin
1268	if DocumentLoaded(Webbrowser.Document) then
1269	Webbrowser.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
1270	end;
1271
1272	function OpenClient(Client: string): Boolean;
1273	var
1274	s, params, Exec: string;
1275	begin
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;
1304	end;
1305
1306	procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
1307	var
1308	Preview_HWND, App_HWND: THandle;
1309	ClassName: array[0..255] of Char;
1310	StartTime, EndTime: DWORD; //Smot
1311	vaIn, vaOut: OleVariant;
1312	begin
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;
1332	end;
1333
1334	function PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean): Boolean;
1335	var
1336	vaIn, vaOut: OleVariant;
1337	begin
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;
1345	end;
1346
1347	procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
1348	var
1349	vaIn, vaOut: OleVariant;
1350	begin
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;
1358	end;
1359
1360	procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
1361	var
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
1379	begin
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;
1402	end;
1403
1404	function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): string;
1405	begin
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);
1415	end;
1416
1417	procedure RestorePrintValues;
1418	var
1419	Reg: TRegistry;
1420	begin
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;
1440	end;
1441
1442	function OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): Boolean;
1443	var
1444	OD: TOpenDialog;
1445	begin
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;
1466	end;
1467
1468	function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent; ATitle: string = ''; AFilter: string = ''): string;
1469	var
1470	SD: TSaveDialog;
1471	begin
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;
1495	end;
1496
1497	function SaveDialog(Document: IDispatch): Boolean;
1498	var
1499	vaIn, vaOut: OleVariant;
1500	begin
1501	Result := InvokeCmd(Document, False, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
1502	end;
1503
1504	function ShowInternetOptions(Document: IDispatch): Boolean;
1505	var
1506	vaIn, vaOut: OleVariant;
1507	begin
1508	Result := InvokeCmd(Document, True, HTMLID_OPTIONS, 0, vaIn, vaOut) = S_OK;
1509	end;
1510
1511	function ShowPageProperties(Document: IDispatch): Boolean;
1512	var
1513	vaIn, vaOut: OleVariant;
1514	begin // OLECMDID_SHOWPAGEACTIONMENU
1515	Result := InvokeCmd(Document, False, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
1516	end;
1517
1518	function ShowOrganizeFavorites(Handle: THandle): Boolean;
1519	begin
1520	Result := OrganizeFavorite(Handle, GetSpecialFolderPath(Handle, CSIDL_FAVORITES));
1521	end;
1522
1523	procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
1524	begin
1525	SendMessage(Handle, WM_COMMAND, ID_IE_FILE_IMPORTEXPORT, 0);
1526	end;
1527
1528	function ShowFindDialog(Document: IDispatch): Boolean;
1529	var
1530	vaIn, vaOut: OleVariant;
1531	begin
1532	Result := InvokeCmd(Document, True, HTMLID_FIND, 0, vaIn, vaOut) = S_OK;
1533	end;
1534
1535	procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
1536	var
1537	k, p: Integer;
1538	path, Source, dest, ext: string;
1539	begin
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;
1560	end;
1561
1562	function ViewPageSourceHtml(Document: IDispatch): Boolean;
1563	var
1564	vaIn, vaOut: OleVariant;
1565	begin
1566	Result := InvokeCmd(Document, True, HTMLID_VIEWSOURCE, 0, vaIn, vaOut) = S_OK;
1567	end;
1568
1569	procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);
1570	var
1571	sd: TSaveDialog;
1572	textStr: TStringList;
1573	begin
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;
1597	end;
1598
1599	procedure ShellExecuteOpen(const sApplication: string);
1600	begin
1601	ShellExecute(Application.Handle, 'open', PChar(sApplication), nil, nil, SW_SHOW);
1602	end;
1603
1604	procedure OpenOutlookMail;
1605	begin
1606	ShellExecuteOpen('outlook.exe');
1607	end;
1608
1609	procedure OpenOutlookExpressMail;
1610	begin
1611	ShellExecuteOpen('msimn.exe');
1612	end;
1613
1614	procedure OpenEudoraMail;
1615	begin
1616	ShellExecuteOpen('eudora.exe');
1617	end;
1618
1619	procedure OpenRegistryEditor;
1620	begin
1621	ShellExecuteOpen('regedit.exe');
1622	end;
1623
1624	function OpenNewsClient: Boolean;
1625	begin
1626	Result := OpenClient('News');
1627	end;
1628
1629	procedure OpenAddressBook;
1630	begin
1631	ShellExecuteOpen('wab.exe');
1632	end;
1633
1634	function OpenCalendar: Boolean;
1635	begin
1636	Result := OpenClient('Calendar');
1637	end;
1638
1639	function OpenNetMeeting: Boolean;
1640	begin
1641	Result := OpenClient('Internet Call');
1642	end;
1643
1644	procedure DoExploreFolder(Handle: THandle; Path: string);
1645	begin
1646	ShellExecute(handle, 'explore', PChar(Path), nil, nil, SW_SHOWNORMAL);
1647	end;
1648
1649	procedure OpenIEBrowserWithAddress(Handle: THandle);
1650	begin
1651	SendMessage(Handle, WM_COMMAND, ID_IE_FILE_NEWWINDOW, 0);
1652	end;
1653
1654	function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
1655	begin
1656	Result := True;
1657	Go(WebBrowser, 'http://lc1.law5.hotmail.passport.com/cgi-bin/login');
1658	end;
1659
1660	function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
1661	begin
1662	Result := True;
1663	Go(WebBrowser, 'http://mail.google.com/mail/');
1664	end;
1665
1666	function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
1667	begin
1668	Result := True;
1669	Go(WebBrowser, 'http://mail.yahoo.com/');
1670	end;
1671
1672	procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
1673	const
1674	GOOGLE_QUERY = 'http://www.google.com/search?ie=ISO-8859-1&q=';
1675	var
1676	sQuery: string;
1677	begin
1678	sQuery := GOOGLE_QUERY + SearchTerm;
1679	Go(WebBrowser, sQuery);
1680	end;
1681
1682	procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
1683	const
1684	MSN_QUERY = 'http://search.live.com/results.aspx?q=';
1685	MSN_Const = '&FORM=CBPW&first=1&noredir=1';
1686	var
1687	sQuery: string;
1688	begin
1689	sQuery := MSN_QUERY + SearchTerm + MSN_Const;
1690	Go(WebBrowser, sQuery);
1691	end;
1692
1693	procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);
1694	const
1695	YAHOO_QUERY = 'http://search.yahoo.com/bin/search?p=';
1696	var
1697	sQuery: string;
1698	begin
1699	sQuery := YAHOO_QUERY + SearchTerm;
1700	WebBrowser.Go(sQuery);
1701	end;
1702
1703	procedure Go(WebBrowser: TEmbeddedWB; Url: string);
1704	var
1705	_URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
1706	begin
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);
1714	end;
1715
1716	procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
1717	var
1718	_URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
1719	begin
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);
1726	end;
1727
1728	procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
1729
1730	function StrToChr(Str: string; Pos: Integer): Char;
1731	begin
1732	Result := Str[Pos];
1733	end;
1734
1735	var
1736	Flags: OleVariant;
1737	HistoryStg: IUrlHistoryStg;
1738	begin
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);
1744	end;
1745
1746	procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
1747	var
1748	VaEmpty, vaPidl: OleVariant;
1749	psa: PSafeArray;
1750	cbData: UINT;
1751	begin
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;
1763	end;
1764
1765	function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2;
1766	var //by Aladin
1767	OleContainer: IOleContainer;
1768	enum: ActiveX.IEnumUnknown;
1769	unk: IUnknown;
1770	Fetched: PLongint;
1771	begin
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;
1783	end;
1784
1785	procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
1786	begin
1787	WebBrowser.Go('about:blank');
1788	Wait(WebBrowser);
1789	end;
1790
1791	procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
1792	begin
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;
1807	end;
1808
1809	procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
1810	var
1811	Flags: OleVariant;
1812	begin
1813	Flags := navNoHistory or navNoReadFromCache or navNoWriteToCache
1814	or navAllowAutosearch or navBrowserBar;
1815	WebBrowser.Navigate(URL, Flags);
1816	end;
1817
1818	function DownloadFile(SourceFile, TargetFile: string): Boolean;
1819	begin
1820	try
1821	Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(TargetFile), 0, nil) = 0;
1822	except
1823	Result := False;
1824	end;
1825	end;
1826
1827	procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
1828	begin
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);
1842	end;
1843
1844	procedure 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.
1848	const
1849	CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
1850	var
1851	ShellUIHelper: ISHellUIHelper;
1852	Url1, Title1: OleVariant;
1853	begin
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;
1864	end;
1865
1866	function GetFavoritesPath: string;
1867	begin
1868	Result := GetShellFolderPath('Favorites');
1869	end;
1870
1871	function GetCookiesPath: string;
1872	begin
1873	Result := GetShellFolderPath('Cookies');
1874	end;
1875
1876	function GetHistoryPath: string;
1877	begin
1878	Result := GetShellFolderPath('History');
1879	end;
1880
1881	function GetCachePath: string;
1882	begin
1883	Result := GetShellFolderPath('Cache');
1884	end;
1885
1886	function GetShellFolderPath(FolderName: Widestring): string;
1887	const
1888	REG_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
1889	var
1890	Reg: TRegistry;
1891	begin
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;
1904	end;
1905
1906	function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
1907	var
1908	exInfo: TShellExecuteInfo;
1909	Buf: PChar;
1910	begin
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;
1933	end;
1934
1935
1936
1937	function GetIEHomePage: string;
1938	var
1939	HomePage: string;
1940	begin
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;
1952	end;
1953
1954	function GetCachedFileFromURL(ItemUrl: string): string;
1955	var
1956	IntCacheInfo: PInternetCacheEntryInfo;
1957	CacheEntry, dwEntrySize, dwLastError: LongWord;
1958	begin
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);
1985	end;
1986
1987	function OrganizeFavorite(h: THandle; Path: PAnsiChar): Boolean; stdcall;
1988	external 'shdocvw.dll' name 'DoOrganizeFavDlg'; overload;
1989
1990	{$IFDEF UNICODE}
1991
1992	function OrganizeFavorite(h: THandle; Path: PWideChar): Boolean;
1993	begin
1994	Result := OrganizeFavorite(h, PAnsiChar(AnsiString(UnicodeString(Path))));
1995	end;
1996
1997	{$ENDIF UNICODE}
1998
1999	function URLFromFavorites(const dotURL: string): string;
2000	begin
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;
2011	end;
2012
2013	function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
2014	var
2015	Handle: THandle;
2016	Info: IQueryInfo;
2017	W: PWideChar;
2018	begin
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)));
2029	end;
2030
2031	function GetDefaultBrowserFromRegistry: string;
2032	var
2033	Reg: TRegistry;
2034	KeyName: string;
2035	begin
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;
2050	end;
2051
2052	function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
2053	var
2054	WSAResult: Integer;
2055	WSAData: TWSAData;
2056	HostEnt: PHostEnt;
2057	Host: AnsiString;
2058	SockAddr: TSockAddrIn;
2059	begin
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;
2093	end;
2094
2095	function CreateNewMail: Boolean;
2096	var
2097	em_subject, em_body, em_mail: string;
2098	begin
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;
2103	end;
2104
2105	procedure SendUrlInMail(LocationURL, LocationName: WideString);
2106	begin
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;
2117	end;
2118
2119
2120	function 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	(*
2124	0 Default. Match partial words.
2125	1 Match backwards.
2126	2 Match whole words only.
2127	4 Match case.
2128	*)
2129	}
2130	var
2131	B: Boolean;
2132	begin
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;
2152	end;
2153
2154	function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
2155	var
2156	tr: IHTMLTxtRange;
2157	begin
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;
2170	end;
2171
2172	function DoSearchAndHighlight(Document: IDispatch; sFind: string;
2173	Flags: TSearchFlags = []; cbackColor: string = 'yellow'; cForeColor: string = '';
2174	ScrollIntoView: TScrollIntoView = sivNoScroll): Integer;
2175	var
2176	Doc2: IHTMLDocument2;
2177	pElem: IHTMLElement;
2178	pBodyelem: IHTMLBodyElement;
2179	pTxtRange: IHTMLTxtRange;
2180	searchdir, searchcase, iMatches: Integer;
2181	begin
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;
2224	end;
2225
2226	procedure 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;
2230	var
2231	// tr: IHTMLTxtRange;
2232	FrameCount, i: Integer;
2233	Wb2: IWebBrowser2;
2234	begin
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;
2268	end;
2269
2270	procedure SearchAndHighlight(Document: IDispatch; aText: string; Flags: TSearchFlags = [];
2271	cbackColor: string = 'yellow'; cForeColor: string = '';
2272	ScrollIntoView: TScrollIntoView = sivNoScroll); overload;
2273	begin
2274	SearchAndHighlight(Document, '', '', aText, Flags, cbackColor, cForeColor, ScrollIntoView, False);
2275	end;
2276
2277	{function FillForm(OleObject: Variant; FieldName: string; Value: string): Boolean;
2278	var
2279	I, j: Integer;
2280	FormItem: Variant;
2281	begin
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;
2302	end; }
2303
2304	procedure SetTextAreaValue(Document: IDispatch; sName, sValue: string; Options: TFindOptions);
2305	var
2306	Doc2: IHTMLDocument2;
2307	i: Integer;
2308	field: IHTMLElement;
2309	textarea: IHTMLTextAreaElement;
2310	begin
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;
2329	end;
2330
2331	function FillForm(Document: IDispatch; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
2332	var
2333	Inputs: IHTMLElementCollection;
2334	HTMLElement: IHTMLElement;
2335	TagName: string;
2336	k, iItemNr, iInputCount: Integer;
2337	begin
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;
2385	end;
2386
2387	function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
2388	var
2389	Doc3: IHTMLDocument3;
2390	begin
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;
2397	end;
2398
2399
2400	function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; Value: Boolean): Boolean;
2401	var
2402	I, j: Integer;
2403	FormItem: Variant;
2404	begin
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;
2426	end;
2427
2428	procedure ClickInputImage(WebBrowser: TEmbeddedWB; ImageURL: string);
2429	var
2430	iDoc: IHTMLDocument2;
2431	iDisp: IDispatch;
2432	iColl: IHTMLElementCollection;
2433	InputImage: htmlInputImage;
2434	i: Integer;
2435	begin
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;
2461	end;
2462
2463	function GetFieldValue(OleObject: Variant; FieldName: string): string;
2464	var
2465	I, j: Integer;
2466	FormItem: Variant;
2467	begin
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;
2484	end;
2485
2486	procedure FillIEFormAndExcecute;
2487	var
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;
2496	begin
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;
2547	end;
2548
2549	procedure ClearHistory;
2550	var
2551	HistoryStg: IUrlHistoryStg2;
2552	begin
2553	HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
2554	HistoryStg.ClearHistory;
2555	end;
2556
2557	function DeleteFirstCacheEntry(var H: THandle): DWORD;
2558	var
2559	T: PInternetCacheEntryInfo;
2560	D: DWord;
2561	begin
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;
2576	end;
2577
2578	function DeleteNextCacheEntry(H: THandle): DWORD;
2579	var
2580	T: PInternetCacheEntryInfo;
2581	D: DWORD;
2582	begin
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;
2595	end;
2596
2597	procedure ClearCache;
2598	var
2599	H: THandle;
2600	begin
2601	if DeleteFirstCacheEntry(H) = S_OK then
2602	repeat
2603	until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS;
2604	FindCloseUrlCache(H);
2605	end;
2606
2607	procedure ClearTypedUrls;
2608	begin
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;
2616	end;
2617
2618	function CheckOnlineStatus: Boolean;
2619	var
2620	dwConnectionTypes: Integer;
2621	begin
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;
2628	end;
2629
2630	procedure SetGlobalOffline(Value: Boolean);
2631	const
2632	INTERNET_STATE_DISCONNECTED_BY_USER = $10;
2633	ISO_FORCE_DISCONNECTED = $1;
2634	INTERNET_STATE_CONNECTED = $1;
2635	var
2636	ci: TInternetConnectedInfo;
2637	dwSize: DWORD;
2638	begin
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);
2650	end;
2651
2652	procedure WorkOffline();
2653	begin
2654	SetGlobalOffline(False);
2655	end;
2656
2657	procedure WorkOnline();
2658	begin
2659	SetGlobalOffline(True);
2660	end;
2661
2662	function IsGlobalOffline: Boolean;
2663	var
2664	dwState: DWORD;
2665	dwSize: DWORD;
2666	begin
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);
2672	end;
2673
2674	function GetTLDFromHost(Host: string): string;
2675	var
2676	i, Dots: Integer;
2677	begin
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;
2687	end;
2688
2689	function CheckIfInRestricredList(const Host: string; SecureSite: Boolean): Boolean;
2690	const
2691	Path = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\';
2692	var
2693	TLD: string;
2694	begin // 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;
2721	end;
2722
2723	function CheckIfInTrustedList(const Host: string; SecureSite: Boolean): Boolean;
2724	const
2725	Path = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\';
2726	var
2727	TLD: string;
2728	begin // 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;
2755	end;
2756
2757	procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
2758	const
2759	REG_PATH = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains';
2760	var
2761	Reg: TRegistryIniFile;
2762	begin
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;
2777	end;
2778
2779	procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
2780	const
2781	REG_PATH = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains';
2782	var
2783	st: string;
2784	I: Integer;
2785	Reg: TRegistryIniFile;
2786	begin
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;
2803	end;
2804
2805
2806	function GetZoneAttributes(const URL: string): TZoneAttributes;
2807	var
2808	dwZone: Cardinal;
2809	ZoneAttr: TZoneAttributes;
2810	var
2811	ZoneManager: IInternetZoneManager;
2812	SecManager: IInternetSecurityManager;
2813	begin
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;
2821	end;
2822
2823	function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
2824	var
2825	ZoneAttr: TZoneAttributes;
2826	ZoneIcon: TIcon;
2827	begin
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;
2839	end;
2840
2841	procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
2842	var
2843	FName, ImageName: string;
2844	h: hInst;
2845	begin
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;
2855	end;
2856
2857	function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;
2858	var
2859	ZoneAttr: TZoneAttributes;
2860	begin
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;
2874	end;
2875
2876	function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
2877	begin
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
2894	end;
2895
2896	function SetProxy(UserAgent, Address: string): Boolean; // mladen
2897	var
2898	list: INTERNET_PER_CONN_OPTION_LIST;
2899	dwBufSize: DWORD;
2900	hInternet: Pointer;
2901	Options: array[1..3] of INTERNET_PER_CONN_OPTION;
2902	begin
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;
2923	end;
2924
2925	function SetProxy(UserAgent, Address, UserName, Password: string; Port: Integer): Boolean;
2926	var
2927	list: INTERNET_PER_CONN_OPTION_LIST;
2928	dwBufSize: DWORD;
2929	hInternet, hInternetConnect: Pointer;
2930	Options: array[1..3] of INTERNET_PER_CONN_OPTION;
2931	begin
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;
2957	end;
2958
2959	function SetProxyFromPAC(UserAgent, PACFile: string): Boolean;
2960	var
2961	list: INTERNET_PER_CONN_OPTION_LIST;
2962	dwBufSize: DWORD;
2963	hInternet: Pointer;
2964	Options: array[1..2] of INTERNET_PER_CONN_OPTION;
2965	begin
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;
2986	end;
2987
2988	function RemoveProxy(): Boolean;
2989	var
2990	list: INTERNET_PER_CONN_OPTION_LIST;
2991	dwBufSize: DWORD;
2992	hInternet: Pointer;
2993	Options: array[1..3] of INTERNET_PER_CONN_OPTION;
2994	begin
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;
3016	end;
3017
3018	procedure RemoveUserAgent(UserAgent: string);
3019	var
3020	reg: TRegistry;
3021	begin
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;
3035	end;
3036
3037	var
3038	MimeFactory, NSFactory: IClassFactory;
3039	MimeInternetSession, NSInternetSession: IInternetSession;
3040
3041	function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
3042	begin
3043	CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory);
3044	CoInternetGetSession(0, MimeInternetSession, 0);
3045	Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME);
3046	end;
3047
3048	function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
3049	begin
3050	Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME);
3051	end;
3052
3053	function RegisterNameSpace(clsid: TGUID): HRESULT;
3054	begin
3055	CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory);
3056	CoInternetGetSession(0, NSInternetSession, 0);
3057	Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0);
3058	end;
3059
3060	function UnregisterNameSpace: HRESULT;
3061	begin
3062	Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http');
3063	end;
3064
3065	procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
3066	var
3067	ws: Integer;
3068	RegPath: string;
3069	begin
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;
3094	end;
3095
3096	procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
3097	var
3098	RegPath: string;
3099	begin
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;
3124	end;
3125
3126	procedure Wait(WebBrowser: TEmbeddedWB);
3127	begin
3128	WebBrowser.Wait;
3129	end;
3130
3131	function InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant): HRESULT;
3132	var
3133	CmdTarget: IOleCommandTarget;
3134	PtrGUID: PGUID;
3135	begin
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);
3157	end;
3158
3159	function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;
3160	begin
3161	Result := WebBrowser.GetIEHandle(WebBrowser, ClassName);
3162	end;
3163
3164	procedure ShowIEVersionInfo(Handle: THandle);
3165	begin
3166	SendMessage(Handle, WM_COMMAND, ID_IE_HELP_VERSIONINFO, 0);
3167	end;
3168
3169	procedure SetNewHomePage(HomePage: string);
3170	begin
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;
3181	end;
3182
3183	function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
3184	begin
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;
3201	end;
3202
3203	function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;
3204	var
3205	RegPath: string;
3206	begin
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;
3234	end;
3235
3236	procedure CreateDesktopShortcut(Handle: THandle);
3237	begin
3238	SendMessage(Handle, WM_COMMAND, ID_IE_FILE_SENDDESKTOPSHORTCUT, 0);
3239	end;
3240
3241	procedure DisableNavSound(bDisable: Boolean);
3242	const
3243	REG_PATH = 'AppEvents\Schemes\Apps\Explorer\Navigating\';
3244	var
3245	Reg: TRegIniFile;
3246	begin
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;
3269	end;
3270
3271	function WBExecScript(
3272	TargetObj: IDispatch;
3273	MethodName: string;
3274	ParamValues: array of const): OleVariant;
3275	var
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;
3285	begin
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;
3393	end;
3394
3395	function ExecScriptEx(WebBrowser: TEmbeddedWB; MethodName: string; ParamValues: array of const): OleVariant;
3396	var
3397	doc: IHTMLDocument2;
3398	dScript: IDispatch;
3399	begin
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;
3406	end;
3407
3408	procedure ExecScript(WebBrowser: TEmbeddedWB; sExpression, sLanguage: string);
3409	// e.g. sLanguage = 'JavaScript';
3410	var
3411	Doc: IHTMLDocument2; // current HTML document
3412	HTMLWin: IHTMLWindow2; // parent window of current HTML document
3413	begin
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;
3425	end;
3426
3427	//To Add--------------------------------------------------
3428
3429	function URLFromShortcut(const dotURL: string): string;
3430	begin
3431	Result := '';
3432	with TIniFile.Create(dotURL) do
3433	try
3434	Result := ReadString('InternetShortcut', 'URL', '');
3435	finally
3436	Free;
3437	end;
3438	end;
3439
3440	function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
3441	var
3442	Handle: THandle;
3443	Info: IQueryInfo;
3444	W: PWideChar;
3445	begin
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)));
3456	end;
3457
3458	function StringToVarArray(const S: string): Variant;
3459	begin
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;
3467	end;
3468
3469	function VarArrayToString(const V: Variant): string;
3470	var
3471	i, j: Integer;
3472	begin
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;
3479	end;
3480
3481	function Encode(const S: string): string;
3482	var
3483	I: Integer;
3484	Hex: string;
3485	begin
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;
3501	end;
3502
3503	function IE5_Installed: Boolean;
3504	var
3505	Reg: TRegistry;
3506	S: string;
3507	begin
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);
3521	end;
3522
3523	function GetIEVersionMajor: Integer;
3524	var
3525	i: Integer;
3526	s: string;
3527	begin
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;
3539	end;
3540
3541	function GetIEVersion: string;
3542	var
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;
3551	begin
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;
3588	end;
3589
3590	function ResolveUrlIni(Filename: string): string;
3591	var
3592	ini: TiniFile;
3593	begin
3594	Result := '';
3595	ini := TIniFile.Create(Filename);
3596	try
3597	Result := ini.ReadString('InternetShortcut', 'URL', '');
3598	finally
3599	ini.Free;
3600	end;
3601	end;
3602
3603	function ResolveUrlIntShCut(Filename: string): string;
3604	var
3605	IURL: IUniformResourceLocator;
3606	PersistFile: IPersistfile;
3607	FName: array[0..MAX_PATH] of WideChar;
3608	p: PChar;
3609	begin
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;
3619	end;
3620
3621	function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
3622	var
3623	pidlChannel: PItemIDList;
3624	psfDesktop: IShellFolder;
3625	pShellLink: IShellLink;
3626	begin
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);
3637	end;
3638
3639	function ResolveLink(const Path: string): string;
3640	var
3641	link: IShellLink;
3642	storage: IPersistFile;
3643	filedata: TWin32FindData;
3644	buf: array[0..MAX_PATH] of Char;
3645	widepath: WideString;
3646	begin
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;
3657	end;
3658
3659	function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
3660	var
3661	Flags: UINT;
3662	begin
3663	Flags := SFGAO_FOLDER;
3664	ShellFolder.GetAttributesOf(1, ID, Flags);
3665	Result := SFGAO_FOLDER and Flags <> 0;
3666	end;
3667
3668	function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
3669	var
3670	FileInfo: TShFileInfo;
3671	begin
3672	SHGetFileInfo(Pchar(ID), 0, FileInfo, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_TYPENAME);
3673	Result := BOOL(fileinfo.szTypeName = ChannelShortcut);
3674	end;
3675
3676	function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
3677	var
3678	Flags: UINT;
3679	begin
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;
3686	end;
3687
3688	function GetImageIndex(pidl: PItemIDList): Integer;
3689	var
3690	Flags: UINT;
3691	FileInfo: TSHFileInfo;
3692	begin
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;
3698	end;
3699
3700	{function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
3701	var
3702	StrRet: TStrRet;
3703	begin
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;
3714	end; }
3715
3716	function GetDisplayName(Folder: IShellFolder; PIDL: PItemIDList): string;
3717	var
3718	StrRet: TStrRet;
3719	P: PChar;
3720	Flags: Integer;
3721	begin
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;
3736	end;
3737
3738	{function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
3739	var
3740	StrRet: TStrRet;
3741	begin
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;
3751	end; }
3752
3753	function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
3754	var
3755	StrRet: TStrRet;
3756	P: PChar;
3757	begin
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;
3771	end;
3772
3773	procedure DisposePIDL(ID: PItemIDList);
3774	var
3775	Malloc: IMalloc;
3776	begin
3777	if ID <> nil then
3778	begin
3779	OLECheck(SHGetMalloc(Malloc));
3780	Malloc.Free(ID);
3781	end;
3782	end;
3783
3784	function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
3785	begin
3786	Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb));
3787	CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));
3788	end;
3789
3790	function NextPIDL(IDList: PItemIDList): PItemIDList;
3791	begin
3792	Result := IDList;
3793	Inc(PAnsiChar(Result), IDList^.mkid.cb);
3794	end;
3795
3796	function GetPIDLSize(IDList: PItemIDList): Integer;
3797	begin
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;
3808	end;
3809
3810	procedure StripLastID(IDList: PItemIDList);
3811	var
3812	MarkerID: PItemIDList;
3813	begin
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;
3824	end;
3825
3826	function CreatePIDL(Size: Integer): PItemIDList;
3827	var
3828	Malloc: IMalloc;
3829	HR: HResult;
3830	begin
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;
3841	end;
3842
3843	function CopyPIDL(IDList: PItemIDList): PItemIDList;
3844	var
3845	Size: Integer;
3846	begin
3847	Size := GetPIDLSize(IDList);
3848	Result := CreatePIDL(Size);
3849	if Assigned(Result) then
3850	CopyMemory(Result, IDList, Size);
3851	end;
3852
3853	function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
3854	var
3855	cb1, cb2: Integer;
3856	begin
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;
3869	end;
3870
3871	function DeleteUrl(Url: PWideChar): HResult;
3872	begin
3873	Result := DeleteUrl(Url);
3874	end;
3875
3876	function GetMailClients: TStrings;
3877	var
3878	Reg: TRegistry;
3879	ts: TStrings;
3880	i: Integer;
3881	begin
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;
3902	end;
3903
3904
3905
3906	end.
3907

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: