Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

EWBTools.pas@ 1176

Last change on this file since 1176 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

Rev	Line
[541]	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@ 1176

Download in other formats: