//***********************************************************
// EwbTools *
// *
// For Delphi *
// Freeware unit *
// by *
// bsalsa, Smot, *
// per lindso larsen *
// *
// Documentation and updated versions: *
// http://www.bsalsa.com *
//***********************************************************
{*******************************************************************************}
{LICENSE:
THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
You may use, change or modify the component under 4 conditions:
1. In your website, add a link to "http://www.bsalsa.com"
2. In your application, add credits to "Embedded Web Browser"
3. Mail me (bsalsa@gmail.com) any code change in the unit
for the benefit of the other users.
4. Please, consider donation in our web site!
{*******************************************************************************}
unit EwbTools;
interface
{$I EWB.inc}
uses
EwbAcc, Windows, Classes, ExtCtrls, ShlObj, Graphics, Dialogs, ActiveX,
{$IFDEF DELPHI6_UP}Variants, {$ENDIF}
MSHTML_EWB, SHDocVw_EWB, EmbeddedWB, URLMon;
var
PrintingWithOptions: Boolean;
//Document and Frame
function DocumentLoaded(Document: IDispatch): Boolean;
procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
//Html
function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
function DocumentSourceText(OleObject: Variant; Document: IDispatch): string;
function DocumentSource(OleObject: Variant): string;
function GetWordAtCursor(const X, Y: Integer; WebBrowser: TEmbeddedWB): string;
//frames
function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2; //By Aladin
function FrameCount(Document: IDispatch): Longint;
function FrameCountFromDocument(SourceDoc: IHTMLDocument2): Integer; //By Aladin
//Document Operations
procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
function CMD_Copy(Document: IDispatch): Boolean;
function Cmd_Paste(Document: IDispatch): Boolean;
function Cmd_Cut(Document: IDispatch): Boolean;
function SelectAll(Document: IDispatch): Boolean;
function UnSelectAll(Document: IDispatch): Boolean;
//scroll
procedure ScrollToTop(OleObject: Variant);
procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
procedure ScrollToBottom(Document: IDispatch);
procedure ScrollToID(ID: Integer; WebBrowser: TEmbeddedWB);
procedure ScrollToIDEx(ID: string; WebBrowser: TEmbeddedWB);
procedure GetScrollBarVisibility(WebBrowser: TEmbeddedWB; var HScroll, VScroll: Boolean);
function GetScrollBarPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
// zoom
function Zoom(Document: IDispatch; ZoomValue: Integer): Boolean;
function ZoomValue(Document: IDispatch): Integer;
function ZoomRangeHigh(Document: IDispatch): Integer;
function ZoomRangeLow(Document: IDispatch): Integer;
function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string; Refresh: Boolean = True): Boolean;
procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth, TargetHeight, TargetWidth: Integer): Boolean;
//View Document Fields/Properties/Images
procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);
//Save
function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HRESULT;
function SaveDocToStream(Document: IDispatch; var AStream: TStream): HRESULT;
function SaveDocToFile(Document: IDispatch; const Fname: string): HRESULT;
//Printing
procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean = False; bCustomHeaderFooter: Boolean = False; Header: string = ''; Footer: string = '');
procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
procedure PrintPreview(Webbrowser: IWebBrowser2);
procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
procedure PrintPreviewFromTemplate(const TemplateFileName: string; Document: IDispatch);
function PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean): Boolean;
procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): string;
procedure RestorePrintValues;
//Dialogs
function OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): Boolean;
function SaveDialog(Document: IDispatch): Boolean; overload;
function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent; ATitle: string = ''; AFilter: string = ''): string; overload;
function ShowInternetOptions(Document: IDispatch): Boolean;
function ShowPageProperties(Document: IDispatch): Boolean;
function ShowOrganizeFavorites(Handle: THandle): Boolean;
procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
function ShowFindDialog(Document: IDispatch): Boolean;
procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
function ViewPageSourceHtml(Document: IDispatch): Boolean;
procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);
//Open external programs
procedure OpenAddressBook;
procedure OpenEudoraMail;
procedure OpenOutlookExpressMail;
procedure OpenOutlookMail;
procedure OpenRegistryEditor;
function OpenCalendar: Boolean;
function OpenClient(Client: string): Boolean;
function OpenNetMeeting: Boolean;
function OpenNewsClient: Boolean;
procedure DoExploreFolder(Handle: THandle; Path: string);
procedure OpenIEBrowserWithAddress(Handle: THandle);
//Open specific webpages
function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);
//Navigate & Download
procedure Go(WebBrowser: TEmbeddedWB; Url: string);
procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
function DownloadFile(SourceFile, TargetFile: string): Boolean;
procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
//Get Special Folders/URL paths etc.
function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
function GetShellFolderPath(FolderName: Widestring): string;
function GetIEHomePage: string;
function GetCachePath: string;
function GetCachedFileFromURL(ItemUrl: string): string;
function GetDefaultBrowserFromRegistry: string;
function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
//E-Mail functions
procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
function CreateNewMail: Boolean;
procedure SendUrlInMail(LocationURL, LocationName: WideString);
//Search in Document & Fill Forms
function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
//function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; const iPos: Integer = 1): IHTMLTxtRange;
function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; aTypeSearch: Integer; const iPos: Integer = 1): IHTMLTxtRange;
procedure SearchAndHighlight(Document: IDispatch;
AText: string; const ACaption, APrompt: string; Flags: TSearchFlags = [];
cbackColor: string = 'yellow'; cForeColor: string = '';
ScrollIntoView: TScrollIntoView = sivNoScroll; ShowInputQuery: Boolean = True); overload;
procedure SearchAndHighlight(Document: IDispatch; aText: string; Flags: TSearchFlags = [];
cbackColor: string = 'yellow'; cForeColor: string = '';
ScrollIntoView: TScrollIntoView = sivNoScroll); overload;
procedure SetTextAreaValue(Document: IDispatch; sName, sValue: string; Options: TFindOptions);
function FillForm(WebBrowser: TEmbeddedWB; FieldName, FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
function FillForm(Document: IDispatch; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; Value: Boolean): Boolean; overload;
function GetFieldValue(OleObject: Variant; FieldName: string): string;
procedure ClickInputImage(WebBrowser: TEmbeddedWB; ImageURL: string);
procedure FillIEFormAndExcecute;
//Clearing
procedure ClearCache;
procedure ClearTypedUrls;
//Online Status
function CheckOnlineStatus: Boolean;
function IsGlobalOffline: Boolean;
procedure WorkOffline();
procedure WorkOnline();
//Restricted & Trusted Lists
function CheckIfInRestricredList(const Host: string; SecureSite: Boolean): Boolean;
function CheckIfInTrustedList(const Host: string; SecureSite: Boolean): Boolean;
procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
//Zone Icon, Security Zone, SSL Status
procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
function GetZoneAttributes(const URL: string): TZoneAttributes;
function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;
//Proxy & User agent
function SetProxy(UserAgent, Address: string): Boolean; overload;
function SetProxy(UserAgent, Address, UserName, Password: string; Port: Integer): Boolean; overload;
function SetProxyFromPAC(UserAgent, PACFile: string): Boolean;
function RemoveProxy(): Boolean;
procedure RemoveUserAgent(UserAgent: string);
//MIME Filter & NameSpace
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
function RegisterNameSpace(clsid: TGUID): HRESULT;
function UnregisterNameSpace: HRESULT;
//Cookies
function GetCookiesPath: string;
procedure ClearSessionCookies;
//Favorites
function OrganizeFavorite(h: THandle; Path: PAnsiChar): Boolean; stdcall; overload;
{$IFDEF UNICODE}
function OrganizeFavorite(h: THandle; Path: PWideChar): Boolean; overload;
{$ENDIF UNICODE}
function URLFromFavorites(const dotURL: string): string;
function GetFavoritesPath: string;
procedure AddToFavorites(URL, Title: string);
//History
function GetHistoryPath: string;
function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
procedure ClearHistory;
//Pages
procedure SetNewHomePage(HomePage: string);
function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;
//Code accessories
procedure Wait(WebBrowser: TEmbeddedWB);
function InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant): HRESULT;
function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;
//Execute Script
procedure ExecScript(WebBrowser: TEmbeddedWB; sExpression, sLanguage: string);
function ExecScriptEx(WebBrowser: TEmbeddedWB; MethodName: string; ParamValues: array of const): OleVariant;
function WBExecScript(TargetObj: IDispatch; MethodName: string; ParamValues: array of const): OleVariant;
//Miscellaneous
procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
procedure ShowIEVersionInfo(Handle: THandle);
procedure CreateDesktopShortcut(Handle: THandle);
procedure DisableNavSound(bDisable: Boolean);
//----- add to ewb-------------------------------------------------------
function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
function CopyPIDL(IDList: PItemIDList): PItemIDList;
function CreatePIDL(Size: Integer): PItemIDList;
function DeleteUrl(Url: PWideChar): HResult;
function Encode(const S: string): string;
function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
function GetIEVersion: string;
function GetIEVersionMajor: Integer;
function GetImageIndex(pidl: PItemIDList): Integer;
function GetMailClients: TStrings;
function GetPIDLSize(IDList: PItemIDList): Integer;
function IE5_Installed: Boolean;
function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function NextPIDL(IDList: PItemIDList): PItemIDList;
function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
function ResolveLink(const Path: string): string;
function ResolveUrlIni(FileName: string): string;
function ResolveUrlIntShCut(FileName: string): string;
function StringToVarArray(const S: string): Variant;
function URLFromShortcut(const dotURL: string): string;
function VarArrayToString(const V: Variant): string;
procedure DisposePIDL(ID: PItemIDList);
procedure StripLastID(IDList: PItemIDList);
function IsWinXPSP2OrLater(): Boolean;
function EncodeUrl(const InputStr: string; const bQueryStr: Boolean): string;
function DecodeURL(const InputStr: string): string;
function IsValidProtocol(URL: string): Boolean;
function ImportCertFile(AFileName, AStoreType: string): Boolean;
//--end of add to ewb---------------------------------
implementation
uses
Registry, ShellAPI, Controls, Messages, Forms, SysUtils,
OleCtrls, WinInet, SendMail_For_EWB, ComObj, IEConst, IniFiles, JPEG, WinSock,
Wcrypt2, Browse4Folder, EWBCoreTools;
type
OSVERSIONINFOEX = packed record
dwOSVersionInfoSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
szCSDVersion: array[0..127] of Char;
wServicePackMajor: WORD;
wServicePackMinor: WORD;
wSuiteMask: WORD;
wProductType: BYTE;
wReserved: BYTE;
end;
TOSVersionInfoEx = OSVERSIONINFOEX;
POSVersionInfoEx = ^TOSVersionInfoEx;
type
fn_VerifyVersionInfo = function(var VersionInformation: OSVERSIONINFOEX;
dwTypeMask: DWORD; dwlConditionMask: LONGLONG): BOOL; stdcall;
fn_VerSetConditionMask = function(ConditionMask: LONGLONG; TypeMask: DWORD;
Condition: Byte): LONGLONG; stdcall;
function ImportCertFile(AFileName, AStoreType: string): Boolean;
var
f: file; //by Ray
encCert: PByte;
encCertLen: DWORD;
store: HCERTSTORE;
context: PCCERT_CONTEXT;
n: PCCERT_CONTEXT;
encType: DWORD;
begin
Result := False;
if FileExists(AFileName) then
begin
AssignFile(f, AFileName);
Reset(f, 1);
encCertLen := FileSize(f);
GetMem(encCert, encCertLen);
BlockRead(f, encCert^, encCertLen);
CloseFile(f);
try
encType := PKCS_7_ASN_ENCODING or X509_ASN_ENCODING;
context := CertCreateCertificateContext(encType, encCert, encCertLen);
if context <> nil then
begin
store := CertOpenSystemStore(0, PChar(AStoreType));
if store <> nil then
begin
n := nil;
Result := CertAddCertificateContextToStore(store, context,
CERT_STORE_ADD_REPLACE_EXISTING, n);
CertCloseStore(store, 0);
CertFreeCertificateContext(context);
end;
end;
finally
FreeMem(encCert, encCertLen);
end;
end;
end;
function IsWinXPSP2OrLater(): Boolean;
var
osvi: TOSVersionInfoEx;
dwlConditionMask: LONGLONG;
op: Integer;
hlib: THandle;
VerifyVersionInfo: fn_VerifyVersionInfo;
VerSetConditionMask: fn_VerSetConditionMask;
begin
Result := False;
hLib := LoadLibrary('kernel32.dll');
if (hLib <> 0) then
begin
@VerifyVersionInfo := GetProcAddress(hLib, 'VerifyVersionInfoA');
@VerSetConditionMask := GetProcAddress(hLib, 'VerSetConditionMask');
if ((@VerifyVersionInfo = nil) or (@VerSetConditionMask = nil)) then
Exit;
dwlConditionMask := 0;
op := VER_GREATER_EQUAL;
// Initialize the OSVERSIONINFOEX structure.
ZeroMemory(@osvi, SizeOf(OSVERSIONINFOEX));
osvi.dwOSVersionInfoSize := SizeOf(OSVERSIONINFOEX);
osvi.dwMajorVersion := 5;
osvi.dwMinorVersion := 1;
osvi.wServicePackMajor := 2;
osvi.wServicePackMinor := 0;
// Initialize the condition mask.
dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MAJORVERSION, op);
dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_MINORVERSION, op);
dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMAJOR, op);
dwlConditionMask := VerSetConditionMask(dwlConditionMask, VER_SERVICEPACKMINOR, op);
// Perform the test.
Result := VerifyVersionInfo(osvi, VER_MAJORVERSION or VER_MINORVERSION or
VER_SERVICEPACKMAJOR or VER_SERVICEPACKMINOR, dwlConditionMask);
end;
end;
function EncodeURL(const InputStr: string; const bQueryStr: Boolean): string;
var
Idx: Integer;
begin
Result := '';
for Idx := 1 to Length(InputStr) do
begin
case InputStr[Idx] of
'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
Result := Result + InputStr[Idx];
' ':
if bQueryStr then
Result := Result + '+'
else
Result := Result + '%20';
else
Result := Result + '%' + SysUtils.IntToHex(Ord(InputStr[Idx]), 2);
end;
end;
end;
function DecodeURL(const InputStr: string): string;
var
Idx: Integer;
Hex: string;
Code: Integer;
begin
Result := '';
Idx := 1;
while Idx <= Length(InputStr) do
begin
case InputStr[Idx] of
'%':
begin
if Idx <= Length(InputStr) - 2 then
begin
Hex := InputStr[Idx + 1] + InputStr[Idx + 2];
Code := SysUtils.StrToIntDef('$' + Hex, -1);
Inc(Idx, 2);
end
else
Code := -1;
if Code = -1 then
raise SysUtils.EConvertError.Create('Invalid HEX digit in URL');
Result := Result + Chr(Code);
end;
'+':
Result := Result + ' '
else
Result := Result + InputStr[Idx];
end;
Inc(Idx);
end;
end;
function IsValidProtocol(URL: string): Boolean;
const
Protocols: array[1..11] of string = ('ftp://', 'http://', 'https://',
'gopher://', 'mailto:', 'news:', 'nntp://', 'telnet://', 'wais://',
'file://', 'prospero://');
var
I: Integer;
begin
Result := False;
URL := SysUtils.LowerCase(URL);
for I := Low(Protocols) to High(Protocols) do
if Pos(Protocols[I], URL) <> 0 then
begin
Result := True;
Break;
end;
end;
function DocumentLoaded(Document: IDispatch): Boolean;
var
iDoc: IHTMLDocument2;
begin
Result := False;
if Assigned(Document) then
begin
Document.QueryInterface(IHTMLDocument2, iDoc);
Result := Assigned(iDoc);
end;
end;
procedure AssignEmptyDocument(WebBrowser: TEmbeddedWB);
begin
WebBrowser.Go('about:blank');
end;
function AddHtmlToAboutBlank(WebBrowser: TEmbeddedWB; StringToHtml: string): Boolean;
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser.Navigate('about:' + StringToHtml, Flags, TargetFrameName, PostData, Headers);
Result := True;
end;
function GetWordAtCursor(const X, Y: Integer; WebBrowser: TEmbeddedWB): string;
var
Doc: IHTMLDocument2;
Selection: IHTMLSelectionObject;
Range: IHTMLTxtRange;
begin
Result := '';
if WebBrowser.DocumentLoaded(Doc) then
begin
Selection := (Doc as IHTMLDocument2).selection;
if Assigned(Selection) then
begin
Range := Selection.createRange as IHTMLTxtRange;
Range.moveToPoint(X, Y);
Range.moveStart('word', -1);
Range.moveEnd('word', 1);
Result := Trim(Range.text);
end;
end;
end;
procedure PrintPreviewFromTemplate(const TemplateFileName: string; Document: IDispatch);
var
OleCommandTarget: IOleCommandTarget;
ParamIn, EmptyParam: OleVariant;
begin
if Assigned(Document) then
begin
EmptyParam := EmptyStr;
Document.QueryInterface(IID_IoleCommandTarget, OLECOMMANDTARGET);
ParamIn := TemplateFileName;
OleCommandTarget.Exec(
nil,
OLECMDID_PRINTPREVIEW,
OLECMDEXECOPT_PROMPTUSER,
ParamIn, EmptyParam);
end;
end;
procedure ScrollToIDEx(ID: string; WebBrowser: TEmbeddedWB);
var
Doc3: IHTMLDocument3;
Elem: IHTMLElement;
RV: IHTMLRect;
begin
Doc3 := WebBrowser.Doc3;
if Assigned(Doc3) then
begin
Elem := Doc3.getElementById(ID);
if Assigned(Elem) then
begin
RV := (Elem as IHTMLElement2).getBoundingClientRect;
Webbrowser.Doc2.parentWindow.scrollBy(RV.left, RV.top);
end;
end;
end;
procedure ScrollToID(ID: Integer; WebBrowser: TEmbeddedWB);
var
Doc: IHTMLDocument2;
ACollection: IHTMLElementCollection;
Elem: IHTMLElement;
Match: IHTMLElement2;
I: Integer;
S: string;
RV: IHTMLRect;
begin
if WebBrowser.DocumentLoaded(Doc) then
begin
ACollection := Doc.all;
if Assigned(ACollection) then
begin
Match := nil;
S := IntToStr(ID);
for I := 0 to ACollection.length - 1 do
begin
Elem := ACollection.item(I, '') as IHTMLElement;
if Assigned(Elem) and (Elem.id = S) then
begin
Match := Elem as IHTMLElement2;
Break;
end;
end;
if Assigned(Match) then
begin
RV := Match.getBoundingClientRect;
WebBrowser.Doc2.parentWindow.scrollBy(RV.left, RV.top);
end;
end;
end;
end;
// Get SysListView32 Child from the Webbrowser Control
function GetWBLV(WBHandle: HWND): HWND;
var
WND: HWND;
begin
Result := 0;
Wnd := GetNextWindow(WBHandle, GW_CHILD);
while (Result = 0) and (WND <> 0) do
begin
Result := FindWindowEx(Wnd, 0, 'SysListView32', nil);
Wnd := GetNextWindow(Wnd, GW_CHILD)
end;
end;
// Check if the horizontal / vertical Scrollbars are visible
procedure GetScrollBarVisibility(WebBrowser: TEmbeddedWB; var HScroll, VScroll: Boolean);
var
WndLV: HWND;
IDoc: IHTMLDocument2;
begin
VScroll := False;
HScroll := False;
WndLV := GetWBLV(WebBrowser.Handle);
if WndLV = 0 then
begin
if Assigned(WebBrowser.Document) and (Succeeded(WebBrowser.Document.QueryInterface(IHTMLDocument2, IDoc))) then
begin
IDoc := WebBrowser.Document as IHTMLDocument2;
if Assigned(IDoc) and Assigned((IHTMLDocument2(IDoc).Body)) then
begin
VScroll := WebBrowser.OleObject.Document.body.ScrollHeight > WebBrowser.OleObject.Document.Body.ClientHeight;
HScroll := (WebBrowser.OleObject.Document.body.ScrollWidth > WebBrowser.OleObject.Document.Body.ClientWidth);
end;
end;
end else
begin
// if the WB is in "ListView" mode:
VScroll := ((GetWindowLong(WndLV, GWL_STYLE) and WS_VSCROLL) <> 0);
HScroll := ((GetWindowLong(WndLV, GWL_STYLE) and WS_HSCROLL) <> 0)
end;
end;
// Get TEmbeddedWB Scrollbar X,Y Position
function GetScrollBarPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
// Get Scrollbar X,Y Position of the ListView
function WB_GetLVScrollPosition(WebBrowser: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
var
lpsi: TScrollInfo;
WndLV: HWND;
begin
Result := False;
// Retrieve SysListView32 Child of TEmbeddedWB
WndLV := GetWBLV(WebBrowser.Handle);
if WndLV <> 0 then // SysListView32 found
begin
// initialize TScrollInfo
FillChar(lpsi, SizeOf(lpsi), 0);
with lpsi do
begin
cbSize := SizeOf(lpsi);
fMask := SIF_POS;
end;
// Get ScrollInfos from the vertical Scrollbar
if GetScrollInfo(WndLV, SB_VERT, lpsi) then
begin
ScrollPos.Y := lpsi.nPos;
// Get ScrollInfos from the horizontal Scrollbar
if GetScrollInfo(WndLV, SB_HORZ, lpsi) then
begin
ScrollPos.X := lpsi.nPos;
Result := True;
end;
end;
end;
end;
// Get Scrollbar X,Y Position of the HTML Document
function WB_GetDOCScrollPosition(WB: TEmbeddedWB; var ScrollPos: TPoint): Boolean;
var
IDoc: IHTMLDocument2;
IDoc3: IHTMLDocument3;
IElement: IHTMLElement;
begin
ScrollPos := Point(-1, -1);
Result := False;
if Assigned(WebBrowser.Document) and (Succeeded(WebBrowser.Document.QueryInterface(IHTMLDocument2, IDoc))) then
begin
IDoc := WebBrowser.Document as IHTMLDocument2;
if Assigned(IDoc) and Assigned((IHTMLDocument2(IDoc).Body)) then
begin
if (IDoc.QueryInterface(IHTMLDocument3, IDoc3) = S_OK) then
if Assigned(IDoc3) then
IElement := IDoc3.get_documentElement;
if (Assigned(IElement)) and (Variant(IDoc).DocumentElement.scrollTop = 0) then
ScrollPos.Y := IHTMLDocument2(IDoc).Body.getAttribute('ScrollTop', 0)
else
ScrollPos.Y := Variant(IDoc).DocumentElement.scrollTop;
if Assigned(IElement) and (Variant(IDoc).DocumentElement.scrollLeft = 0) then
ScrollPos.X := IHTMLDocument2(IDoc).Body.getAttribute('ScrollLeft', 0)
else
ScrollPos.X := Variant(IDoc).DocumentElement.scrollLeft
end;
Result := (ScrollPos.X <> -1) and (ScrollPos.Y <> -1)
end;
end;
begin
Result := WB_GetDOCScrollPosition(WebBrowser, ScrollPos);
if not Result then
Result := WB_GetLVScrollPosition(WebBrowser, ScrollPos);
end;
function DocumentSource(OleObject: Variant): string;
var
Strings: TStringList;
begin
Strings := TStringList.Create;
try
ViewPageSourceHTMLToStrings(OleObject, OleObject.Document, Strings);
Result := Strings.Text;
finally
FreeAndNil(Strings);
end;
end;
function DocumentSourceText(OleObject: Variant; Document: IDispatch): string;
var
Strings: TStringList;
begin
Strings := TStringList.Create;
try
EwbTools.ViewPageSourceTextToStrings(OleObject, Document, Strings);
Result := Strings.Text;
finally
FreeAndNil(Strings);
end;
end;
function GetFrame(Document: IDispatch; FrameNo: Integer): IWebBrowser2;
var
OleContainer: IOleContainer;
enum: ActiveX.IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
if Assigned(Document) then
begin
Fetched := nil;
OleContainer := Document as IOleContainer;
if OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum) = S_OK then
begin
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
Result := Unk as IWebBrowser2;
end else
Result := nil;
end
else
Result := nil;
end;
function FrameCount(Document: IDispatch): LongInt;
var //fix by Aladin
OleContainer: IOleContainer;
enum: ActiveX.IEnumUnknown;
FetchedContrs: LongInt;
Unknown: IUnknown;
IWeb: IWebBrowser2;
begin
Result := 0; //bsalsa
if not DocumentLoaded(Document) then Exit;
OleContainer := Document as IOleContainer;
if OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum) = S_OK then
begin
while Enum.Next(1, Unknown, @FetchedContrs) = S_OK do
begin
if Unknown.QueryInterface(IID_IWebBrowser2, IWeb) = S_OK then //check if it is frame
Inc(Result);
end;
end;
end;
function FrameCountFromDocument(SourceDoc: IHTMLDocument2): Integer;
var //by Aladin
OleContainer: IOleContainer;
enum: ActiveX.IEnumUnknown;
unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
EnumResult: HRESULT;
begin
Result := 0;
if not DocumentLoaded(SourceDoc) then Exit;
OleContainer := SourceDoc as IOleContainer;
EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
if EnumResult = S_OK then
// Added per OLE help
Enum.Next(100, Unk, @Result)
else // Added per OLE help
Enum := nil;
end;
procedure SetFocusToDoc(WebBrowser: TEmbeddedWB; Dispatch, Document: IDispatch);
begin
if DocumentLoaded(Document) then
with (Dispatch as IOleObject) do
DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser, 0, WebBrowser.Handle, WebBrowser.ClientRect);
end;
function CMD_Copy(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, False, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
function CMD_Paste(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, False, OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
function CMD_Cut(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, False, OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
function SelectAll(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, False, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
function UnSelectAll(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, False, OLECMDID_CLEARSELECTION, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
procedure ScrollToTop(OleObject: Variant);
begin
try
if DocumentLoaded(OleObject.Document) then
OleObject.Document.ParentWindow.ScrollTo(0, 0);
except
end;
end;
procedure ScrollToPosition(OleObject: Variant; X, Y: Integer);
begin
try
if DocumentLoaded(OleObject.Document) then
OleObject.Document.ParentWindow.ScrollTo(X, Y);
except
end;
end;
procedure ScrollToBottom(Document: IDispatch);
var
HTMLParentWin: IHTMLWindow2;
Doc2: IHTMLDocument2;
begin
try
if Supports(Document, IHTMLDocument2, Doc2) then
begin
// OleObject.Document.ParentWindow.ScrollTo(0, MaxInt); doesn't work in IE8
HTMLParentWin := IHTMLWindow2((Doc2 as IHTMLDocument2).parentWindow);
HTMLParentWin.scrollBy(0, (Doc2.body as IHTMLElement2).scrollHeight);
end;
except
end;
end;
function Zoom(Document: IDispatch; ZoomValue: Integer): Boolean;
var
vaIn, vaOut: OleVariant;
begin
if ZoomValue < ZoomRangeLow(Document) then
vaIn := ZoomRangeLow(Document)
else
if ZoomValue > ZoomRangeHigh(Document) then
vaIn := ZoomRangeHigh(Document)
else
vaIn := ZoomValue;
Result := InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut) = S_OK;
end;
function ZoomValue(Document: IDispatch): Integer;
var
vaIn, vaOut: OleVariant;
begin
vaIn := null;
InvokeCmd(Document, False, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
Result := vaOut;
end;
function ZoomRangeHigh(Document: IDispatch): Integer;
var
vaIn, vaOut: OleVariant;
begin
InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
Result := HiWord(DWORD(vaOut));
end;
function ZoomRangeLow(Document: IDispatch): Integer;
var
vaIn, vaOut: OleVariant;
begin
InvokeCmd(Document, False, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
Result := LoWord(DWORD(vaOut));
end;
function SetCharartersSet(WebBrowser: TEmbeddedWB; Document: IDispatch; const ACharactersSet: string; Refresh: Boolean = True): Boolean;
var
RefreshLevel: OleVariant;
begin
Wait(WebBrowser);
Result := False;
if DocumentLoaded(Document) then
begin
try
WebBrowser.Doc2.Set_CharSet(ACharactersSet);
Result := True;
if Refresh then
begin
RefreshLevel := 7;
WebBrowser.Refresh2(RefreshLevel);
end;
except
end;
end;
end;
{
function GetCookie(OleObject: Variant): string;
begin
Result := '';
if DocumentLoaded(OleObject.Document) then
try
Result := OleObject.Document.Cookie;
except
end;
end; }
procedure ClearSessionCookies;
begin
InternetSetOption(nil, INTERNET_OPTION_END_BROWSER_SESSION, nil, 0);
end;
procedure GetThumbnail(Dispatch: IDispatch; var Image: TImage);
var
DrawRect: TRect;
begin
if Image = nil then
Exit;
DrawRect := Rect(0, 0, Image.Height, Image.Width);
Image.Picture.Bitmap.Height := Image.Height;
Image.Picture.Bitmap.Width := Image.Width;
(Dispatch as IViewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0,
Image.Canvas.Handle, @DrawRect, nil, nil, 0);
Image.Refresh;
end;
function GetBmpFromBrowser(Document: IDispatch; Handle: THandle; Width, Height: Integer; FileName: string): Boolean;
var
ViewObject: IViewObject;
sourceDrawRect: TRect;
ScreenImg: Graphics.TBitmap;
begin
Result := False;
if DocumentLoaded(Document) then
try
Document.QueryInterface(IViewObject, ViewObject);
if Assigned(ViewObject) then
try
ScreenImg := TBitmap.Create;
ScreenImg.Height := Height;
ScreenImg.Width := Width;
sourceDrawRect := Rect(0, 0, ScreenImg.Width, ScreenImg.Height);
ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Handle,
ScreenImg.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
ScreenImg.SaveToFile(FileName);
Result := True;
finally
ViewObject._Release;
end;
except
Result := False;
end;
end;
function GetJPEGfromBrowser(Document: IDispatch; ControlInterface: IWebBrowser2; FileName: string; SourceHeight, SourceWidth,
TargetHeight, TargetWidth: Integer): Boolean;
var
sourceDrawRect: TRect;
targetDrawRect: TRect;
sourceBitmap: Graphics.TBitmap;
targetBitmap: Graphics.TBitmap;
aJPG: TJPEGImage;
aViewObject: IViewObject;
IWeb: IWebBrowser2;
begin
Result := False;
sourceBitmap := Graphics.TBitmap.Create;
targetBitmap := Graphics.TBitmap.Create;
aJPG := TJPEGImage.Create;
IWeb := ControlInterface;
try
try
sourceDrawRect := Rect(0, 0, SourceWidth, SourceHeight);
sourceBitmap.Width := SourceWidth;
sourceBitmap.Height := SourceHeight;
aViewObject := IWeb as IViewObject;
if aViewObject = nil then
Exit;
OleCheck(aViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil,
Forms.Application.Handle,
sourceBitmap.Canvas.Handle,
@sourceDrawRect, nil, nil, 0));
targetDrawRect := Rect(0, 0, TargetWidth, TargetHeight);
targetBitmap.Height := TargetHeight;
targetBitmap.Width := TargetWidth;
targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);
aJPG.Assign(targetBitmap);
aJPG.SaveToFile(FileName);
Result := True;
finally
aJPG.Free;
sourceBitmap.Free;
targetBitmap.Free;
end;
except
Result := False;
end;
end;
procedure ViewPageLinksToStrings(OleObject: Variant; LinksList: TStrings);
var //by smot
UNum: Variant;
s: string;
procedure RecurseLinks(htmlDoc: Variant);
var
BodyElement, ElementCo, HTMLFrames, HTMLWnd, doc: OleVariant;
j, i: Integer;
begin
if VarIsEmpty(htmlDoc) then Exit;
BodyElement := htmlDoc.body;
if BodyElement.tagName = 'BODY' then
begin
ElementCo := htmlDoc.links;
j := ElementCo.Length - 1;
for i := 0 to j do
begin
UNum := ElementCo.item(i);
s := UNum.href;
if j = 0 then
s := 'No Links found in the page body';
LinksList.Add(s);
end;
end;
HTMLFrames := htmlDoc.Frames;
j := HTMLFrames.Length - 1;
for i := 0 to j do
begin
HTMLWnd := HTMLFrames.Item(i);
try
doc := HTMLWnd.Document;
RecurseLinks(doc);
except
Continue;
end;
end;
end;
begin
LinksList.Clear;
if not DocumentLoaded(OleObject.Document) then
Exit;
RecurseLinks(OleObject.Document);
end;
procedure ViewPageSourceHTMLToStrings(OleObject: Variant; Document: IDispatch; HtmlList: TStrings);
begin
HtmlList.Clear;
if DocumentLoaded(Document) then
begin
try
HtmlList.Add(VarToStr(OleObject.Document.documentElement.innerHTML));
except
end;
end;
end;
procedure ViewPageSourceTextToStrings(OleObject: Variant; Document: IDispatch; TextList: TStrings);
begin
TextList.Clear;
if DocumentLoaded(Document) then
begin
try
TextList.Add(VarToStr(OleObject.Document.documentElement.innerText));
except
end;
end;
end;
procedure ViewPageSourceText(OleObject: Variant; Document: IDispatch);
var
TextLst: TStringList;
begin
TextLst := TStringList.Create;
try
if DocumentLoaded(Document) then
begin
TextLst.Add(VarToStr(OleObject.Document.documentElement.innerText));
MessageDlg(TextLst.Text, mtCustom, [mbOK], 0);
end;
finally
TextLst.Free;
end;
end;
function SaveDocToStrings(Document: IDispatch; var AStrings: TStrings): HResult;
var
IpStream: IPersistStreamInit;
AStream: TMemoryStream;
begin
Result := S_FALSE;
if not DocumentLoaded(Document) then
Exit;
AStream := TMemoryStream.Create;
try
IpStream := Document as IPersistStreamInit;
if not Assigned(IpStream) then
Result := S_FALSE
else
if Succeeded(IpStream.save(TStreamadapter.Create(AStream), True))
then
begin
AStream.Seek(0, 0);
AStrings.LoadFromStream(AStream);
Result := S_OK;
end;
except
end;
AStream.Free;
end;
function SaveDocToStream(Document: IDispatch; var AStream: TStream): HResult;
var
IpStream: IPersistStreamInit;
begin
if DocumentLoaded(Document) then
begin
IpStream := Document as IPersistStreamInit;
Result := IpStream.Save(TStreamAdapter.Create(AStream), True);
end
else
Result := S_FALSE;
end;
function SaveDocToFile(Document: IDispatch; const Fname: string): HResult;
var
PFile: IPersistFile;
begin
Result := S_FALSE;
if DocumentLoaded(Document) then
begin
PFile := Document as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end;
end;
procedure PrintWithHeaderFooter(ControlInterface: IWebBrowser2; Header, Footer: PWideChar; Options: OLECMDEXECOPT);
var
saBound: TSafeArrayBound;
psaHeadFoot: PSafeArray;
vaIn, vaOut: TVariantArg;
vHeadStr, vFootStr: TVariantArg;
rgIndex: LongInt;
begin
try
saBound.lLbound := 0;
saBound.cElements := 2;
psaHeadFoot := SafeArrayCreate(VT_VARIANT, 1, saBound);
vHeadStr.vt := VT_BSTR;
vHeadStr.bstrVal := SysAllocString(Header);
vFootStr.vt := VT_BSTR;
vFootStr.bstrVal := SysAllocString(Footer);
rgIndex := 0;
OleCheck(SafeArrayPutElement(psaHeadFoot, rgIndex, vHeadStr));
rgIndex := 1;
OleCheck(SafeArrayPutElement(psaHeadFoot, rgIndex, vFootStr));
vaIn.vt := VT_ARRAY or VT_BYREF;
vaIn.parray := psaHeadFoot;
ControlInterFace.ExecWB(OLECMDID_PRINT, Options,
OleVariant(vaIn), OleVariant(vaOut));
if vHeadStr.bstrVal <> nil then
SysFreeString(vHeadStr.bstrVal);
if vFootStr.bstrVal <> nil then
SysFreeString(vFootStr.bstrVal);
except
end;
end;
procedure Print(ControlInterface: IWebBrowser2; bHideSetup: Boolean = False; bCustomHeaderFooter: Boolean = False; Header: string = ''; Footer: string = '');
var
vaIn, vaOut: OleVariant;
begin
if DocumentLoaded(ControlInterface.Document) then
begin
if bCustomHeaderFooter then
begin
if bHideSetup then
PrintWithHeaderFooter(ControlInterface, TaskAllocWideString(Header), TaskAllocWideString(Footer), OLECMDEXECOPT_DONTPROMPTUSER)
else
PrintWithHeaderFooter(ControlInterface, TaskAllocWideString(Header), TaskAllocWideString(Footer), OLECMDEXECOPT_PROMPTUSER);
end
else
if bHideSetup then
ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut)
else
ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut)
end;
end;
procedure PrintWithOptions(ControlInterface: IWebBrowser2; Document: IDispatch; UsePrintOptions, PrintOptionsEnabled, HideSetup: Boolean; var InvokingPageSetup: Boolean);
begin
PrintingWithOptions := True;
PageSetup(Document, UsePrintOptions, PrintOptionsEnabled, InvokingPagesetup);
Print(ControlInterface, HideSetup);
end;
procedure PrintPreview(Webbrowser: IWebBrowser2);
// IE 5.5 only
var
vaIn, vaOut: Olevariant;
begin
if DocumentLoaded(Webbrowser.Document) then
Webbrowser.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
function OpenClient(Client: string): Boolean;
var
s, params, Exec: string;
begin
Result := False;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software\Clients\' + Client, False);
S := ReadString('');
CloseKey;
OpenKey('Software\Clients\' + Client + '\' + S + '\shell\open\command', False);
S := ReadString('');
CloseKey;
if S <> '' then
begin
if Pos('/', S) > 0 then
begin
Exec := system.Copy(S, 1, Pos('/', S) - 2);
Params := system.Copy(s, Length(exec) + 1, length(S));
end
else
begin
Exec := S;
Params := '';
end;
Result := True;
ShellExecute(Application.handle, 'open', PChar(Exec), PChar(Params), '', SW_SHOW);
end;
finally
Free;
end;
end;
procedure PrintPreviewExtended(ControlInterface: IWebBrowser2; nCMDShow: Integer; HideSetup: Boolean);
var
Preview_HWND, App_HWND: THandle;
ClassName: array[0..255] of Char;
StartTime, EndTime: DWORD; //Smot
vaIn, vaOut: OleVariant;
begin
if DocumentLoaded(ControlInterface.Document) then
begin
if HideSetup then
ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut) //jerzy
else
ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);
Preview_HWND := 0;
StartTime := GetTickCount;
repeat
App_HWND := GetForegroundWindow();
GetClassName(App_HWND, ClassName, SizeOf(ClassName));
if lstrcmp(@ClassName[0], @IE_PPREVIEWCLASS[1]) = 0 then
Preview_HWND := App_HWND;
Forms.Application.ProcessMessages;
EndTime := GetTickCount;
until (Preview_HWND <> 0) or (EndTime - StartTime > 7000);
if Preview_HWND <> 0 then
ShowWindow(Preview_HWND, nCmdShow);
end;
end;
function PageSetup(Document: IDispatch; UsePrintOptions, PrintOptionsEnabled: Boolean; var InvokingPageSetup: Boolean): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := False;
if DocumentLoaded(Document) then
begin
if PrintOptionsEnabled and UsePrintOptions then
InvokingPageSetup := True;
Result := InvokeCmd(Document, False, OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK
end;
end;
procedure PrintSetup(ControlInterface: IWebBrowser2; HideSetup: Boolean);
var
vaIn, vaOut: OleVariant;
begin
if DocumentLoaded(ControlInterface.Document) then
begin
if HideSetup then
ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut)
else
ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut)
end;
end;
procedure GetPrintValues(WebBrowser: TEmbeddedWB; PrintOptions: TPrintOptions; Measure: TMeasure);
var
S: string;
Registry: TRegistry;
function ReadMargin(key: string): Real;
begin
S := Registry.ReadString(key);
if S = '' then
S := '0.750000'; // <-- default margin value by takeru_tk_81
S := StringReplace(S, ' ', '', [rfReplaceAll]);
if DecimalSeparator <> '.' then
S := StringReplace(S, '.', DecimalSeparator, []);
if Measure = mMetric then
Result := StrToFloat(S) * InchToMetric
else
Result := StrToFloat(S);
end;
begin
Registry := TRegistry.Create;
try
with Registry do
begin
RootKey := HKEY_CURRENT_USER;
if OpenKey('Software\Microsoft\Internet Explorer\PageSetup', False) then
begin
with PrintOptions do
begin
Header := ReadString('header');
Footer := ReadString('footer');
Margins.Left := ReadMargin('margin_left');
Margins.Right := ReadMargin('margin_right');
Margins.Top := ReadMargin('margin_top');
Margins.Bottom := ReadMargin('margin_bottom');
end;
end;
Registry.Free;
end;
except
end;
end;
function PrintMarginStr(Measure, RuntimeMeasure: TMeasure; M: Real): string;
begin
if Measure <> RuntimeMeasure then
begin
if RuntimeMeasure = mMetric then
Result := FloatToStr(M * InchToMetric)
else
Result := FloatToStr(M / InchToMetric);
end
else
Result := FloatToStr(M);
end;
procedure RestorePrintValues;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
with Reg do
begin
RootKey := HKEY_CURRENT_USER;
if OpenKey('Software\Microsoft\Internet Explorer\PageSetup', True) then
begin
WriteString('header', '&w&bPage &p of &P');
WriteString('footer', '&u&b&d');
WriteString('margin_left', '0.750000');
WriteString('margin_right', '0.750000');
WriteString('margin_top', '0.750000');
WriteString('margin_bottom', '0.750000');
end;
Reg.Free;
end;
except
MessageDlg('Error while writing page print values to the registry!', mtError, [mbOK], 0);
end;
end;
function OpenDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent): Boolean;
var
OD: TOpenDialog;
begin
OD := TOpenDialog.Create(AOwner);
try
with OD do
begin
Filter := 'Internet Files|*.htm; *.html; *.url; *.mht; *.mhtml; *.php *.asp'
+ #10 + #13 + '|Image Files| *.gif;*.bmp;*.ico;*.jpg;*.png;*.wmf; *.emf; '
+ #10 + #13 + '|Text & Documents Files| *.txt;*.doc;*.xls;*.dot;'
+ #10 + #13 + '|Compressed Files| *.zip;'
+ #10 + #13 + '|XML Files| *.xml;'
+ #10 + #13 + '|Any Files|*.*';
Options := Options + [ofShowHelp, ofEnableSizing];
Title := 'Browser - Open Dialog';
HelpContext := 0;
Result := Execute;
if Result then
WebBrowser.Go(OD.FileName);
end;
finally
OD.Free;
end;
end;
function SaveDialog(WebBrowser: TEmbeddedWB; AOwner: TComponent; ATitle: string = ''; AFilter: string = ''): string;
var
SD: TSaveDialog;
begin
SD := TSaveDialog.Create(AOwner);
try
with SD do
begin
if AFilter = '' then
Filter := 'Internet Files|*.htm; *.html;*.mht; *.mhtml; *.php *.asp'
+ #10 + #13 + '|Text & Documents Files| *.txt;*.doc;*.xls;*.dot;'
+ #10 + #13 + '|XML Files| *.xml;'
+ #10 + #13 + '|Any Files|*.*'
else
Filter := AFilter;
Options := Options + [ofShowHelp, ofEnableSizing];
if ATitle = '' then
Title := 'Browser - Save Dialog';
HelpContext := 0;
if Execute then
Result := SD.FileName;
if SD.FileName <> '' then
WebBrowser.SaveToFile(SD.FileName);
end;
finally
SD.Free;
end;
end;
function SaveDialog(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, False, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
function ShowInternetOptions(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, True, HTMLID_OPTIONS, 0, vaIn, vaOut) = S_OK;
end;
function ShowPageProperties(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin // OLECMDID_SHOWPAGEACTIONMENU
Result := InvokeCmd(Document, False, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) = S_OK;
end;
function ShowOrganizeFavorites(Handle: THandle): Boolean;
begin
Result := OrganizeFavorite(Handle, GetSpecialFolderPath(Handle, CSIDL_FAVORITES));
end;
procedure ShowImportExportFavoritesAndCookies(Handle: THandle);
begin
SendMessage(Handle, WM_COMMAND, ID_IE_FILE_IMPORTEXPORT, 0);
end;
function ShowFindDialog(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, True, HTMLID_FIND, 0, vaIn, vaOut) = S_OK;
end;
procedure SaveImagesDialog(OleObject: Variant; Document: IDispatch);
var
k, p: Integer;
path, Source, dest, ext: string;
begin
if DocumentLoaded(Document) then
begin
// path := TBrowse4Folder.('Web Browser - Please select a destination folder' + #10 + #13
// + 'for the images', 'Desktop');
MessageDlg(Path, mtCustom, [mbYes, mbAll, mbCancel], 0);
begin
for k := 0 to OleObject.Document.Images.Length - 1 do
begin
Source := OleObject.Document.Images.Item(k).Src;
p := LastDelimiter('.', Source);
ext := UpperCase(System.Copy(Source, p + 1, Length(Source)));
if (ext = 'GIF') or (ext = 'JPG') or (ext = 'BMP') or (ext = 'PNG') then
begin
p := LastDelimiter('/', Source);
dest := path + '/Images' + System.Copy(Source, p + 1, Length(Source));
DownloadFile(Source, dest);
end;
end;
end;
end;
end;
function ViewPageSourceHtml(Document: IDispatch): Boolean;
var
vaIn, vaOut: OleVariant;
begin
Result := InvokeCmd(Document, True, HTMLID_VIEWSOURCE, 0, vaIn, vaOut) = S_OK;
end;
procedure SavePageTextDialog(AOwner: TComponent; OleObject: Variant; Document: IDispatch);
var
sd: TSaveDialog;
textStr: TStringList;
begin
if not DocumentLoaded(Document) then Exit;
textstr := TStringList.Create;
try
textStr.Add(VarToStr(OleObject.Document.documentElement.innerText));
begin
sd := TSaveDialog.Create(AOwner);
try
sd.Filter := 'Text file|*.txt|Word file|*.doc';
sd.DefaultExt := 'txt';
sd.FilterIndex := 1;
sd.FileName := 'WebSiteText.txt';
sd.Title := 'Web Site Text';
if sd.Execute then
begin
textStr.SaveToFile(sd.FileName);
end;
finally
sd.Free;
end;
end;
finally
textStr.Free;
end;
end;
procedure ShellExecuteOpen(const sApplication: string);
begin
ShellExecute(Application.Handle, 'open', PChar(sApplication), nil, nil, SW_SHOW);
end;
procedure OpenOutlookMail;
begin
ShellExecuteOpen('outlook.exe');
end;
procedure OpenOutlookExpressMail;
begin
ShellExecuteOpen('msimn.exe');
end;
procedure OpenEudoraMail;
begin
ShellExecuteOpen('eudora.exe');
end;
procedure OpenRegistryEditor;
begin
ShellExecuteOpen('regedit.exe');
end;
function OpenNewsClient: Boolean;
begin
Result := OpenClient('News');
end;
procedure OpenAddressBook;
begin
ShellExecuteOpen('wab.exe');
end;
function OpenCalendar: Boolean;
begin
Result := OpenClient('Calendar');
end;
function OpenNetMeeting: Boolean;
begin
Result := OpenClient('Internet Call');
end;
procedure DoExploreFolder(Handle: THandle; Path: string);
begin
ShellExecute(handle, 'explore', PChar(Path), nil, nil, SW_SHOWNORMAL);
end;
procedure OpenIEBrowserWithAddress(Handle: THandle);
begin
SendMessage(Handle, WM_COMMAND, ID_IE_FILE_NEWWINDOW, 0);
end;
function OpenHotmailMail(WebBrowser: TEmbeddedWB): Boolean;
begin
Result := True;
Go(WebBrowser, 'http://lc1.law5.hotmail.passport.com/cgi-bin/login');
end;
function OpenGoogleMail(WebBrowser: TEmbeddedWB): Boolean;
begin
Result := True;
Go(WebBrowser, 'http://mail.google.com/mail/');
end;
function OpenYahooMail(WebBrowser: TEmbeddedWB): Boolean;
begin
Result := True;
Go(WebBrowser, 'http://mail.yahoo.com/');
end;
procedure GoSearchInGoogle(WebBrowser: TEmbeddedWB; SearchTerm: string);
const
GOOGLE_QUERY = 'http://www.google.com/search?ie=ISO-8859-1&q=';
var
sQuery: string;
begin
sQuery := GOOGLE_QUERY + SearchTerm;
Go(WebBrowser, sQuery);
end;
procedure GoSearchInMSN(WebBrowser: TEmbeddedWB; SearchTerm: string);
const
MSN_QUERY = 'http://search.live.com/results.aspx?q=';
MSN_Const = '&FORM=CBPW&first=1&noredir=1';
var
sQuery: string;
begin
sQuery := MSN_QUERY + SearchTerm + MSN_Const;
Go(WebBrowser, sQuery);
end;
procedure GoSearchInYahoo(WebBrowser: TEmbeddedWB; SearchTerm: string);
const
YAHOO_QUERY = 'http://search.yahoo.com/bin/search?p=';
var
sQuery: string;
begin
sQuery := YAHOO_QUERY + SearchTerm;
WebBrowser.Go(sQuery);
end;
procedure Go(WebBrowser: TEmbeddedWB; Url: string);
var
_URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
_URL := Url;
Flags := 0;
TargetFrameName := 0;
Postdata := 0;
Headers := 0;
if (Trim(_URL) <> '') then
WebBrowser.Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
end;
procedure GoWithQueryDetails(WebBrowser: TEmbeddedWB; Url, Query: string);
var
_URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
_URL := Url + Query;
TargetFrameName := 0;
headers := StringtoVarArray('Content-Type:application/x-www-form-urlencoded'#13#10);
Postdata := StringToVarArray('version=current&name=myname' + #13#10);
Flags := 0;
WebBrowser.Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
end;
procedure GoNoHistory(WebBrowser: TEmbeddedWB; const URL: string);
function StrToChr(Str: string; Pos: Integer): Char;
begin
Result := Str[Pos];
end;
var
Flags: OleVariant;
HistoryStg: IUrlHistoryStg;
begin
Flags := navNoHistory;
WebBrowser.Navigate(WideString(URL), Flags);
Wait(WebBrowser);
HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg;
HistoryStg.DeleteUrl(PWideChar(StrToChr(URL, 0)), 0);
end;
procedure NavigatePidl(WebBrowser: TEmbeddedWB; pidl: PItemIdList);
var
VaEmpty, vaPidl: OleVariant;
psa: PSafeArray;
cbData: UINT;
begin
cbdata := GetPIDLSize(pidl);
psa := SafeArrayCreateVector(VT_UI1, 0, cbData);
if (psa <> nil) then
begin
CopyMemory(psa.pvData, pidl, cbData);
VariantInit(vaPidl);
TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1;
TVariantArg(vaPidl).parray := psa;
WebBrowser.Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty);
VariantClear(vaPidl);
end;
end;
function GetFrameFromDocument(SourceDoc: IHTMLDocument2; FrameNo: Integer): IWebBrowser2;
var //by Aladin
OleContainer: IOleContainer;
enum: ActiveX.IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
Result := nil;
Fetched := nil;
if DocumentLoaded(SourceDoc) then
begin
OleContainer := SourceDoc as IOleContainer;
OleContainer.EnumObjects(OLECONTF_EMBEDDINGS or OLECONTF_OTHERS, Enum);
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
if Supports(Unk, IWebBrowser2, Result) then //perva 2008/12/10
Result := Unk as IWebBrowser2;
end;
end;
procedure GoAboutBlank(WebBrowser: TEmbeddedWB);
begin
WebBrowser.Go('about:blank');
Wait(WebBrowser);
end;
procedure SendPageInMailAsAttachment(WebBrowser: TEmbeddedWB; AOwner: TComponent; Document: IDispatch; mFileName, mSubject, mBody: string);
begin
WebBrowser.SaveToFile(mFileName);
Sleep(800);
with TEwbMapiMail.Create(AOwner) do
begin
try
Subject := mSubject;
Body := mBody;
Attachments.Add(mFileName);
EditDialog := True;
Send;
finally
// Free;
end;
end;
end;
procedure GoDownloadFile(WebBrowser: TEmbeddedWB; URL: string);
var
Flags: OleVariant;
begin
Flags := navNoHistory or navNoReadFromCache or navNoWriteToCache
or navAllowAutosearch or navBrowserBar;
WebBrowser.Navigate(URL, Flags);
end;
function DownloadFile(SourceFile, TargetFile: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(TargetFile), 0, nil) = 0;
except
Result := False;
end;
end;
procedure GoDownloadMaskedFile(SourceFile, TargetFile: string; Notify: Boolean);
begin
if Notify then
begin
if DownloadFile(SourceFile, TargetFile) then
MessageBox(0, PChar('Downloading: ' + SourceFile + #10 + #13 +
'To: ' + TargetFile + #10 + #13 + 'was successfully finished.'),
PChar('Download successful.'), MB_OK)
else
MessageBox(0, PChar(
'An error ocurred while downloading the file.' + SourceFile),
PChar('Downloading Error!!'), MB_ICONERROR or MB_OK);
end
else
DownloadFile(SourceFile, TargetFile);
end;
procedure AddToFavorites(URL, Title: string);
// The URL parameter must specify a valid URL using HTTP, Secure Hypertext Transfer Protocol (HTTPS),
// or File Transfer Protocol (FTP) protocols only. Calling the IShellUIHelper::AddFavorite method with a
// file:// or javascript: URL returns E_ACCESSDENIED.
const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';
var
ShellUIHelper: ISHellUIHelper;
Url1, Title1: OleVariant;
begin
if (Trim(URL) <> '') and (Trim(Title) <> '') then
begin
Title1 := Title;
Url1 := Url;
CoCreateInstance(CLSID_SHELLUIHELPER, nil, CLSCTX_INPROC_SERVER, IID_IShellUIHelper, ShellUIHelper);
try
ShellUIHelper.AddFavorite(URL1, Title1);
except
end;
end;
end;
function GetFavoritesPath: string;
begin
Result := GetShellFolderPath('Favorites');
end;
function GetCookiesPath: string;
begin
Result := GetShellFolderPath('Cookies');
end;
function GetHistoryPath: string;
begin
Result := GetShellFolderPath('History');
end;
function GetCachePath: string;
begin
Result := GetShellFolderPath('Cache');
end;
function GetShellFolderPath(FolderName: Widestring): string;
const
REG_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
var
Reg: TRegistry;
begin
Result := '';
Reg := TRegistry.Create(KEY_READ);
with Reg do
try
Rootkey := HKEY_CURRENT_USER;
OpenKey(REG_PATH, False);
if (ValueExists(FolderName)) and not (length(trim(ReadString(FolderName))) = 0) then
Result := ReadString(FolderName);
finally
CloseKey;
Free;
end;
end;
function GetSpecialFolderPath(CallerHandle: THandle; CSIDL: Integer): PChar;
var
exInfo: TShellExecuteInfo;
Buf: PChar;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST;
Wnd := CallerHandle;
nShow := SW_SHOWNORMAL;
Buf := StrAlloc(MAX_PATH);
try
{$IFDEF UNICODE}
FillChar(Buf^, MAX_PATH * SizeOf(Char), 0);
{$ELSE}
FillChar(Buf^, MAX_PATH, 0);
{$ENDIF UNICODE}
if SHGetSpecialFolderPath(wnd, Buf, CSIDL, True) then
Result := Buf
else
Result := '';
finally
StrDispose(Buf);
end;
end;
end;
function GetIEHomePage: string;
var
HomePage: string;
begin
HomePage := '';
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('\Software\Microsoft\Internet Explorer\Main', False);
HomePage := ReadString('Start Page');
CloseKey;
finally
Free;
end;
Result := HomePage;
end;
function GetCachedFileFromURL(ItemUrl: string): string;
var
IntCacheInfo: PInternetCacheEntryInfo;
CacheEntry, dwEntrySize, dwLastError: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(IntCacheInfo, dwEntrySize);
CacheEntry := FindFirstUrlCacheEntry(nil, IntCacheInfo^, dwEntrySize);
if (CacheEntry <> 0) and (ItemUrl = IntCacheInfo^.lpszSourceUrlName) then
Result := IntCacheInfo^.lpszLocalFileName;
FreeMem(IntCacheInfo);
if Result = '' then
repeat
dwEntrySize := 0;
FindNextUrlCacheEntry(CacheEntry, TInternetCacheEntryInfo(nil^), dwEntrySize);
dwLastError := GetLastError();
if (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
GetMem(IntCacheInfo, dwEntrySize);
if (FindNextUrlCacheEntry(CacheEntry, IntCacheInfo^, dwEntrySize)) then
begin
if ItemUrl = IntCacheInfo^.lpszSourceUrlName then
begin
Result := IntCacheInfo^.lpszLocalFileName;
Break;
end;
end;
FreeMem(IntCacheInfo);
end;
until (dwLastError = ERROR_NO_MORE_ITEMS);
end;
function OrganizeFavorite(h: THandle; Path: PAnsiChar): Boolean; stdcall;
external 'shdocvw.dll' name 'DoOrganizeFavDlg'; overload;
{$IFDEF UNICODE}
function OrganizeFavorite(h: THandle; Path: PWideChar): Boolean;
begin
Result := OrganizeFavorite(h, PAnsiChar(AnsiString(UnicodeString(Path))));
end;
{$ENDIF UNICODE}
function URLFromFavorites(const dotURL: string): string;
begin
Result := '';
with TIniFile.Create(dotURL) do
try
try
Result := ReadString('InternetShortcut', 'URL', '');
except;
end;
finally
Free;
end;
end;
function UrlFromHistory(ShellFolder: IShellFolder; pidl: PItemIDList): string;
var
Handle: THandle;
Info: IQueryInfo;
W: PWideChar;
begin
Result := '';
Handle := 0;
Info := nil;
ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));
if Assigned(Info) then
begin
Info.GetInfoTip(0, w);
Result := W;
end;
Result := Trim(System.Copy(Result, Pos(#10, Result) + 1, length(Result)));
end;
function GetDefaultBrowserFromRegistry: string;
var
Reg: TRegistry;
KeyName: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
KeyName := 'htmlfile\shell\open\command';
if Reg.OpenKey(KeyName, False) then
begin
Result := Reg.ReadString('');
Reg.CloseKey;
end
else
Result := 'No default browser found.';
finally
Reg.Free;
end;
end;
function GetIPAndHostName(var HostName, IPaddr, WSAErr: string): Boolean;
var
WSAResult: Integer;
WSAData: TWSAData;
HostEnt: PHostEnt;
Host: AnsiString;
SockAddr: TSockAddrIn;
begin
Result := False;
WSAResult := WSAStartup(MakeWord(1, 1), WSAData);
if WSAResult <> 0 then
begin
WSAErr := 'Winsock is not responding."';
end else
try
if Host = '' then
begin
SetLength(Host, MAX_PATH);
GetHostName(PAnsiChar(Host), MAX_PATH);
end;
HostEnt := GetHostByName(PAnsiChar(Host));
if HostEnt <> nil then
begin
HostName := string(AnsiString(Host));
SetLength(HostName, StrLen(PChar(HostName)));
SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
IPaddr := string(AnsiString(inet_ntoa(SockAddr.sin_addr)));
Result := True;
end else
begin
begin
case WSAGetLastError of
WSANOTINITIALISED: WSAErr := 'WSANotInitialised';
WSAENETDOWN: WSAErr := 'WSAENetDown';
WSAEINPROGRESS: WSAErr := 'WSAEInProgress';
end;
end;
end;
finally
WSACleanup;
end;
end;
function CreateNewMail: Boolean;
var
em_subject, em_body, em_mail: string;
begin
em_subject := '';
em_body := '';
em_mail := 'mailto:?subject=' + em_subject + '&body=' + em_body;
Result := ShellExecute(0, 'open', PChar(em_mail), nil, nil, SW_SHOWNORMAL) > 32;
end;
procedure SendUrlInMail(LocationURL, LocationName: WideString);
begin
with TEwbMapiMail.Create(nil) do
begin
try
Subject := LocationName;
Body := LocationURL;
EditDialog := True;
Send;
finally
end;
end;
end;
function SearchText(WebBrowser: TEmbeddedWB; Document: IDispatch; const Value: string; aTypeSearch: Integer; const iPos: Integer = 1): IHTMLTxtRange;
//by JJM
{ aTypeSearch can have the following values
(*
0 Default. Match partial words.
1 Match backwards.
2 Match whole words only.
4 Match case.
*)
}
var
B: Boolean;
begin
Wait(WebBrowser);
Result := nil;
try
if DocumentLoaded(Document) then
if Assigned((Document as IHTMLDocument2).body) then
begin
Result := ((Document as IHTMLDocument2).body as IHTMLBodyElement).CreateTextRange;
if Result.moveStart('character', ipos) = S_OK then
B := Result.findText(Value, 1, aTypeSearch)
else
B := Result.findText(Value, iPos, aTypeSearch);
if B then
Result.ScrollIntoView(True)
else
Result := nil;
end;
except
on e: Exception do ;
end;
end;
function SearchString(Webbrowser: TEmbeddedWB; const strText: string): Boolean;
var
tr: IHTMLTxtRange;
begin
Wait(WebBrowser);
Result := False;
try
if Assigned(Webbrowser.Document) then
begin
tr := ((Webbrowser.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
Result := tr.findText(strText, 1, 0);
end;
except
on e: Exception do
;
end;
end;
function DoSearchAndHighlight(Document: IDispatch; sFind: string;
Flags: TSearchFlags = []; cbackColor: string = 'yellow'; cForeColor: string = '';
ScrollIntoView: TScrollIntoView = sivNoScroll): Integer;
var
Doc2: IHTMLDocument2;
pElem: IHTMLElement;
pBodyelem: IHTMLBodyElement;
pTxtRange: IHTMLTxtRange;
searchdir, searchcase, iMatches: Integer;
begin
iMatches := 0;
if (Length(sFind) <> 0) and
Supports(Document, IHTMLDocument2, Doc2) then
begin
searchdir := 1;
searchcase := 0;
//Set up search case
if (sfMatchWholeWord in Flags) and (sfMatchCase in Flags) then
searchcase := 6
else if sfMatchWholeWord in Flags then
searchcase := 2
else if sfMatchCase in Flags then
searchcase := 4;
pElem := Doc2.body;
if (pElem <> nil) then
begin
pBodyelem := pElem as IHTMLBodyElement;
if (pBodyelem <> nil) then
begin
pTxtRange := pBodyelem.createTextRange();
if (pTxtRange <> nil) then
begin
while (pTxtRange.findText(sFind, searchdir, searchcase)) do
begin
if (cbackColor <> '') then
pTxtRange.execCommand('BackColor', False, cbackColor);
if (cForeColor <> '') then
pTxtRange.execCommand('ForeColor', False, cForeColor);
pTxtRange.moveStart('Character', 1);
pTxtRange.moveEnd('Textedit', 1);
iMatches := iMatches + 1;
if (iMatches = 1) and (ScrollIntoView = sivFirstMatch) then
pTxtRange.scrollIntoView(True);
end;
if (iMatches > 1) and (ScrollIntoView = sivLastMatch) then
pTxtRange.scrollIntoView(True);
end;
end;
end;
end;
Result := iMatches;
end;
procedure SearchAndHighlight(Document: IDispatch;
AText: string; const ACaption, APrompt: string; Flags: TSearchFlags = [];
cbackColor: string = 'yellow'; cForeColor: string = '';
ScrollIntoView: TScrollIntoView = sivNoScroll; ShowInputQuery: Boolean = True); overload;
var
// tr: IHTMLTxtRange;
FrameCount, i: Integer;
Wb2: IWebBrowser2;
begin
if DocumentLoaded(Document) then
begin
if ShowInputQuery then
if not InputQuery(ACaption, APrompt, AText) then Exit;
if Length(aText) = 0 then Exit;
try
FrameCount := FrameCountFromDocument(Document as IHTMLDocument2);
if FrameCount > 0 then
begin
for i := 0 to Pred(FrameCount) do
begin
Wb2 := GetFrameFromDocument(Document as IHTMLDocument2, i);
if Assigned(Wb2) then
SearchAndHighlight(Wb2.Document, AText, ACaption, APrompt, Flags,
cbackColor, cForeColor, ScrollIntoView, False);
end;
end
else
begin
DoSearchAndHighlight(Document, AText, Flags,
cbackColor, cForeColor, ScrollIntoView);
{ tr := ((Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
while tr.findText(aText, 1, 0) do
begin
tr.pasteHTML('' +
tr.htmlText + '');
tr.scrollIntoView(True);
end; }
end;
except
end;
end;
end;
procedure SearchAndHighlight(Document: IDispatch; aText: string; Flags: TSearchFlags = [];
cbackColor: string = 'yellow'; cForeColor: string = '';
ScrollIntoView: TScrollIntoView = sivNoScroll); overload;
begin
SearchAndHighlight(Document, '', '', aText, Flags, cbackColor, cForeColor, ScrollIntoView, False);
end;
{function FillForm(OleObject: Variant; FieldName: string; Value: string): Boolean;
var
I, j: Integer;
FormItem: Variant;
begin
Result := False;
if not DocumentLoaded(OleObject.Document) or OleObject.Document.all.tags('FORM').Length = 0 then
Exit;
for I := 0 to OleObject.Document.forms.Length - 1 do
begin
FormItem := OleObject.Document.forms.Item(I);
for j := 0 to FormItem.Length - 1 do
begin
try
if (FormItem.Item(j).Name = FieldName) and
(FormItem.Item(j).Name <> 'length') then
begin
FormItem.Item(j).Value := Value;
Result := True;
end;
except
Exit;
end;
end;
end;
end; }
procedure SetTextAreaValue(Document: IDispatch; sName, sValue: string; Options: TFindOptions);
var
Doc2: IHTMLDocument2;
i: Integer;
field: IHTMLElement;
textarea: IHTMLTextAreaElement;
begin
if Supports(Document, IHTMLDocument2, Doc2) then
for i := 0 to Doc2.all.length - 1 do
begin
field := Doc2.all.item(i, '') as IHTMLElement;
if Assigned(field) then
begin
if SameText(field.tagName, 'TEXTAREA') then
begin
textarea := field as IHTMLTextAreaElement;
if Assigned(textarea) then
begin
if ((frWholeWord in Options) and (sName = textarea.Name))
or ((Options = []) and (AnsiPos(sName, textarea.Name) <> 0)) then
textarea.Value := sValue;
end;
end;
end;
end;
end;
function FillForm(Document: IDispatch; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
var
Inputs: IHTMLElementCollection;
HTMLElement: IHTMLElement;
TagName: string;
k, iItemNr, iInputCount: Integer;
begin
Result := False;
Inputs := IHTMLDocument3(Document).getElementsByName(FieldName);
if Assigned(Inputs) then
begin
try
if ElementNr = -1 then
iInputCount := Inputs.Length
else
iInputCount := ElementNr;
if iInputCount = -1 then iInputCount := 0;
for k := 0 to iInputCount - 1 do
begin
if ElementNr = -1 then
iItemNr := k
else
iItemNr := ElementNr;
HTMLElement := Inputs.item(iItemNr, '') as IHTMLElement;
if Assigned(HTMLElement) then
begin
TagName := AnsiUpperCase(HTMLElement.tagName);
if TagName = 'INPUT' then
begin
(HTMLElement as IHTMLInputElement).Value := FieldValue;
Result := True;
Exit;
end
else if TagName = 'SELECT' then
begin
(HTMLElement as IHTMLSelectElement).Value := FieldValue;
Result := True;
Exit;
end
else if TagName = 'TEXTAREA' then
begin
(HTMLElement as IHTMLTextAreaElement).Value := FieldValue;
Result := True;
Exit;
end;
end;
if ElementNr <> -1 then Exit;
end;
except
end;
end;
end;
function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; ElementNr: Integer = -1): Boolean; overload;
var
Doc3: IHTMLDocument3;
begin
Result := False;
if Assigned(WebBrowser.Document) and
(Succeeded(WebBrowser.Document.QueryInterface(IHTMLDocument3, Doc3))) then
begin
FillForm(Doc3, FieldName, FieldValue, ElementNr)
end;
end;
function FillForm(WebBrowser: TEmbeddedWB; FieldName: string; FieldValue: string; Value: Boolean): Boolean;
var
I, j: Integer;
FormItem: Variant;
begin
Result := False;
if not DocumentLoaded(WebBrowser.Document) then
if WebBrowser.OleObject.Document.all.tags('FORM').Length = 0 then
if (FieldName = '') and (FieldValue = '') then
for I := 0 to WebBrowser.OleObject.Document.forms.Length - 1 do
begin
FormItem := WebBrowser.OleObject.Document.forms.Item(I);
for j := 0 to FormItem.Length - 1 do
begin
try
if (FormItem.Item(j).Name = FieldName) or (Fieldname = '') then
if (FormItem.Item(j).Value = FieldValue) or (Fieldvalue = '') then
begin
FormItem.Item(j).checked := Value;
Result := True;
end;
except
Continue;
end;
end;
end;
end;
procedure ClickInputImage(WebBrowser: TEmbeddedWB; ImageURL: string);
var
iDoc: IHTMLDocument2;
iDisp: IDispatch;
iColl: IHTMLElementCollection;
InputImage: htmlInputImage;
i: Integer;
begin
if WebBrowser.DocumentLoaded then
begin
if Supports(WebBrowser.Document, IHTMLDocument2, iDoc) then
begin
iDisp := iDoc.all.tags('INPUT');
if Assigned(iDisp) then
begin
if Supports(iDisp, IHTMLElementCollection, iColl) then
begin
ImageURL := AnsiUpperCase(ImageURL);
for i := 1 to iColl.Get_length do
begin
iDisp := iColl.item(Pred(i), 0);
if Supports(iDisp, HTMLInputImage, ImageURL) then
begin
if Pos(ImageURL, AnsiUpperCase(InputImage.src)) <> 0 then
begin
InputImage.Click;
end;
end;
end;
end;
end;
end;
end;
end;
function GetFieldValue(OleObject: Variant; FieldName: string): string;
var
I, j: Integer;
FormItem: Variant;
begin
Result := '';
if DocumentLoaded(OleObject.Document) then
if OleObject.Document.all.tags('FORM').Length = 0 then
for I := 0 to OleObject.Document.forms.Length - 1 do
begin
FormItem := OleObject.Document.forms.Item(I);
for j := 0 to FormItem.Length - 1 do
begin
try
if FormItem.Item(j).Name = FieldName then
Result := FormItem.Item(j).Value;
except
Continue;
end;
end;
end;
end;
procedure FillIEFormAndExcecute;
var
ShellWindow: IShellWindows;
IWeb: IWebBrowser2;
spDisp: IDispatch;
IDoc1: IHTMLDocument2;
Document: Variant;
k, m: Integer;
ovElements: OleVariant;
i: Integer;
begin
ShellWindow := CoShellWindows.Create;
// get the running instance of Internet Explorer
for k := 0 to ShellWindow.Count do
begin
spDisp := ShellWindow.Item(k);
if spDisp = nil then
Continue;
// QueryInterface determines if an interface can be used with an object
spDisp.QueryInterface(IWebBrowser2, IWeb);
if IWeb <> nil then
begin
IWeb.Document.QueryInterface(IHTMLDocument2, iDoc1);
if iDoc1 <> nil then
begin
IWeb := ShellWindow.Item(k) as IWebBrowser2;
begin
Document := IWeb.Document;
// count forms on document and iterate through its forms
for m := 0 to Document.Forms.Length - 1 do
begin
ovElements := Document.Forms.Item(m).Elements;
// iterate through elements
for i := 0 to ovElements.Length - 1 do
begin
// when input fieldname is found, try to fill out
try
if (CompareText(ovElements.Item(i).tagName, 'INPUT') = 0) and
(CompareText(ovElements.Item(i).type, 'text') = 0) then
begin
ovElements.Item(i).Value := 'FindWindow';
end;
except
end;
// when Submit button is found, try to click
try
if (CompareText(ovElements.Item(i).tagName, 'INPUT') = 0) and
(CompareText(ovElements.Item(i).type, 'SUBMIT') = 0) and
(ovElements.Item(i).Value = 'Search') then // Suchen for German
begin
ovElements.Item(i).Click;
end;
except
end;
end;
end;
end;
end;
end;
end;
end;
procedure ClearHistory;
var
HistoryStg: IUrlHistoryStg2;
begin
HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
HistoryStg.ClearHistory;
end;
function DeleteFirstCacheEntry(var H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWord;
begin
Result := S_OK;
H := 0;
D := 0;
FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, nil, @D, nil, nil, nil);
GetMem(T, D);
try
H := FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, T, @D, nil, nil, nil);
if (H = 0) then
Result := GetLastError
else
DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;
function DeleteNextCacheEntry(H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWORD;
begin
Result := S_OK;
D := 0;
FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);
GetMem(T, D);
try
if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil) then
Result := GetLastError
else
DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;
procedure ClearCache;
var
H: THandle;
begin
if DeleteFirstCacheEntry(H) = S_OK then
repeat
until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS;
FindCloseUrlCache(H);
end;
procedure ClearTypedUrls;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
DeleteKey('Software\Microsoft\Internet Explorer\TypedURLs');
finally
Free;
end;
end;
function CheckOnlineStatus: Boolean;
var
dwConnectionTypes: Integer;
begin
Result := False;
try
dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN + INTERNET_CONNECTION_PROXY;
Result := InternetGetConnectedState(@dwConnectionTypes, 0);
except
end;
end;
procedure SetGlobalOffline(Value: Boolean);
const
INTERNET_STATE_DISCONNECTED_BY_USER = $10;
ISO_FORCE_DISCONNECTED = $1;
INTERNET_STATE_CONNECTED = $1;
var
ci: TInternetConnectedInfo;
dwSize: DWORD;
begin
dwSize := SizeOf(ci);
if Value then
begin
ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
ci.dwFlags := ISO_FORCE_DISCONNECTED;
end else
begin
ci.dwFlags := 0;
ci.dwConnectedState := INTERNET_STATE_CONNECTED;
end;
InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, dwSize);
end;
procedure WorkOffline();
begin
SetGlobalOffline(False);
end;
procedure WorkOnline();
begin
SetGlobalOffline(True);
end;
function IsGlobalOffline: Boolean;
var
dwState: DWORD;
dwSize: DWORD;
begin
dwState := 0;
dwSize := SizeOf(dwState);
Result := False;
if (InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwState, dwSize)) then
Result := ((dwState and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0);
end;
function GetTLDFromHost(Host: string): string;
var
i, Dots: Integer;
begin
Dots := 0;
for i := Length(Host) downto 1 do
begin
if Copy(Host, i, 1) = '.' then
Inc(Dots);
if Dots = 2 then
break;
Result := Copy(Host, i, 1) + Result;
end;
end;
function CheckIfInRestricredList(const Host: string; SecureSite: Boolean): Boolean;
const
Path = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\';
var
TLD: string;
begin // todo: check for IPs IN RANGES
Result := False;
TLD := GetTLDFromHost(Host);
with TRegistry.Create(KEY_READ) do
begin
try
RootKey := HKEY_CURRENT_USER;
if not OpenKey(Path + 'Domains' + '\' + TLD + '\' +
Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then
begin
CloseKey;
if not OpenKey(Path + 'EscDomains' + '\' + TLD + '\' +
Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then // found on IE6, W2003
begin
CloseKey;
Exit;
end;
end;
if SecureSite then
Result := ReadInteger('https') = 4
else
Result := ReadInteger('http') = 4
finally
CloseKey;
Free;
end;
end;
end;
function CheckIfInTrustedList(const Host: string; SecureSite: Boolean): Boolean;
const
Path = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\';
var
TLD: string;
begin // todo: check for IPs in RANGES
Result := False;
TLD := GetTLDFromHost(Host);
with TRegistry.Create(KEY_READ) do
begin
try
RootKey := HKEY_CURRENT_USER;
if not OpenKey(Path + 'Domains' + '\' + TLD + '\' +
Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then
begin
CloseKey;
if not OpenKey(Path + 'EscDomains' + '\' + TLD + '\' +
Copy(Host, 1, Length(Host) - Length(TLD) - 1), False) then // found on IE6, W2003
begin
CloseKey;
Exit;
end;
end;
if SecureSite then
Result := ReadInteger('https') = 2
else
Result := ReadInteger('http') = 2
finally
CloseKey;
Free;
end;
end;
end;
procedure AddToTrustedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
const
REG_PATH = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains';
var
Reg: TRegistryIniFile;
begin
if AnsiPos('HTTPS', AnsiUpperCase(URL)) = 0 then
MessageDlg('Only sites with https:// prefix (secured sites) can be added to the trusted sites list zone!', mtError, [mbOK], 0)
else
begin
try
Reg := TRegistryIniFile.Create(REG_PATH);
try
Reg.WriteInteger(URL, 'https', (2));
finally
Reg.Free;
end;
except
end;
end;
end;
procedure AddToRestrictedSiteList(WebBrowser: TEmbeddedWB; const URL: string);
const
REG_PATH = '\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains';
var
st: string;
I: Integer;
Reg: TRegistryIniFile;
begin
I := LastDelimiter(':', Url) + 2;
st := Copy(Url, I + 1, MaxInt);
if AnsiPos('www', st) > 0 then
begin
I := 4;
st := Copy(st, I + 1, MaxInt);
end;
try
Reg := TRegistryIniFile.Create(REG_PATH);
try
Reg.WriteInteger(st, '*', (4));
finally
Reg.Free;
end;
except
end;
end;
function GetZoneAttributes(const URL: string): TZoneAttributes;
var
dwZone: Cardinal;
ZoneAttr: TZoneAttributes;
var
ZoneManager: IInternetZoneManager;
SecManager: IInternetSecurityManager;
begin
ZeroMemory(@ZoneAttr, SizeOf(TZoneAttributes));
if CoInternetCreateSecuritymanager(nil, SecManager, 0) = S_OK then
if CoInternetCreateZoneManager(nil, ZoneManager, 0) = S_OK then
begin
SecManager.MapUrlToZone(PWideChar(WideString(URL)), dwZone, 0);
ZoneManager.GetZoneAttributes(dwZone, Result);
end;
end;
function GetZoneIconToForm(LocationURL: string; Caption, Hint: string): Boolean;
var
ZoneAttr: TZoneAttributes;
ZoneIcon: TIcon;
begin
ZoneAttr := GetZoneAttributes(LocationURL);
ZoneIcon := TIcon.Create;
try
GetZoneIcon(ZoneAttr.szIconPath, ZoneIcon);
Caption := ZoneAttr.szDisplayName;
Hint := ZoneAttr.szDisplayName;
Forms.Application.Icon := ZoneIcon;
finally
ZoneIcon.Free;
end;
Result := True;
end;
procedure GetZoneIcon(IconPath: string; var Icon: TIcon);
var
FName, ImageName: string;
h: hInst;
begin
FName := Copy(IconPath, 1, Pos('#', IconPath) - 1);
ImageName := Copy(IconPath, Pos('#', IconPath), Length(IconPath));
h := LoadLibrary(PChar(FName));
try
if h <> 0 then
Icon.Handle := LoadImage(h, PChar(ImageName), IMAGE_ICON, 16, 16, 0);
finally
FreeLibrary(h);
end;
end;
function GetUrlSecurityZone(LocationURL: string; var ZoneName, ZoneDescription: string; var Icon: TIcon): Boolean;
var
ZoneAttr: TZoneAttributes;
begin
Assert(Icon <> nil);
ZoneAttr := GetZoneAttributes(LocationURL);
try
try
GetZoneIcon(ZoneAttr.szIconPath, Icon);
ZoneName := ZoneAttr.szDisplayName;
ZoneDescription := ZoneAttr.szDescription;
Result := True;
except
Result := False;
end;
finally
end;
end;
function GetSSLStatus(OleObject: Variant; LocationURL: string; var SSLName, SSLDescription: string): Boolean;
begin
Result := False;
if (Pos('https://', LocationURL) > 0) then
begin
if OleObject.Document.Location.Protocol = 'https:' then
begin
SSLName := 'SSL';
SSLDescription := 'It is a secure web page.';
Result := True;
end;
end
else
begin
SSLName := 'None';
SSLDescription := 'The page is not secured.';
Result := False;
end
end;
function SetProxy(UserAgent, Address: string): Boolean; // mladen
var
list: INTERNET_PER_CONN_OPTION_LIST;
dwBufSize: DWORD;
hInternet: Pointer;
Options: array[1..3] of INTERNET_PER_CONN_OPTION;
begin
Result := False;
dwBufSize := SizeOf(list);
list.dwSize := SizeOf(list);
list.pszConnection := nil;
list.dwOptionCount := High(Options); // the highest index of the array (in this case 3)
Options[1].dwOption := INTERNET_PER_CONN_FLAGS;
Options[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
Options[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
Options[2].Value.pszValue := PAnsiChar(AnsiString(Address));
Options[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
Options[3].Value.pszValue := '';
list.pOptions := @Options;
hInternet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
if hInternet <> nil then
try
Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
finally
InternetCloseHandle(hInternet)
end;
end;
function SetProxy(UserAgent, Address, UserName, Password: string; Port: Integer): Boolean;
var
list: INTERNET_PER_CONN_OPTION_LIST;
dwBufSize: DWORD;
hInternet, hInternetConnect: Pointer;
Options: array[1..3] of INTERNET_PER_CONN_OPTION;
begin
Result := False;
dwBufSize := SizeOf(list);
list.dwSize := SizeOf(list);
list.pszConnection := nil;
list.dwOptionCount := High(Options);
Options[1].dwOption := INTERNET_PER_CONN_FLAGS;
Options[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
Options[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
Options[2].Value.pszValue := PAnsiChar(AnsiString(Address));
Options[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
Options[3].Value.pszValue := '';
list.pOptions := @Options;
hInternet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
if hInternet <> nil then
try
hInternetConnect := InternetConnect(hInternet, PChar(Address), Port, PChar(UserName), PChar(Password),
INTERNET_SERVICE_HTTP, 0, 0);
if hInternetConnect <> nil then
begin
Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
end;
finally
InternetCloseHandle(hInternet)
end;
end;
function SetProxyFromPAC(UserAgent, PACFile: string): Boolean;
var
list: INTERNET_PER_CONN_OPTION_LIST;
dwBufSize: DWORD;
hInternet: Pointer;
Options: array[1..2] of INTERNET_PER_CONN_OPTION;
begin
Result := False;
dwBufSize := SizeOf(list);
list.dwSize := SizeOf(list);
list.pszConnection := nil;
list.dwOptionCount := High(Options);
Options[1].dwOption := INTERNET_PER_CONN_AUTOCONFIG_URL;
Options[1].Value.pszValue := PAnsiChar(AnsiString(PacFile));
Options[2].dwOption := INTERNET_PER_CONN_FLAGS;
Options[2].Value.dwValue := PROXY_TYPE_AUTO_PROXY_URL;
list.dwOptionCount := 2;
list.dwOptionError := 0;
list.pOptions := @Options;
hInternet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
if hInternet <> nil then
try
Result := InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
finally
InternetCloseHandle(hInternet)
end;
end;
function RemoveProxy(): Boolean;
var
list: INTERNET_PER_CONN_OPTION_LIST;
dwBufSize: DWORD;
hInternet: Pointer;
Options: array[1..3] of INTERNET_PER_CONN_OPTION;
begin
Result := False;
dwBufSize := SizeOf(list);
list.dwSize := SizeOf(list);
list.pszConnection := nil;
list.dwOptionCount := High(Options);
Options[1].dwOption := INTERNET_PER_CONN_FLAGS;
Options[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
Options[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
Options[2].Value.pszValue := PAnsiChar('');
Options[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
Options[3].Value.pszValue := '';
list.pOptions := @Options;
hInternet := InternetOpen(PChar(''), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
if hInternet <> nil then
try
InternetSetOption(hInternet, INTERNET_OPTION_PER_CONNECTION_OPTION, @list, dwBufSize);
InternetSetOption(hInternet, INTERNET_OPTION_REFRESH, nil, 0);
Result := True;
finally
InternetCloseHandle(hInternet)
end;
end;
procedure RemoveUserAgent(UserAgent: string);
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_CURRENT_USER;
try
if OpenKey(USER_AGENT_PATH, False)
then
DeleteValue(UserAgent);
finally
CloseKey;
Free;
end;
end;
end;
var
MimeFactory, NSFactory: IClassFactory;
MimeInternetSession, NSInternetSession: IInternetSession;
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory);
CoInternetGetSession(0, MimeInternetSession, 0);
Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME);
end;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
begin
Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME);
end;
function RegisterNameSpace(clsid: TGUID): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory);
CoInternetGetSession(0, NSInternetSession, 0);
Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0);
end;
function UnregisterNameSpace: HRESULT;
begin
Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http');
end;
procedure RestoreApplicationFormSize(WebBrowser: TEmbeddedWB);
var
ws: Integer;
RegPath: string;
begin
with TRegistry.Create do
begin
RootKey := HKEY_LOCAL_MACHINE;
RegPath := 'SOFTWARE\' + Forms.Application.Title + '\FormSize';
if OpenKey(RegPath, False) then
try
with Forms.Application.MainForm do
begin
Left := ReadInteger('Left');
Top := ReadInteger('Top');
Width := ReadInteger('Width');
Height := ReadInteger('Height');
ws := ReadInteger('WindowState');
case ws of
0: WindowState := wsNormal;
1: WindowState := wsMinimized;
2: WindowState := wsMaximized;
end;
end;
except
end;
CloseKey;
Free;
end;
end;
procedure SaveApplicationFormSize(WebBrowser: TEmbeddedWB);
var
RegPath: string;
begin
with TRegistry.Create do
begin
RootKey := HKEY_LOCAL_MACHINE;
RegPath := 'SOFTWARE\' + Forms.Application.Title + '\FormSize';
if OpenKey(RegPath, True) then
try
with Forms.Application.MainForm do
begin
WriteInteger('Top', Top);
WriteInteger('Left', Left);
WriteInteger('Width', Width);
WriteInteger('Height', Height);
with Forms.Application.MainForm do
case WindowState of
wsNormal: WriteInteger('WindowState', 0);
wsMinimized: WriteInteger('WindowState', 0);
wsMaximized: WriteInteger('WindowState', 0);
end;
end;
CloseKey;
Free;
except
end;
end;
end;
procedure Wait(WebBrowser: TEmbeddedWB);
begin
WebBrowser.Wait;
end;
function InvokeCMD(Document: IDispatch; InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant): HRESULT;
var
CmdTarget: IOleCommandTarget;
PtrGUID: PGUID;
begin
// New(PtrGUID);
Result := S_FALSE;
if InvokeIE then
begin
New(PtrGUID);
PtrGUID^ := CLSID_WebBrowser;
end
else
PtrGuid := PGUID(nil);
if DocumentLoaded(Document) then
try
Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
Result := CmdTarget.Exec(PtrGuid, Value1, Value2, vaIn, vaOut);
finally
CmdTarget._Release;
end;
except
end;
Dispose(PtrGUID);
end;
function GetIEHandle(WebBrowser: TEmbeddedWB; ClassName: string): HWND;
begin
Result := WebBrowser.GetIEHandle(WebBrowser, ClassName);
end;
procedure ShowIEVersionInfo(Handle: THandle);
begin
SendMessage(Handle, WM_COMMAND, ID_IE_HELP_VERSIONINFO, 0);
end;
procedure SetNewHomePage(HomePage: string);
begin
with TRegistry.Create do
begin
try
OpenKey('\Software\Microsoft\Internet Explorer\Main', True);
WriteString('Start Page', HomePage);
CloseKey;
finally
Free;
end;
end;
end;
function GetLastVisitedPage(var LastVisitedPage: string): Boolean;
begin
Result := False;
with TRegistry.Create do
begin
LastVisitedPage := '';
RootKey := HKEY_LOCAL_MACHINE;
try
if OpenKey('SOFTWARE\' + Forms.Application.Title + '\WebPages', False) then
begin
LastVisitedPage := ReadString('LastVisitedPage');
CloseKey;
Result := (LastVisitedPage <> '') and (AnsiPos('.', LastVisitedPage) > 0);
end;
finally
Free;
end;
end;
end;
function SaveLastVisitedPage(WebBrowser: TEmbeddedWB; LocationURL: string): Boolean;
var
RegPath: string;
begin
Result := False;
with TRegistry.Create do
begin
RootKey := HKEY_LOCAL_MACHINE;
RegPath := 'SOFTWARE\' + Forms.Application.Title + '\WebPages';
if OpenKey(RegPath, False) then
try
DeleteKey('LastVisitedPage');
except
end;
Free;
end;
with TRegIniFile.Create do
begin
RootKey := HKEY_LOCAL_MACHINE;
RegPath := 'SOFTWARE\' + Forms.Application.Title;
if OpenKey(RegPath, True) then
begin
try
WriteString('WebPages', 'LastVisitedPage', LocationURL);
Result := True;
except
end;
CloseKey;
end;
Free;
end;
end;
procedure CreateDesktopShortcut(Handle: THandle);
begin
SendMessage(Handle, WM_COMMAND, ID_IE_FILE_SENDDESKTOPSHORTCUT, 0);
end;
procedure DisableNavSound(bDisable: Boolean);
const
REG_PATH = 'AppEvents\Schemes\Apps\Explorer\Navigating\';
var
Reg: TRegIniFile;
begin
Reg := TRegIniFile.Create;
with Reg do
begin
RootKey := HKEY_CURRENT_USER;
try
if bDisable then
begin
if KeyExists(REG_PATH + '.Current') then
if OpenKey(REG_PATH, True) then
MoveKey('.Current', 'Old_Current', True);
end
else
begin
if KeyExists(REG_PATH + 'Old_Current') then
if OpenKey(REG_PATH, False) then
MoveKey('Old_Current', '.Current', True);
end;
finally
CloseKey;
Free;
end;
end;
end;
function WBExecScript(
TargetObj: IDispatch;
MethodName: string;
ParamValues: array of const): OleVariant;
var
wide: WideString;
disps: TDispIDList;
panswer: ^OleVariant;
answer: OleVariant;
dispParams: TDispParams;
aexception: TExcepInfo;
pVarArg: PVariantArgList;
res: HRESULT;
ParamCount, i: Integer;
begin
Result := False;
// prepare for function call
ParamCount := High(ParamValues) + 1;
wide := MethodName;
pVarArg := nil;
if ParamCount > 0 then
GetMem(pVarArg, ParamCount * sizeof(TVariantArg));
try
// get dispid of requested method
if not Succeeded(TargetObj.GetIDsOfNames(GUID_NULL, @wide, 1, 0, @disps)) then
raise Exception.Create('This object does not support this method');
pAnswer := @answer;
// prepare parameters
for i := 0 to Pred(ParamCount) do
begin
case ParamValues[ParamCount - 1 - i].VType of
vtBoolean: begin
pVarArg^[i].vt := VT_BOOL;
pVarArg^[i].vbool := ParamValues[ParamCount - 1 - i].VBoolean;
end;
vtCurrency: begin
pVarArg^[i].vt := VT_CY;
pVarArg^[i].cyVal := ParamValues[ParamCount - 1 - i].VCurrency^;
end;
vtInt64: begin
pVarArg^[i].vt := VT_I8;
PInt64(@pVarArg^[i].cyVal)^ := ParamValues[ParamCount - 1 - i].VInt64^;
end;
vtInteger: begin
pVarArg^[i].vt := VT_I4;
pVarArg^[i].lVal := ParamValues[ParamCount - 1 - i].VInteger;
end;
vtExtended: begin
pVarArg^[i].vt := VT_R8;
pVarArg^[i].dblVal := ParamValues[ParamCount - 1 - i].VExtended^;
end;
vtVariant: begin
pVarArg^[i].vt := VT_BYREF or VT_VARIANT;
pVarArg^[i].pvarVal := ParamValues[ParamCount - 1 - i].VVariant;
end;
vtChar: begin
{pVarArg^[i].vt := VT_I1;
pVarArg^[i].cVal := ParamValues[ParamCount - 1 - i].VChar;}
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VChar));
end;
vtWideChar: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VWideChar));
end;
vtPChar: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VPChar));
end;
vtPWideChar: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := ParamValues[ParamCount - 1 - i].VPWideChar;
end;
vtAnsiString: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(PAnsiChar(ParamValues[ParamCount - 1 - i].VAnsiString)));
end;
vtWideString: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(ParamValues[ParamCount - 1 - i].VWideString));
end;
vtString: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(PAnsiChar(ParamValues[ParamCount - 1 - i].VString)));
end;
{$IFDEF UNICODE}
vtUnicodeString: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(UnicodeString(ParamValues[ParamCount - 1 - i].VUnicodeString));
end;
{$ENDIF UNICODE}
else
raise Exception.CreateFmt('Unsupported type for Parameter with Index %d', [i]);
end;
end;
// prepare dispatch parameters
dispparams.rgvarg := pVarArg;
dispparams.rgdispidNamedArgs := nil;
dispparams.cArgs := ParamCount;
dispparams.cNamedArgs := 0;
// make IDispatch call
res := TargetObj.Invoke(disps[0],
GUID_NULL, 0, DISPATCH_METHOD or DISPATCH_PROPERTYGET,
dispParams, pAnswer, @aexception, nil);
// check the Result
if res <> 0 then
raise Exception.CreateFmt(
'Method call unsuccessful. %s (%s).',
[string(aexception.bstrDescription), string(aexception.bstrSource)]);
// return the Result
Result := answer;
finally
if ParamCount > 0 then
FreeMem(pVarArg, ParamCount * sizeof(TVariantArg));
end;
end;
function ExecScriptEx(WebBrowser: TEmbeddedWB; MethodName: string; ParamValues: array of const): OleVariant;
var
doc: IHTMLDocument2;
dScript: IDispatch;
begin
if WebBrowser.DocumentLoaded(Doc) then
begin
dScript := doc.Script;
if Assigned(dScript) then
Result := WBExecScript(DScript, MethodName, ParamValues);
end;
end;
procedure ExecScript(WebBrowser: TEmbeddedWB; sExpression, sLanguage: string);
// e.g. sLanguage = 'JavaScript';
var
Doc: IHTMLDocument2; // current HTML document
HTMLWin: IHTMLWindow2; // parent window of current HTML document
begin
if WebBrowser.DocumentLoaded(Doc) then
begin
HTMLWin := Doc.parentWindow;
if Assigned(HTMLWin) then
begin
try
HTMLWin.execScript(sExpression, sLanguage);
except
end;
end;
end;
end;
//To Add--------------------------------------------------
function URLFromShortcut(const dotURL: string): string;
begin
Result := '';
with TIniFile.Create(dotURL) do
try
Result := ReadString('InternetShortcut', 'URL', '');
finally
Free;
end;
end;
function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
var
Handle: THandle;
Info: IQueryInfo;
W: PWideChar;
begin
Handle := 0;
Info := nil;
Result := '';
ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));
if Assigned(Info) then
begin
Info.GetInfoTip(0, w);
Result := W;
end;
Result := Trim(Copy(Result, Pos(#10, Result) + 1, length(Result)));
end;
function StringToVarArray(const S: string): Variant;
begin
Result := Unassigned;
if S <> '' then
begin
Result := VarArrayCreate([0, Length(S) - 1], varByte);
Move(Pointer(S)^, VarArrayLock(Result)^, Length(S));
VarArrayUnlock(Result);
end;
end;
function VarArrayToString(const V: Variant): string;
var
i, j: Integer;
begin
if VarIsArray(V) then
for i := 0 to VarArrayHighBound(V, 1) do
begin
j := V[i];
Result := Result + chr(j);
end;
end;
function Encode(const S: string): string;
var
I: Integer;
Hex: string;
begin
for I := 1 to Length(S) do
case S[i] of
' ': Result := Result + '+';
'A'..'Z', 'a'..'z', '*', '@', '.', '_', '-',
'0'..'9', '$', '!', '''', '(', ')':
Result := Result + s[i];
else
begin
Hex := IntToHex(ord(S[i]), 2);
if Length(Hex) = 2 then
Result := Result + '%' + Hex
else
Result := Result + '%0' + hex;
end;
end;
end;
function IE5_Installed: Boolean;
var
Reg: TRegistry;
S: string;
begin
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software\Microsoft\Internet Explorer', False);
if ValueExists('Version') then
S := ReadString('Version')
else
S := '0';
CloseKey;
Free;
end;
Result := (StrToInt(S[1]) > 4);
end;
function GetIEVersionMajor: Integer;
var
i: Integer;
s: string;
begin
s := GetIEVersion;
i := Pos('.', s);
Result := -1;
if i <> 0 then
begin
try
Result := StrToInt(Copy(s, 1, Pos('.', s) - 1));
except
Result := -1;
end;
end;
end;
function GetIEVersion: string;
var
SysDir: PChar;
Info: Pointer;
InfoData: Pointer;
InfoSize: LongInt;
Len: DWORD;
FName: Pchar;
SystemDir, Infotype: string;
LangPtr: Pointer;
begin
Len := MAX_PATH + 1;
GetMem(SysDir, Len);
try
if Windows.GetSystemDirectory(SysDir, Len) <> 0 then
SystemDir := SysDir;
finally
FreeMem(SysDir);
end;
Result := '';
InfoType := 'FileVersion';
if FileExists(SystemDir + '\ieframe.dll') then
FName := PChar(SystemDir + '\ieframe.dll')
else
FName := PChar(SystemDir + '\shdocvw.dll');
InfoSize := GetFileVersionInfoSize(Fname, Len);
if (InfoSize > 0) then
begin
GetMem(Info, InfoSize);
try
if GetFileVersionInfo(FName, Len, InfoSize, Info) then
begin
Len := 255;
if VerQueryValue(Info, '\VarFileInfo\Translation', LangPtr, Len) then
InfoType := Format('\StringFileInfo\%0.4x%0.4x\%s'#0, [LoWord(LongInt(LangPtr^)),
HiWord(LongInt(LangPtr^)), InfoType]);
if VerQueryValue(Info, Pchar(InfoType), InfoData, len) then
{$IFDEF UNICODE}
Result := Trim(PWideChar(InfoData));
{$ELSE}
Result := StrPas(PAnsiChar(InfoData));
{$ENDIF UNICODE}
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
function ResolveUrlIni(Filename: string): string;
var
ini: TiniFile;
begin
Result := '';
ini := TIniFile.Create(Filename);
try
Result := ini.ReadString('InternetShortcut', 'URL', '');
finally
ini.Free;
end;
end;
function ResolveUrlIntShCut(Filename: string): string;
var
IURL: IUniformResourceLocator;
PersistFile: IPersistfile;
FName: array[0..MAX_PATH] of WideChar;
p: PChar;
begin
if Succeeded(CoCreateInstance(CLSID_InternetShortcut, nil, CLSCTX_INPROC_SERVER,
IID_IUniformResourceLocator, IURL)) then
begin
Persistfile := IUrl as IPersistFile;
StringToWideChar(FileName, FName, MAX_PATH);
PersistFile.Load(FName, STGM_READ);
IUrl.GetUrl(@P);
Result := P;
end;
end;
function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
var
pidlChannel: PItemIDList;
psfDesktop: IShellFolder;
pShellLink: IShellLink;
begin
Result := S_FALSE;
if Succeeded(pFolder.GetUIObjectOf(0, 1, pidl, IShellLink, nil, Pointer(pShellLink)))
then
if Succeeded(pShellLink.GetIDList(pidlChannel)) then
if Succeeded(SHGetDesktopFolder(psfDesktop)) then
begin
lpszURL := getDisplayName(psfDesktop, PidlChannel);
Result := S_OK;
end;
DisposePidl(PidlChannel);
end;
function ResolveLink(const Path: string): string;
var
link: IShellLink;
storage: IPersistFile;
filedata: TWin32FindData;
buf: array[0..MAX_PATH] of Char;
widepath: WideString;
begin
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link));
OleCheck(link.QueryInterface(IPersistFile, storage));
widepath := path;
Result := '';
if Succeeded(storage.Load(@widepath[1], STGM_READ)) then
if Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) then
if Succeeded(link.GetPath(buf, SizeOf(buf), filedata, SLGP_UNCPRIORITY)) then
Result := buf;
storage := nil;
link := nil;
end;
function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
Flags: UINT;
begin
Flags := SFGAO_FOLDER;
ShellFolder.GetAttributesOf(1, ID, Flags);
Result := SFGAO_FOLDER and Flags <> 0;
end;
function IsChannel(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
FileInfo: TShFileInfo;
begin
SHGetFileInfo(Pchar(ID), 0, FileInfo, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_TYPENAME);
Result := BOOL(fileinfo.szTypeName = ChannelShortcut);
end;
function IsFolderEx(ChannelShortcut: string; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
Flags: UINT;
begin
Flags := SFGAO_FOLDER;
ShellFolder.GetAttributesOf(1, ID, Flags);
if SFGAO_FOLDER and Flags <> 0 then
Result := not isChannel(ChannelShortcut, Shellfolder, id)
else
Result := False;
end;
function GetImageIndex(pidl: PItemIDList): Integer;
var
Flags: UINT;
FileInfo: TSHFileInfo;
begin
Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON or SHGFI_SMALLICON;
if SHGetFileInfo(PChar(pidl), 0, FileInfo, SizeOf(TSHFileInfo), Flags) = 0 then
Result := -1
else
Result := FileInfo.iIcon;
end;
{function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
var
StrRet: TStrRet;
begin
Result := '';
Folder.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET:
Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end; }
function GetDisplayName(Folder: IShellFolder; PIDL: PItemIDList): string;
var
StrRet: TStrRet;
P: PChar;
Flags: Integer;
begin
Result := '';
Flags := SHGDN_NORMAL;
Folder.GetDisplayNameOf(PIDL, Flags, StrRet);
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLenA(StrRet.cStr));
STRRET_OFFSET:
begin
P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
end;
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end;
{function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
var
StrRet: TStrRet;
begin
Folder.GetDisplayNameOf(pidl, SHGDN_FORPARSING, StrRet);
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET:
Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end; }
function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
var
StrRet: TStrRet;
P: PChar;
begin
Result := '';
Folder.GetDisplayNameOf(PIDL, SHGDN_FORPARSING, StrRet);
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLenA(StrRet.cStr));
STRRET_OFFSET:
begin
P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
end;
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end;
procedure DisposePIDL(ID: PItemIDList);
var
Malloc: IMalloc;
begin
if ID <> nil then
begin
OLECheck(SHGetMalloc(Malloc));
Malloc.Free(ID);
end;
end;
function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
begin
Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb));
CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));
end;
function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PAnsiChar(Result), IDList^.mkid.cb);
end;
function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;
procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;
function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
HR: HResult;
begin
Result := nil;
HR := SHGetMalloc(Malloc);
if Failed(HR) then
Exit;
try
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
finally
end;
end;
function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;
function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
cb1, cb2: Integer;
begin
if Assigned(IDList1) then
cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
else
cb1 := 0;
cb2 := GetPIDLSize(IDList2);
Result := CreatePIDL(cb1 + cb2);
if Assigned(Result) then
begin
if Assigned(IDList1) then
CopyMemory(Result, IDList1, cb1);
CopyMemory(PAnsiChar(Result) + cb1, IDList2, cb2);
end;
end;
function DeleteUrl(Url: PWideChar): HResult;
begin
Result := DeleteUrl(Url);
end;
function GetMailClients: TStrings;
var
Reg: TRegistry;
ts: TStrings;
i: Integer;
begin
ts := TStringList.Create;
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_CURRENT_USER;
try
OpenKey(RegMail, False);
if HasSubKeys then
begin
GetKeyNames(ts);
CloseKey;
for i := 0 to ts.Count - 1 do
OpenKey(RegMail + ts.Strings[i], False);
end;
Result := ts;
finally
CloseKey;
Free;
end;
end;
end;
end.