//************************************************************* // TEwbCore * // * // Freeware Component * // For Delphi * // by * // Per Lindso Larsen * // Developing Team: * // Eran Bodankin (bsalsa) -(bsalsa@gmail.com) * // Serge Voloshenyuk (SergeV@bsalsa.com) * // Thomas Stutz (smot777@yahoo.com * // * // 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/modify the component under 4 conditions: 1. In your web site, 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 EwbCore; interface {$I EWB.inc} uses {$IFDEF DELPHI6_UP}Variants, {$ENDIF} Dialogs, Windows, Messages, Classes, MSHTML_EWB, EWBAcc, Controls, Forms, ExtCtrls, ActiveX, ShlObj, SHDocVw_EWB, UrlMon, IEConst; type TCustomEmbeddedWB = class; TOleCmdArray = array of TOleCmd; TDragDropHandlingType = ( ddtMS, // Microsoft implementation ddtMy, // TCustomEmbeddedWB event handlers ddtCustom, // granted by user in OnGetDropTarget event handler ddtNo // No drag and drop ); TDocDesignMode = (ddmOn, ddmOff, ddmInherit, ddmUnknown); TIEPopupMenu = ( rcmDefault, rcmImage, rcmControl, rcmTable, rcmSelText, rcmAnchor, rcmUnKnown, rcmImageArt, rcmImgDynSrc, rcmDebug, rcmAll ); TIEPopupMenus = set of TIEPopupMenu; TIEPopupMenuItem = ( rcsBack, rcsForward, rcsSavePageBkg, rcsSetAsBkg, rcsCopyBkg, rcsSetAsDeskT, rcsSelectAll, rcsPaste, rcsCreateSC, rcsAddToFav, rcsEncoding, rcsRefresh, rcsViewSource, rcsProperties, rcsPrint, rcsOpenNWindow, rcsOpenLink ); TIEPopupMenuItems = set of TIEPopupMenuItem; {============================================================================} { Controlling Download and Execution } { http://msdn.microsoft.com/en-us/library/aa770041.aspx } { TDownloadControlOption = ( DLCTL_DLIMAGES, DLCTL_VIDEOS, DLCTL_BGSOUNDS, DLCTL_NO_SCRIPTS, DLCTL_NO_JAVA, DLCTL_NO_RUNACTIVEXCTLS, DLCTL_NO_DLACTIVEXCTLS, DLCTL_DOWNLOADONLY, DLCTL_NO_FRAMEDOWNLOAD, DLCTL_RESYNCHRONIZE, DLCTL_PRAGMA_NO_CACHE, DLCTL_NO_BEHAVIORS, DLCTL_NO_METACHARSET, DLCTL_URL_ENCODING_DISABLE_UTF8, DLCTL_URL_ENCODING_ENABLE_UTF8, DLCTL_FORCEOFFLINE, DLCTL_NO_CLIENTPULL, DLCTL_SILENT, DLCTL_OFFLINE); } TDownloadControlOption = ( DownloadImages, DownloadVideos, DownloadBGSounds, DontExecuteScripts, DontExecuteJava, DontExecuteActiveX, DontDownloadActiveX, DownloadButDontDisplay, DontDownloadFrame, CheckPageResynchronize, DownloadAndIgnoreCache, DontDownloadBehaviors, SuppressedMetaCharset, DisableUrlIfEncodingUTF8, EnableUrlIfEncodingUTF8, ForceOfflineMode, DontPerformClientPull, DownloadInSilentMode, WorkOffline); TDownloadControlOptions = set of TDownloadControlOption; { Doc Host Flags: http://msdn.microsoft.com/en-us/library/aa753277.aspx } { TUserInterfaceOption = (DIALOG, DISABLE_HELP_MENU, NO3DBORDER, SCROLL_NO, DISABLE_SCRIPT_INACTIVE, OPENNEWWIN, DISABLE_OFFSCREEN, FLAT_SCROLLBAR, DIV_BLOCKDEFAULT, ACTIVATE_CLIENTHIT_ONLY, OVERRIDEBEHAVIORFACTORY, CODEPAGELINKEDFONTS, URL_ENCODING_DISABLE_UTF8, URL_ENCODING_ENABLE_UTF8, ENABLE_FORMS_AUTOCOMPLETE, ENABLE_INPLACE_NAVIGATION, IME_ENABLE_RECONVERSION, THEME, NOTHEME, NOPICS, NO3DOUTERBORDER, DISABLE_EDIT_NS_FIXUP, LOCAL_MACHINE_ACCESS_CHECK, DISABLE_UNTRUSTEDPROTOCOL, HOST_NAVIGATES, ENABLE_REDIRECT_NOTIFICATION, USE_WINDOWLESS_SELECTCONTROL, USE_WINDOWED_SELECTCONTROL, ENABLE_ACTIVEX_INACTIVATE_MODE); } TUserInterfaceOption = (DisableTextSelect, DisableHelpMenu, DontUse3DBorders, DontUseScrollBars, PostponeScriptUntilActive, ForceOpenNewWindow, Reserved_OFFSCREEN, ForceFlatScrollBars, InsertDivTagOnEditMode, ActivateUIOnlyOnDocClick, ConsultBeforeRetrievingBehavior, CheckFontSupportsCodePage, DisableSubmitUrlInUTF8, EnableSubmitUrlInUTF8, EnablesFormsAutoComplete, ForceSameWindowNavigation, EmableImeLocalLanguages, EnableThemes, DisableThemes, DisablePicsRatings, DisableFrameSetBorder, DisablesAutoNameSpaceCorrection, DisableLocalFileAccess, DisableUntrustedProtocol, CheckNavigationDelegatedToHost, EnableRedirectNotification, EnableDomWindlessControls, EnableWindowedControls, ForceUserActivationOnActiveXJava); TUserInterfaceOptions = set of TUserInterfaceOption; {events} TMenuPreprocess = procedure(Sender: TObject; ID: DWORD; Menu: HMENU; const Context: IDispatch) of object; TEWBNotifyEvent = procedure(Sender: TObject; var Rezult: HRESULT) of object; TBoolQueryEvent = procedure(Sender: TObject; var Value: BOOL) of object; TMaskedCtrlCharEvent = procedure(Sender: TCustomEmbeddedWB; MaskedChar: Char) of object; TOMWindowMoveEvent = procedure(Sender: TCustomEmbeddedWB; cx, cy: Integer) of object; {IDocHostShowUI Interface} TShowHelpEvent = function(Sender: TObject; HWND: THandle; pszHelpFile: POleStr; uCommand: Integer; dwData: Longint; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT of object; TShowMessageEvent = function(Sender: TObject; HWND: THandle; lpstrText: POleStr; lpstrCaption: POleStr; dwType: Longint; lpstrHelpFile: POleStr; dwHelpContext: Longint; var plResult: LRESULT): HRESULT of object; {IDocHostUIHandler Interface} TEnableModelessEvent = procedure(Sender: TCustomEmbeddedWB; const fEnable: BOOL) of object; TFilterDataObjectEvent = procedure(Sender: TCustomEmbeddedWB; const pDO: IDataObject; var ppDORet: IDataObject) of object; TGetDropTargetEvent = procedure(Sender: TCustomEmbeddedWB; var DropTarget: IDropTarget) of object; TGetExternalEvent = procedure(Sender: TCustomEmbeddedWB; var ppDispatch: IDispatch) of object; TGetHostInfoEvent = procedure(Sender: TCustomEmbeddedWB; var pInfo: TDOCHOSTUIINFO) of object; TGetOptionKeyPathEvent = procedure(Sender: TCustomEmbeddedWB; var pchKey: POleStr) of object; TOnActivateEvent = procedure(Sender: TCustomEmbeddedWB; const fActivate: BOOL) of object; TResizeBorderEvent = procedure(Sender: TCustomEmbeddedWB; const prcBorder: PRect; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL) of object; TShowContextMenuEvent = procedure(Sender: TCustomEmbeddedWB; const dwID: DWORD; const ppt: PPOINT; const CommandTarget: IUnknown; const Context: IDispatch; var Result: HRESULT) of object; TShowUIEvent = procedure(Sender: TCustomEmbeddedWB; const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow; var Rezult: HRESULT) of object; TTranslateAcceleratorEvent = procedure(Sender: TCustomEmbeddedWB; const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD; var Done: Boolean) of object; TTranslateUrlEvent = procedure(Sender: TCustomEmbeddedWB; const pchURLIn: POleStr; var ppchURLOut: WideString) of object; {$IFDEF USE_IOLECOMMANDTARGET} TRefreshEvent = procedure(Sender: TCustomEmbeddedWB; CmdID: Integer; var Cancel: Boolean) of object; {$ENDIF} {INewWindowManager Interface} TEvaluateNewWindowEvent = procedure(Sender: TCustomEmbeddedWB; pszUrl, pszName, pszUrlContext, pszFeatures: LPCWSTR; fReplace: BOOL; dwFlags, dwUserActionTime: DWORD; var Rezult: HRESULT) of object; {IDownloadManager Interface} TDownloadEvent = procedure(Sender: TCustomEmbeddedWB; pmk: IMoniker; pbc: IBindCtx; dwBindVerb: DWORD; grfBINDF: DWORD; pBindInfo: PBindInfo; pszHeaders: PWideChar; pszRedir: PWidechar; uiCP: UINT; var Rezult: HRESULT) of object; {IAuthenticate Interface} TAuthenticateEvent = procedure(Sender: TCustomEmbeddedWB; var hwnd: HWnd; var szUserName, szPassWord: WideString; var Rezult: HRESULT) of object; {IZoomEvents Interface} TZoomPercentChangedEvent = function(Sender: TCustomEmbeddedWB; const ulZoomPercent: uLong): HRESULT of object; {Script Error handling} TScriptErrorAction = (eaContinue, eaCancel, eaAskUser); TScriptErrorEvent = procedure(Sender: TObject; ErrorLine, ErrorCharacter, ErrorCode, ErrorMessage, ErrorUrl: string; var ScriptErrorAction: TScriptErrorAction) of object; {User Agent Mode Event} TSetUserAgentEvent = function(var UserAgent: string): HRESULT of object; { TCustomEmbeddedWB } TCustomEmbeddedWB = class(TEWB , IDispatch // http://msdn.microsoft.com/en-us/library/ms221608.aspx , IDocHostShowUI // http://msdn.microsoft.com/en-us/library/aa753269.aspx , IDocHostUIHandler // http://msdn.microsoft.com/en-us/library/aa753260(VS.85).aspx , IDocHostUIHandler2 // http://msdn.microsoft.com/en-us/library/aa753275(VS.85).aspx , IDropTarget // http://msdn.microsoft.com/en-us/library/ms679679.aspx {$IFDEF USE_IOLECOMMANDTARGET} , IOleCommandTarget // http://msdn.microsoft.com/en-us/library/ms683797.aspx {$ENDIF} , IServiceProvider // http://msdn.microsoft.com/en-us/library/cc678965(VS.85).aspx , INewWindowManager // http://msdn.microsoft.com/en-us/library/bb775418(VS.85).aspx , IProtectFocus // http://msdn2.microsoft.com/en-us/library/aa361771.aspx , IDownloadManager // http://msdn.microsoft.com/en-us/library/aa753613(VS.85).aspx , IHTMLOMWindowServices //http://msdn.microsoft.com/library/default.asp?url=/workshop/browser/hosting/reference/ifaces/IHTMLOMWindowServices/IHTMLOMWindowServices.asp , IHostBehaviorInit // http://msdn.microsoft.com/en-us/library/aa753687(VS.85).aspx , IZoomEvents // http://msdn.microsoft.com/en-us/library/aa770056(VS.85).aspx , IAuthenticate // http://msdn.microsoft.com/en-us/library/ms835407.aspx ) private FOnZoomPercentChanged: TZoomPercentChangedEvent; FOnGetIDsOfNames: TGetIDsOfNamesEvent; FOnGetTypeInfo: TGetTypeInfoEvent; FOnGetTypeInfoCount: TGetTypeInfoCountEvent; FOnInvoke: TInvokeEvent; FDownloadControlOptions: TDownloadControlOptions; FOnShowMessage: TShowMessageEvent; FOnShowHelp: TShowHelpEvent; FHelpFile: string; fOptionKeyPath: string; fOverOptionKeyPath: Boolean; FOnFilterDataObject: TFilterDataObjectEvent; FOnGetExternal: TGetExternalEvent; FOnGetHostInfo: TGetHostInfoEvent; FUserInterfaceOptions: TUserInterfaceOptions; FOnEnableModeless: TEnableModelessEvent; {$IFDEF GETKEYPATH_HANDLERS} FOnGetOptionKeyPath: TGetOptionKeyPathEvent; FOnGetOverrideKeyPath: TGetOptionKeyPathEvent; {$ENDIF} FOnGetDropTarget: TGetDropTargetEvent; FOnHideUI: TEWBNotifyEvent; FOnOnDocWindowActivate: TOnActivateEvent; FOnOnFrameWindowActivate: TOnActivateEvent; FOnResizeBorder: TResizeBorderEvent; FOnShowContextmenu: TShowContextMenuEvent; FOnShowUI: TShowUIEvent; FOnTranslateAccelerator: TTranslateAcceleratorEvent; FOnTranslateUrL: TTranslateUrlEvent; FOnUpdateUI: TEWBNotifyEvent; FOnDragLeaveEvent: TNotifyEvent; FOnDragEnterEvent: TOnDragEnterEvent; FOnDragOverEvent: TOnDragOverEvent; FOnDropEvent: TOnDropEvent; FOnScriptError: TScriptErrorEvent; FScriptErrorAction: TScriptErrorAction; {$IFDEF USE_IOLECOMMANDTARGET} FOnUnload: TNotifyEvent; FOnRefresh: TRefreshEvent; FOnCommandExec: TComTargetExecEvent; {$ENDIF} FOnQueryService: TQueryServiceEvent; FOnEvaluateNewWindow: TEvaluateNewWindowEvent; FCanGrabFocus: Boolean; FOnAllowFocusChange: TBoolQueryEvent; FOnDownload: TDownloadEvent; FDropHandlingType: TDragDropHandlingType; FZoomPercent: Integer; FDesignMode: Boolean; FDisabledPopupMenus: TIEPopupMenus; FOnFilterPopupMenu: TMenuPreprocess; FOnMaskedCtrlChar: TMaskedCtrlCharEvent; FDisableCtrlShortcuts: string; FOnResize: TOMWindowMoveEvent; FOnMoveBy: TOMWindowMoveEvent; FOnMove: TOMWindowMoveEvent; FOnResizeBy: TOMWindowMoveEvent; FFloatingHosting: Boolean; FOnPopulateNSTable: TNotifyEvent; FOnAuthenticate: TAuthenticateEvent; {$IFDEF RESEARCH_MODE} FOnQueryInterface: OnQueryInterfaceEvent; {$ENDIF} procedure SetDownloadOptions(const Value: TDownloadControlOptions); procedure SetUserInterfaceOptions(const Value: TUserInterfaceOptions); function GetDoc2: IHtmlDocument2; function GetDoc3: IHtmlDocument3; function GetDoc4: IHtmlDocument4; function GetDoc5: IHtmlDocument5; function GetElemByID(const ID: WideString): IHTMLElement; function GetZoom: Integer; procedure SetZoom(const Value: Integer); procedure setOpticalZoom(const Value: Integer); function _getCookie: WideString; function GetCharSet: WideString; procedure SetCharSet(const Value: WideString); procedure SetDropHandlingType(const Value: TDragDropHandlingType); procedure SetDesignMode(const Value: Boolean); function GetDocDesignMode: TDocDesignMode; procedure SetDocDesignMode(const Value: TDocDesignMode); function GetBody: IHTMLElement; protected CurrentHandle: HWND; //jls procedure CreateWnd; override; //jls procedure DestroyWnd; override; //jls protected {$IFDEF RESEARCH_MODE} { IInterface } function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall; {$ENDIF} {IDispatch Interface} function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; stdcall; function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall; {IDocHostShowUI Interface } function ShowHelp(HWND: THandle; pszHelpFile: POleStr; uCommand: Integer; dwData: Longint; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT; stdcall; function ShowMessage(HWND: THandle; lpstrText: POleStr; lpstrCaption: POleStr; dwType: Longint; lpstrHelpFile: POleStr; dwHelpContext: Longint; var plResult: LRESULT): HRESULT; stdcall; {IDocHostUIHandler Interface} function EnableModeless(const fEnable: BOOL): HRESULT; stdcall; function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall; function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall; function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall; function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall; function GetOptionKeyPath(out pchKey: POleStr; const dw: DWORD): HRESULT; stdcall; function HideUI: HRESULT; stdcall; function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall; function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall; function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL): HRESULT; stdcall; function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const CommandTarget: IUnknown; const Context: IDispatch): HRESULT; stdcall; function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall; function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; stdcall; function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POleStr; out ppchURLOut: POleStr): HRESULT; stdcall; function UpdateUI: HRESULT; stdcall; {IDocHostUIHandler2 Interface} function GetOverrideKeyPath(out pchKey: POleStr; dw: DWORD): HRESULT; stdcall; {IDropTarget Interface} function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; function IDropTarget.DragOver = DropTargetDragOver; function DropTargetDragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; function DragLeave: HRESULT; stdcall; function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; {$IFDEF USE_IOLECOMMANDTARGET} {IOleCommandTarget interface} function IOleCommandTarget.QueryStatus = CommandTarget_QueryStatus; function CommandTarget_QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; stdcall; function IOleCommandTarget.Exec = CommandTarget_Exec; function CommandTarget_Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall; {$ENDIF} {IServiceProvider Interface} function QueryService(const rsid, iid: TGUID; out Obj): HRESULT; stdcall; {INewWindowManager Interface} function EvaluateNewWindow(pszUrl, pszName, pszUrlContext, pszFeatures: LPCWSTR; fReplace: BOOL; dwFlags, dwUserActionTime: DWORD): HRESULT; stdcall; {IProtectFocus IE7 interface} function AllowFocusChange(out pfAllow: BOOL): HRESULT; stdcall; {IDownloadManager Interface} function Download( pmk: IMoniker; // Identifies the object to be downloaded pbc: IBindCtx; // Stores information used by the moniker to bind dwBindVerb: DWORD; // The action to be performed during the bind grfBINDF: DWORD; // Determines the use of URL encoding during the bind pBindInfo: PBindInfo; // Used to implement IBindStatusCallback::GetBindInfo pszHeaders: PWidechar; // Additional headers to use with IHttpNegotiate pszRedir: PWidechar; // The URL that the moniker is redirected to uiCP: UINT // The code page of the object's display name ): HRESULT; stdcall; {IHostBehaviorInit} function PopulateNamespaceTable: HRESULT; stdcall; {IHTMLOMWindowServices Interface} function ResizeBy(const x, y: Integer): HRESULT; stdcall; function ResizeTo(const x, y: Integer): HRESULT; stdcall; function MoveBy(const x, y: Integer): HRESULT; stdcall; function MoveTo(const x, y: Integer): HRESULT; stdcall; {IZoomEvents interface} function OnZoomPercentChanged(const ulZoomPercent: uLong): HRESULT; stdcall; {IAuthenticate} function Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR): HRESULT; stdcall; protected FDownloadOptionValue: Longint; FUserInterfaceValue: Cardinal; FOnSetUserAgent: TSetUserAgentEvent; FOnPreRefresh: TNotifyEvent; FOnHookChildWindow : TNotifyEvent; procedure UpdateDownloadControlValues; procedure UpdateUserInterfaceValues; function CopyOptionKeyPath(Overrided: Boolean): PWideChar; function DoFilterMsg(const lpMsg: PMSG): Boolean; virtual; function ScriptErrorHandler(const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; virtual; function DoQueryService(const rsid, iid: TGUID; var Obj): Boolean; virtual; function FilterPopupMenu: Boolean; virtual; procedure DoFilterPopupMenu(Sender: TObject; ID: DWORD; Menu: HMENU; const Context: IDispatch); virtual; procedure MoveParentForm(x, y: Integer; Delta: Boolean); procedure ResizeParentForm(w, h: Integer; Delta: Boolean); public class function dwEffectToStr(Command: Int64): string; class procedure DropEffect(grfKeyState: Longint; var dwEffect: longint); constructor Create(AOwner: TComponent); override; destructor Destroy; override; function InvokeCommand(CmdGroup: PGUID; Cmd, nCmdexecopt: DWORD; var vaIn, vaOut: OleVariant): HRESULT; overload; function InvokeCommand(CmdGroup: PGUID; Cmd: DWORD): HRESULT; overload; function QueryCommandStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; function QueryCMDEnabled(CmdGroup: PGUID; cmdID: Cardinal): Boolean; function QueryCMDLatched(CmdGroup: PGUID; cmdID: Cardinal): Boolean; function QueryCMDStatus(CmdGroup: PGUID; cmdID: Cardinal): OLECMDF; function QueryCMDArrayStatus(CmdGroup: PGUID; cmds: TOleCmdArray): Boolean; procedure Client2HostWin(var CX, CY: Integer); // just call it in OnClientToHostWindow handler function GetIEWin(const ClassName: string): HWND; procedure SetFocusToDoc; procedure SetFocusToBody; procedure SetFocusToParent; function ZoomRangeHigh: Integer; function ZoomRangeLow: Integer; property Zoom: Integer read getZoom write setZoom; property ZoomPercent: Integer read FZoomPercent write setOpticalZoom default 100; property Cookie: WideString read _getCookie; property DesignMode: Boolean read FDesignMode write SetDesignMode; {html functions} property Doc2: IHtmlDocument2 read GetDoc2; property Doc3: IHtmlDocument3 read GetDoc3; property Doc4: IHtmlDocument4 read GetDoc4; property Doc5: IHtmlDocument5 read GetDoc5; property Body: IHTMLElement read getBody; property DocDesignMode: TDocDesignMode read getDocDesignMode write setDocDesignMode; property CharactersSet: WideString read GetCharSet write SetCharSet; property ElementByID[const ID: WideString]: IHTMLElement read getElemByID; function ScrollToElement(Element: IHTMLElement): Boolean; function GetElementNamespaceTable(out aTable: IElementNamespaceTable): Boolean; {$IFDEF RESEARCH_MODE} property OnQueryInterface: OnQueryInterfaceEvent read fOnQueryInterface write fOnQueryInterface; {$ENDIF} property CanGrabFocus: Boolean read FCanGrabFocus write FCanGrabFocus default True; published property OnAllowFocusChange: TBoolQueryEvent read FOnAllowFocusChange write FOnAllowFocusChange; property DisableCtrlShortcuts: string read FDisableCtrlShortcuts write FDisableCtrlShortcuts; property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions write SetDownloadOptions default [DownloadImages, DownloadVideos, DownloadBGSounds]; property UserInterfaceOptions: TUserInterfaceOptions read FUserInterfaceOptions write SetUserInterfaceOptions default []; property HelpFile: string read FHelpFile write FHelpFile; property OptionKeyPath: string read FOptionKeyPath write FOptionKeyPath; property OverrideOptionKeyPath: Boolean read FOverOptionKeyPath write FOverOptionKeyPath default False; property DropHandlingType: TDragDropHandlingType read FDropHandlingType write setDropHandlingType default ddtMS; property DisabledPopupMenus: TIEPopupMenus read FDisabledPopupMenus write FDisabledPopupMenus default []; property FloatingHosting: Boolean read FFloatingHosting write fFloatingHosting default False; property OnGetIDsOfNames: TGetIDsOfNamesEvent read FOnGetIDsOfNames write FOnGetIdsOfNames; property OnGetTypeInfo: TGetTypeInfoEvent read FonGetTypeInfo write FOnGetTypeInfo; property OnGetTypeInfoCount: TGetTypeInfoCountEvent read FonGetTypeInfoCount write FOnGetTypeInfoCount; property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke; property OnShowHelpRequest: TShowHelpEvent read FOnShowHelp write FOnShowHelp; property OnShowMessage: TShowMessageEvent read FOnShowMessage write FOnShowMessage; property OnFilterDataObject: TFilterDataObjectEvent read FOnFilterDataObject write FOnFilterDataObject; property OnGetExternal: TGetExternalEvent read FOnGetExternal write FOnGetExternal; property OnGetHostInfo: TGetHostInfoEvent read FOnGetHostInfo write FOnGetHostInfo; property OnEnableModeless: TEnableModelessEvent read FOnEnableModeless write FOnEnableModeless; {$IFDEF GETKEYPATH_HANDLERS} property OnGetOptionKeyPath: TGetOptionKeyPathEvent read FOnGetOptionKeyPath write FOnGetOptionKeyPath; property OnGetOverrideKeyPath: TGetOptionKeyPathEvent read FOnGetOverrideKeyPath write FOnGetOverrideKeyPath; {$ENDIF} property OnZoomPercentChange: TZoomPercentChangedEvent read FOnZoomPercentChanged write FOnZoomPercentChanged; property OnGetDropTarget: TGetDropTargetEvent read FOnGetDropTarget write FOnGetDropTarget; property OnHideUI: TEWBNotifyEvent read FOnHideUI write FOnHideUI; property OnOnDocWindowActivate: TOnActivateEvent read FOnOnDocWindowActivate write FOnOnDocWindowActivate; property OnOnFrameWindowActivate: TOnActivateEvent read FOnOnFrameWindowActivate write FOnOnFrameWindowActivate; property OnResizeBorder: TResizeBorderEvent read FOnResizeBorder write FOnResizeBorder; property OnShowContextMenu: TShowContextMenuEvent read FOnShowContextmenu write FOnShowContextmenu; property OnShowUI: TShowUIEvent read FOnShowUI write FOnShowUI; property OnTranslateAccelerator: TTranslateAcceleratorEvent read FOnTranslateAccelerator write FOnTranslateAccelerator; property OnTranslateUrl: TTranslateUrlEvent read FOnTranslateUrL write FOnTranslateUrL; property OnUpdateUI: TEWBNotifyEvent read FOnUpdateUI write FOnUpdateUI; property OnDragEnter: TOnDragEnterEvent read FOnDragEnterEvent write FOnDragEnterEvent; property OnDragLeave: TNotifyEvent read FOnDragLeaveEvent write FOnDragLeaveEvent; property OnDragOver2: TOnDragOverEvent read FOnDragOverEvent write FOnDragOverEvent; property OnDropEvent: TOnDropEvent read FOnDropEvent write FOnDropEvent; property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError; property ScriptErrorAction: TScriptErrorAction read FScriptErrorAction write FScriptErrorAction default eaContinue; {$IFDEF USE_IOLECOMMANDTARGET} property OnRefresh: TRefreshEvent read FOnRefresh write FOnRefresh; property OnUnload: TNotifyEvent read FOnUnload write FOnUnload; property OnCommandExec: TComTargetExecEvent read FOnCommandExec write fOnCommandExec; {$ENDIF} property OnQueryService: TQueryServiceEvent read FOnQueryService write FOnQueryService; property OnEvaluateNewWindow: TEvaluateNewWindowEvent read FOnEvaluateNewWindow write FOnEvaluateNewWindow; property OnFileDownload: TDownloadEvent read FOnDownload write FOnDownload; property OnFilterPopupMenu: TMenuPreprocess read FOnFilterPopupMenu write FOnFilterPopupMenu; property OnMaskedCtrlChar: TMaskedCtrlCharEvent read FOnMaskedCtrlChar write FOnMaskedCtrlChar; property OnMove: TOMWindowMoveEvent read FOnMove write FOnMove; property OnMoveBy: TOMWindowMoveEvent read FOnMoveBy write FOnMoveBy; property OnResize: TOMWindowMoveEvent read FOnResize write FOnResize; property OnResizeBy: TOMWindowMoveEvent read FOnResizeBy write FOnResizeBy; property OnPopulateNSTable: TNotifyEvent read FOnPopulateNSTable write FOnPopulateNSTable; property OnAuthenticate: TAuthenticateEvent read FOnAuthenticate write FOnAuthenticate; property OnPreRefresh: TNotifyEvent read FOnPreRefresh write FOnPreRefresh; end; TEwbCore = class(TCustomEmbeddedWB) private function IsCtrlCharMask: Boolean; published property DisableCtrlShortcuts stored IsCtrlCharMask; end; //this two functions for using in custom OnShowContextMenu handler. function IsSeTIEPopupMenus(ID: DWORD; rcm: TIEPopupMenus): Boolean; function ShowRightClickMenu(Sender: TObject; dwID: DWORD; const Target: IUnknown; const Context: IDispatch; const ppt: PPOINT; const EncodingSubMenu: OleVariant; preprocess: TMenuPreprocess = nil): Boolean; implementation uses SysUtils, ComObj, EwbCoreTools, Registry; function IsSeTIEPopupMenus(ID: DWORD; rcm: TIEPopupMenus): Boolean; begin Result := (rcmAll in rcm) or ((ID in [0..9]) and (TIEPopupMenu(ID) in rcm)); end; function ShowRightClickMenu(Sender: TObject; dwID: DWORD; const Target: IUnknown; const Context: IDispatch; const ppt: PPOINT; const EncodingSubMenu: OleVariant; Preprocess: TMenuPreprocess = nil): Boolean; var ShDocLcHandle: THandle; OleCommandTarget: IOleCommandTarget; OleWindow: IOleWindow; WindowHandle: HWND; ParentMenu, SubMenu: HMENU; SubMenuItemInfo: MENUITEMINFO; PopupResult: LongBool; begin Result := False; ShDocLcHandle := GetSHDOCLCModule; if ShDocLcHandle = 0 then Exit; if Supports(Target, IOleCommandTarget, OleCommandTarget) and Supports(Target, IOleWindow, OleWindow) and ActiveX.Succeeded(OleWindow.GetWindow(WindowHandle)) then begin ParentMenu := Windows.LoadMenu(ShDocLcHandle, MAKEINTRESOURCE(CContextMenuID)); if ParentMenu <> 0 then try SubMenu := GetSubMenu(ParentMenu, dwID); FillChar(SubMenuItemInfo, SizeOf(SubMenuItemInfo), 0); SubMenuItemInfo.cbSize := SizeOf(MENUITEMINFO); SubMenuItemInfo.fMask := MIIM_SUBMENU; SubMenuItemInfo.hSubMenu := HMENU(@EncodingSubMenu); SetMenuItemInfo(SubMenu, IDM_LANGUAGE, False, SubMenuItemInfo); if Assigned(Preprocess) then Preprocess(Sender, dwID, SubMenu, Context); PopupResult := Windows.TrackPopupMenuEx(SubMenu, TPM_LEFTALIGN or TPM_TOPALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON or TPM_HORPOSANIMATION or TPM_VERPOSANIMATION, ppt^.X, ppt^.Y, WindowHandle, nil); if PopupResult then SendMessage(WindowHandle, WM_COMMAND, MakeWParam(LOWORD(PopupResult), 0), 0); Result := True; finally DestroyMenu(ParentMenu); end; end; end; type { TnoDragDrop } TnoDragDrop = class(TInterfacedObject, IDropTarget) protected function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; function DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; function DragLeave: HRESULT; stdcall; function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HRESULT; stdcall; end; function TnoDragDrop.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; begin dwEffect := DROPEFFECT_NONE; Result := S_OK; end; function TnoDragDrop.DragLeave: HRESULT; begin Result := S_OK; end; function TnoDragDrop.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; begin dwEffect := DROPEFFECT_NONE; Result := S_OK; end; function TnoDragDrop.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; begin dwEffect := DROPEFFECT_NONE; Result := S_OK; end; { TCustomEmbeddedWB } class function TCustomEmbeddedWB.dwEffectToStr(Command: Int64): string; const E_UNSPEC = E_Fail; begin case (Command) of DROPEFFECT_NONE: Result := 'Drop target cannot accept the data.'; DROPEFFECT_COPY: Result := 'Drag source should copy the data.'; DROPEFFECT_MOVE: Result := 'Drag source should remove the data.'; DROPEFFECT_LINK: Result := 'Drag source should create a link to the original data.'; DRAGDROP_S_DROP: Result := 'The drag-and-drop operation was successful.'; DRAGDROP_S_CANCEL: Result := 'The drag-and-drop operation was canceled.'; DRAGDROP_S_USEDEFAULTCURSORS: Result := 'Successful completion. Restoring defaults.'; DRAGDROP_E_INVALIDHWND: Result := 'Invalid handle returned in the hwnd parameter.'; DRAGDROP_E_NOTREGISTERED: Result := 'Failed to revoke a drop target that has not been registered.'; E_UNSPEC: Result := 'Unexpected error occurred.'; E_OUTOFMEMORY: Result := 'Out of memory.'; 7: Result := 'operation was successful.'; else Result := 'Unknown.'; end; end; class procedure TCustomEmbeddedWB.DropEffect(grfKeyState: Longint; var dwEffect: longint); begin if (grfKeyState and MK_CONTROL = 0) and (grfKeyState and MK_SHIFT <> 0) and (dwEffect and DropEffect_Move <> 0) then dwEffect := DropEffect_Move else if (grfKeyState and MK_CONTROL <> 0) and (grfKeyState and MK_SHIFT <> 0) and (dwEffect and DropEffect_Link <> 0) then dwEffect := DropEffect_Link else if (dwEffect and DropEffect_Copy <> 0) then dwEffect := DropEffect_Copy else if (dwEffect and DropEffect_Move <> 0) then dwEffect := DropEffect_Move else if (dwEffect and DropEffect_Link <> 0) then dwEffect := DropEffect_Link else dwEffect := DropEffect_None; end; function TCustomEmbeddedWB.AllowFocusChange(out pfAllow: BOOL): HRESULT; begin Result := S_OK; pfAllow := CanGrabFocus; if Assigned(OnAllowFocusChange) then OnAllowFocusChange(Self, pfAllow); end; function TCustomEmbeddedWB.CopyOptionKeyPath(Overrided: Boolean): PWideChar; begin if (OptionKeyPath = '') or (OverrideOptionKeyPath xor Overrided) then Result := nil else Result := StringToLPOLESTR(OptionKeyPath); end; constructor TCustomEmbeddedWB.Create(AOwner: TComponent); begin inherited; FCanGrabFocus := True; FScriptErrorAction := eaContinue; DownloadOptions := [DownloadImages, DownloadVideos, DownloadBGSounds]; UserInterfaceOptions := [EnableThemes, EnablesFormsAutoComplete]; FDropHandlingType := ddtMS; FDisableCtrlShortcuts := 'N'; end; destructor TCustomEmbeddedWB.Destroy(); begin inherited; end; procedure TCustomEmbeddedWB.CreateWnd; //jls begin if (CurrentHandle <> 0) and IsWindow(CurrentHandle) then begin WindowHandle := CurrentHandle; CurrentHandle := 0; Windows.SetParent(WindowHandle, TWinControl(Self).Parent.Handle); MoveWindow(WindowHandle, 0, 0, TWinControl(Self).Parent.Width, TWinControl(Self).Parent.Height, True); //Force a resize on the client window end else inherited; end; procedure TCustomEmbeddedWB.DestroyWnd; //jls begin if (csDestroying in ComponentState) then inherited else begin Windows.SetParent(WindowHandle, Forms.Application.Handle); //Parent to the Application window which is 0x0 in size CurrentHandle := WindowHandle; // Save the WindowHandle WindowHandle := 0; // Set it to 0 so Createwnd will be called again... end; end; function TCustomEmbeddedWB.EnableModeless(const fEnable: BOOL): HRESULT; begin Result := S_OK; if Assigned(FOnEnableModeless) then FOnEnableModeless(Self, fEnable); end; function TCustomEmbeddedWB.EvaluateNewWindow(pszUrl, pszName, pszUrlContext, pszFeatures: LPCWSTR; fReplace: BOOL; dwFlags, dwUserActionTime: DWORD): HRESULT; begin Result := E_FAIL; if Assigned(FOnEvaluateNewWindow) then FOnEvaluateNewWindow(Self, pszUrl, pszName, pszUrlContext, pszFeatures, FReplace, dwFlags, dwUserActionTime, Result); end; function TCustomEmbeddedWB.FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; begin ppDORet := nil; if Assigned(FOnFilterDataObject) then FOnFilterDataObject(Self, pDO, ppDORet); if ppDORet = nil then Result := S_FALSE else Result := S_OK; end; function TCustomEmbeddedWB.GetDoc2: IHtmlDocument2; begin if not Supports(Document, IHtmlDocument2, Result) then Result := nil; end; function TCustomEmbeddedWB.GetDoc3: IHtmlDocument3; begin if not Supports(Document, IHtmlDocument3, Result) then Result := nil; end; function TCustomEmbeddedWB.GetDoc4: IHtmlDocument4; begin if not Supports(Document, IHtmlDocument4, Result) then Result := nil; end; function TCustomEmbeddedWB.GetDoc5: IHtmlDocument5; begin if not Supports(Document, IHtmlDocument5, Result) then Result := nil; end; function TCustomEmbeddedWB.getBody: IHTMLElement; var D: IHtmlDocument2; begin if Supports(Document, IHtmlDocument2, D) then Result := D.body else Result := nil; end; function TCustomEmbeddedWB.GetExternal(out ppDispatch: IDispatch): HRESULT; begin ppDispatch := nil; if Assigned(FOnGetExternal) then FOnGetExternal(Self, ppDispatch); if ppDispatch = nil then Result := S_FALSE else Result := S_OK; end; function TCustomEmbeddedWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; begin FillChar(pInfo, SizeOf(TDOCHOSTUIINFO), #0); pInfo.cbSize := SizeOf(pInfo); pInfo.dwFlags := FUserInterfaceValue; pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT; Result := S_OK; if Assigned(FOnGetHostInfo) then FOnGetHostInfo(Self, pInfo); end; function TCustomEmbeddedWB.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; begin Result := inherited GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs); if Assigned(FOnGetIDsOfNames) then FOnGetIDsOfNames(Self, IID, Names, NameCount, LocaleID, DispIds, Result); end; function TCustomEmbeddedWB.GetIEWin(const ClassName: string): HWND; var szClass: array[0..255] of char; begin if HandleAllocated then begin Result := GetWindow(WindowHandle, GW_CHILD); repeat if (GetClassName(Result, szClass, SizeOf(szClass)) > 0) and (AnsiStrComp(PChar(ClassName), szClass) = 0) then Exit; Result := GetWindow(Result, GW_CHILD); until not IsWindow(Result); end; Result := 0; end; function TCustomEmbeddedWB.GetOptionKeyPath(out pchKey: POleStr; const dw: DWORD): HRESULT; begin pchKey := CopyOptionKeyPath(False); {$IFDEF GETKEYPATH_HANDLERS} if Assigned(FOnGetOptionKeyPath) then FOnGetOptionKeyPath(Self, pchKey); {$ENDIF} if pchKey = nil then Result := S_FALSE else Result := S_OK; end; function TCustomEmbeddedWB.GetOverrideKeyPath(out pchKey: POleStr; dw: DWORD): HRESULT; begin pchKey := CopyOptionKeyPath(True); {$IFDEF GETKEYPATH_HANDLERS} if Assigned(FOnGetOverrideKeyPath) then FOnGetOverrideKeyPath(Self, pchKey); {$ENDIF} if pchKey = nil then Result := S_FALSE else Result := S_OK; end; function TCustomEmbeddedWB.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; begin Result := inherited GetTypeInfo(Index, LocaleID, TypeInfo); if Assigned(FOnGetTypeInfo) then FOnGetTypeInfo(Self, Index, LocaleID, ITypeInfo(TypeInfo), Result); end; function TCustomEmbeddedWB.GetTypeInfoCount(out Count: Integer): HRESULT; begin Result := inherited GetTypeInfoCount(Count); if Assigned(FOnGetTypeInfoCount) then FOnGetTypeInfoCount(Self, Count, Result); end; function TCustomEmbeddedWB.GetZoom: Integer; var vaIn, vaOut: OleVariant; begin vaIn := NULL; InvokeCommand(nil, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); Result := vaOut; end; procedure TCustomEmbeddedWB.SetZoom(const Value: Integer); var vaIn, vaOut: OleVariant; Range: DWORD; begin InvokeCommand(nil, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); Range := DWORD(vaOut); if Value < LoWord(Range) then vaIn := LoWord(Range) else if Value > HiWord(Range) then vaIn := HiWord(Range) else vaIn := Value; InvokeCommand(nil, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); end; procedure TCustomEmbeddedWB.SetOpticalZoom(const Value: Integer); var vaIn, vaOut: OleVariant; Range: DWORD; begin if FZoomPercent <> Value then begin FZoomPercent := Value; InvokeCommand(nil, OLECMDID_OPTICAL_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); Range := DWORD(vaOut); if Value < LoWord(Range) then vaIn := LoWord(Range) else if Value > HiWord(Range) then vaIn := HiWord(Range) else vaIn := Value; InvokeCommand(nil, OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); if Assigned(FOnZoomPercentChanged) then FOnZoomPercentChanged(Self, vaOut); end; end; function TCustomEmbeddedWB.HideUI: HRESULT; begin Result := S_FALSE; if Assigned(FOnHideUI) then FOnHideUI(Self, Result); end; function TCustomEmbeddedWB.InvokeCommand(CmdGroup: PGUID; Cmd, nCmdexecopt: DWORD; var vaIn, vaOut: OleVariant): HRESULT; var CmdTarget: IOleCommandTarget; begin if Supports(Document, IOleCommandTarget, CmdTarget) then Result := CmdTarget.Exec(CmdGroup, Cmd, nCmdexecopt, vaIn, vaOut) else Result := E_UNEXPECTED; end; function TCustomEmbeddedWB.InvokeCommand(CmdGroup: PGUID; Cmd: DWORD): HRESULT; var CmdTarget: IOleCommandTarget; vaIn, vaOut: Olevariant; begin if Supports(Document, IOleCommandTarget, CmdTarget) then Result := CmdTarget.Exec(CmdGroup, Cmd, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut) else Result := E_UNEXPECTED; end; function TCustomEmbeddedWB.QueryCMDArrayStatus(CmdGroup: PGUID; cmds: TOleCmdArray): Boolean; var CmdTarget: IOleCommandTarget; begin if Supports(Document, IOleCommandTarget, CmdTarget) then Result := CmdTarget.QueryStatus(CmdGroup, Length(cmds), @Cmds, nil) = S_OK else Result := False; end; function TCustomEmbeddedWB.QueryCMDEnabled(CmdGroup: PGUID; cmdID: Cardinal): Boolean; begin Result := (QueryCMDStatus(CmdGroup, cmdID) and OLECMDF_ENABLED) <> 0; end; function TCustomEmbeddedWB.QueryCMDLatched(CmdGroup: PGUID; cmdID: Cardinal): Boolean; begin Result := (QueryCMDStatus(CmdGroup, cmdID) and OLECMDF_LATCHED) <> 0; end; function TCustomEmbeddedWB.QueryCMDStatus(CmdGroup: PGUID; cmdID: Cardinal): OLECMDF; var CmdTarget: IOleCommandTarget; Cmd: TOleCmd; begin Result := 0; if Supports(Document, IOleCommandTarget, CmdTarget) then begin Cmd.CmdID := cmdID; Cmd.cmdf := 0; if CmdTarget.QueryStatus(CmdGroup, 1, @Cmd, nil) = S_OK then Result := Cmd.cmdf; end; end; function TCustomEmbeddedWB.QueryCommandStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; var CmdTarget: IOleCommandTarget; begin if Supports(Document, IOleCommandTarget, CmdTarget) then Result := CmdTarget.QueryStatus(CmdGroup, cCmds, prgCmds, CmdText) else Result := E_UNEXPECTED; end; {$IFDEF RESEARCH_MODE} function TCustomEmbeddedWB.QueryInterface(const IID: TGUID; out Obj): HRESULT; begin Result := inherited QueryInterface(IID, Obj); if Assigned(OnQueryInterface) then OnQueryInterface(Self, IID, Obj, Result); end; {$ENDIF} function TCustomEmbeddedWB.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; var UserAgent: string; begin try Result := S_FALSE; if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then begin Result := S_OK; case DispID of DISPID_AMBIENT_DLCONTROL: begin PVariant(VarResult)^ := FDownloadOptionValue; end; DISPID_AMBIENT_USERMODE: begin POleVariant(VarResult)^ := not DesignMode; end; DISPID_AMBIENT_USERAGENT: begin Result := S_FALSE; if Assigned(FOnSetUserAgent) then begin if FOnSetUserAgent(UserAgent) = S_OK then if UserAgent <> '' then begin POleVariant(VarResult)^ := UserAgent + #13#10; Result := S_OK; end; end; end; else Result := S_FALSE; end; end else if (Flags and DISPATCH_PROPERTYPUT <> 0) and (DispID = DISPID_AMBIENT_USERMODE) then begin Result := S_OK; Self.FDesignMode := POleVariant(TDispParams(Params).rgvarg)^; end; if Result = S_FALSE then begin Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); if (result = DISP_E_MEMBERNOTFOUND) and Assigned(FOnInvoke) then FOnInvoke(Self, DispID, IID, LocaleID, Flags, TagDispParams(Params), VarResult, ExcepInfo, ArgErr, Result); end; except on E: Exception do begin Result := DISP_E_EXCEPTION; with PExcepInfo(ExcepInfo)^ do begin wCode := 9999; bstrDescription := E.Message; bstrSource := E.ClassName; dwHelpContext := E.HelpContext; end; end; end; end; function TCustomEmbeddedWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT; begin if Assigned(FOnOnDocWindowActivate) then FOnOnDocWindowActivate(Self, FActivate); Result := S_OK; end; function TCustomEmbeddedWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT; begin if Assigned(FOnOnFrameWindowActivate) then FOnOnFrameWindowActivate(Self, fActivate); Result := S_OK; end; function TCustomEmbeddedWB.DoQueryService(const rsid, iid: TGUID; var Obj): Boolean; begin if (IsEqualGuid(rsid, IID_INewWindowManager) and Assigned(FOnEvaluateNewWindow)) or IsEqualGuid(rsid, IID_IProtectFocus) or (IsEqualGuid(rsid, IID_IDownloadManager) and Assigned(FOnDownload)) or (IsEqualGuid(rsid, IID_IHostBehaviorInit) and Assigned(OnPopulateNSTable)) or (IsEqualGuid(rsid, IID_IHTMLOMWindowServices) and (FloatingHosting or Assigned(OnMove) or Assigned(Self.OnMoveBy) or Assigned(OnResize) or Assigned(OnResizeBy))) or (IsEqualGUID(iid, IID_IAuthenticate) and Assigned(OnAuthenticate)) then Result := QueryInterface(iid, Obj) = S_OK else Result := False; end; function TCustomEmbeddedWB.QueryService(const rsid, iid: TGUID; out Obj): HRESULT; begin Pointer(Obj) := nil; if (not DoQueryService(rsid, iid, Obj)) and Assigned(FOnQueryService) then FOnQueryService(Self, rsid, iid, IUnknown(obj)); if Pointer(Obj) <> nil then Result := S_OK else Result := E_NOINTERFACE; end; function TCustomEmbeddedWB.ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL): HRESULT; begin if Assigned(FOnResizeBorder) then FOnResizeBorder(Self, prcBorder, pUIWindow, fRameWindow); Result := S_OK; end; procedure TCustomEmbeddedWB.MoveParentForm(x, y: Integer; Delta: Boolean); var F: TCustomForm; begin F := GetParentForm(Self); if F <> nil then begin if Delta then begin x := F.Left + x; y := F.Top + y; end; //FIXME defend from moving outside of screen (don't forget multimonitor) F.SetBounds(x, y, F.Width, F.Height); end; end; procedure TCustomEmbeddedWB.ResizeParentForm(w, h: Integer; Delta: Boolean); var F: TCustomForm; begin F := GetParentForm(Self); if F <> nil then begin if Delta then begin w := F.Width + w; h := F.Height + h; end; F.SetBounds(F.Left, F.Top, w, h); end; end; function TCustomEmbeddedWB.ResizeBy(const x, y: Integer): HRESULT; begin if FloatingHosting then ResizeParentForm(x, y, True); if Assigned(OnResizeBy) then OnResizeBy(Self, x, y); Result := S_OK; // always return success to prevent script error messages end; function TCustomEmbeddedWB.ResizeTo(const x, y: Integer): HRESULT; begin if FloatingHosting then ResizeParentForm(x, y, False); if Assigned(OnResize) then OnResize(self, x, y); Result := S_OK; // always return success to prevent script error messages end; function TCustomEmbeddedWB.MoveBy(const x, y: Integer): HRESULT; begin if FloatingHosting then MoveParentForm(x, y, True); if Assigned(OnMoveBy) then OnMoveBy(self, x, y); Result := S_OK; // always return success to prevent script error messages end; function TCustomEmbeddedWB.MoveTo(const x, y: Integer): HRESULT; begin if FloatingHosting then MoveParentForm(x, y, False); if Assigned(OnMove) then OnMove(self, x, y); Result := S_OK; // always return success to prevent script error messages end; function TCustomEmbeddedWB.OnZoomPercentChanged(const ulZoomPercent: uLong): HRESULT; begin if Assigned(FOnZoomPercentChanged) then Result := FOnZoomPercentChanged(Self, ulZoomPercent) else Result := S_FALSE; end; function TCustomEmbeddedWB.GetElemByID(const ID: WideString): IHTMLElement; var Doc3: IHTMLDocument3; begin if Supports(Document, IHTMLDocument3, Doc3) then Result := Doc3.getElementById(ID) else Result := nil; end; function TCustomEmbeddedWB.ScrollToElement(Element: IHTMLElement): Boolean; var RV: IHTMLRect; begin Result := Element <> nil; if Result then begin RV := (Element as IHTMLElement2).getBoundingClientRect; Doc2.parentWindow.scrollBy(RV.left, RV.top); end; end; function TCustomEmbeddedWB.GetCharSet: WideString; begin Result := Doc2.charset; end; procedure TCustomEmbeddedWB.SetCharSet(const Value: WideString); var Level: OleVariant; begin Doc2.charset := Value; Level := 7; DefaultInterface.Refresh2(Level); end; procedure TCustomEmbeddedWB.SetDesignMode(const Value: Boolean); var Control: IOleControl; begin FDesignMode := Value; if DefaultInterface.QueryInterface(IOleControl, Control) = 0 then with (Application as IOleControl) do begin OnAmbientPropertyChange(DISPID_AMBIENT_USERMODE); _Release; end; end; const _DesignModeValues: array[TDocDesignMode] of string = ('On', 'Off', 'Inherit', ''); function TCustomEmbeddedWB.GetDocDesignMode: TDocDesignMode; var D: IHTMLDocument2; I: Integer; begin Result := ddmUnknown; if Supports(Document, IHTMLDocument2, D) then begin I := AnsiIndexStr(D.designMode, _DesignModeValues); if I in [0..2] then Result := TDocDesignMode(I); end; end; procedure TCustomEmbeddedWB.SetDocDesignMode(const Value: TDocDesignMode); var D: IHTMLDocument2; begin if (Value <> ddmUnknown) and Supports(Document, IHTMLDocument2, D) then D.designMode := _DesignModeValues[Value]; end; procedure TCustomEmbeddedWB.SetDownloadOptions(const Value: TDownloadControlOptions); begin FDownloadControlOptions := Value; UpdateDownloadControlValues; with (Application as IOleControl) do begin OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); _Release; end; end; procedure TCustomEmbeddedWB.SetFocusToBody; var bodyElement: IHTMLElement2; HTMLDoc2: IHTMLDocument2; begin HTMLDoc2 := GetDoc2; if Assigned(HTMLDoc2) then begin bodyElement := HTMLDoc2.body as IHTMLElement2; if Assigned(bodyElement) then bodyElement.focus; end; end; procedure TCustomEmbeddedWB.SetFocusToDoc; var bCanGrabFocus: Boolean; ParentForm: TCustomForm; begin if Document <> nil then begin bCanGrabFocus := CanGrabFocus; CanGrabFocus := True; with (Application as IOleObject) do begin if DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0, Handle, GetClientRect) = S_OK then begin ParentForm := GetParentForm(Self); if Assigned(ParentForm) and Self.CanFocus then ParentForm.ActiveControl := Self; end; end; CanGrabFocus := bCanGrabFocus; end; end; procedure TCustomEmbeddedWB.SetFocusToParent; begin {if IsWindow(WindowHandle) then begin Windows.SetParent(WindowHandle, Parent.Handle); MoveWindow(WindowHandle, 0, 0, Parent.Width, Parent.Height, True); Parent.SetFocus; end;} if IsWindow(WindowHandle) then begin Windows.SetParent(WindowHandle, TWinControl(Self).Parent.Handle); MoveWindow(WindowHandle, 0, 0, TWinControl(Self).Parent.Width, TWinControl(Self).Parent.Height, True); TWinControl(Self).Parent.SetFocus; end; end; procedure TCustomEmbeddedWB.SetUserInterfaceOptions(const Value: TUserInterfaceOptions); begin FUserInterfaceOptions := Value; UpdateUserInterfaceValues; with (Application as IOleControl) do begin OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); _Release; end; end; procedure TCustomEmbeddedWB.SetDropHandlingType(const Value: TDragDropHandlingType); var innerWnd: LongWord; Impl: IDropTarget; begin if FDropHandlingType <> Value then begin FDropHandlingType := Value; if HandleAllocated then innerWnd := GetIEWin('Internet Explorer_Server') else innerWnd := 0; if innerWnd <> 0 then RevokeDragDrop(innerWnd); Impl := nil; case Value of ddtMS: DefaultInterface.RegisterAsDropTarget := True; ddtMy: Impl := Self; ddtCustom: if innerWnd <> 0 then begin Impl := Self; if Assigned(FOnGetDropTarget) then FOnGetDropTarget(Self, Impl); end; ddtNo: DefaultInterface.RegisterAsDropTarget := False; end; if (innerWnd <> 0) and (Impl <> nil) then RegisterDragDrop(innerWnd, Impl); end; end; function TCustomEmbeddedWB.GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; begin Result := S_OK; case DropHandlingType of ddtMS: begin DefaultInterface.RegisterAsDropTarget := True; Result := E_NOTIMPL; end; ddtMy: ppDropTarget := Self; ddtCustom: begin ppDropTarget := Self; if Assigned(FOnGetDropTarget) then FOnGetDropTarget(Self, ppDropTarget); end; ddtNo: begin DefaultInterface.RegisterAsDropTarget := False; ppDropTarget := nil; end; end; end; function TCustomEmbeddedWB.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; begin Result := NOERROR; dwEffect := DROPEFFECT_NONE; if Assigned(OnDragEnter) then OnDragEnter(Self, dataObj, grfKeyState, pt, dwEffect, Result); end; function TCustomEmbeddedWB.DragLeave: HRESULT; begin Result := NOERROR; if Assigned(OnDragLeave) then OnDragLeave(Self); end; function TCustomEmbeddedWB.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; begin Result := NOERROR; dwEffect := DROPEFFECT_NONE; if Assigned(FOnDropEvent) then FOnDropEvent(Self, dataObj, grfKeyState, pt, dwEffect, Result); end; function TCustomEmbeddedWB.DropTargetDragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HRESULT; begin Result := NOERROR; dwEffect := DROPEFFECT_NONE; if Assigned(FOnDragOverEvent) then FOnDragOverEvent(Self, grfKeyState, pt, dwEffect, Result); end; function TCustomEmbeddedWB.Download(pmk: IMoniker; pbc: IBindCtx; dwBindVerb, grfBINDF: DWORD; pBindInfo: PBindInfo; pszHeaders, pszRedir: PWidechar; uiCP: UINT): HRESULT; begin Result := E_NOTIMPL; if Assigned(FOnDownload) then FOnDownload(Self, pmk, pbc, dwBindVerb, grfBINDF, pBindInfo, pszHeaders, pszRedir, uiCP, Result); end; function TCustomEmbeddedWB.FilterPopupMenu: Boolean; begin Result := Assigned(OnFilterPopupMenu); end; procedure TCustomEmbeddedWB.DoFilterPopupMenu(Sender: TObject; ID: DWORD; Menu: HMENU; const Context: IDispatch); begin if Assigned(OnFilterPopupMenu) then OnFilterPopupMenu(Sender, ID, Menu, Context); end; function TCustomEmbeddedWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const CommandTarget: IUnknown; const Context: IDispatch): HRESULT; var EncodingSubMenu: OleVariant; begin Result := E_NOTIMPL; if Assigned(FOnShowContextMenu) then FOnShowContextMenu(Self, dwID, ppt, CommandTarget, Context, Result); if Result = E_NOTIMPL then begin if IsSeTIEPopupMenus(dwID, DisabledPopupMenus) then begin Result := S_OK; if Assigned(PopUpMenu) then // Show assigned TPopupMenu PopUpMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y); end else if FilterPopupMenu then begin ExecWB(CGetMimeSubMenuCommandID, OLECMDEXECOPT_DODEFAULT, EncodingSubMenu); if ShowRightClickMenu(Self, dwID, CommandTarget, Context, ppt, EncodingSubMenu, DoFilterPopupMenu) then Result := S_OK else Result := S_FALSE; end else Result := S_FALSE; end; end; function TCustomEmbeddedWB.ShowHelp(HWND: THandle; pszHelpFile: POleStr; uCommand, dwData: Integer; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT; begin if Assigned(FOnShowHelp) then Result := FOnShowHelp(Self, HWND, pszHelpFile, uCommand, dwData, ptMouse, pDispatchObjectHit) else if (pszHelpFile = nil) and (HelpFile <> '') then begin HtmlHelp(HWND, PChar(HelpFile), uCommand, dwData); Result := S_OK; end else Result := S_FALSE; end; function TCustomEmbeddedWB.ShowMessage(HWND: THandle; lpstrText, lpstrCaption: POleStr; dwType: Integer; lpstrHelpFile: POleStr; dwHelpContext: Integer; var plResult: LRESULT): HRESULT; begin if Assigned(FOnShowMessage) then Result := FOnShowMessage(Self, HWND, lpstrText, lpStrCaption, dwType, lpStrHelpFile, dwHelpContext, plResult) else Result := S_FALSE; end; function TCustomEmbeddedWB.ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; begin Result := S_FALSE; if Assigned(FOnShowUI) then FOnShowUI(Self, dwID, pActiveObject, pCommandTarget, pFrame, pDoc, Result); end; function TCustomEmbeddedWB.DoFilterMsg(const lpMsg: PMSG): Boolean; type PWMKey = ^TWMKey; var ShiftState: TShiftState; begin { Result := (FDisableCtrlShortcuts <> '') and (lpMsg^.message = WM_KEYDOWN) and (((GetKeyState(VK_LCONTROL) < 0) and (GetKeyState(VK_MENU) >= 0)) or ((GetKeyState(VK_RCONTROL) < 0) and (GetKeyState(VK_LMENU) >= 0))) and (_CharPos(Char(lpMsg.wParam), FDisableCtrlShortcuts) > 0); } ShiftState := KeyDataToShiftState(PWMKey(lpMsg)^.KeyData); Result := (FDisableCtrlShortcuts <> '') and (lpMsg^.message = WM_KEYDOWN) and ((ShiftState = [ssCtrl]) and (ShiftState <> [ssAlt])) and (_CharPos(Char(lpMsg.wParam), FDisableCtrlShortcuts) > 0); if Result and Assigned(OnMaskedCtrlChar) then OnMaskedCtrlChar(Self, Char(lpMsg.wParam)); end; function TCustomEmbeddedWB.TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; { Called by MSHTML when IOleInPlaceActiveObject.TranslateAccelerator or IOleControlSite.TranslateAccelerator is called } var Filtered: Boolean; begin Filtered := DoFilterMsg(lpMsg); if (not Filtered) and Assigned(FOnTranslateAccelerator) then FOnTranslateAccelerator(Self, lpMsg, pguidCmdGroup, nCmdID, Filtered); if Filtered then Result := S_OK else Result := S_FALSE; end; function TCustomEmbeddedWB.TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POleStr; out ppchURLOut: POleStr): HRESULT; var URLOut: WideString; begin URLOut := ''; if Assigned(FOnTranslateUrl) then FOnTranslateUrl(Self, pchUrlIn, URLOut); if URLOut <> '' then begin Result := S_OK; ppchURLOut := WideStringToLPOLESTR(URLOut); end else Result := S_FALSE; end; function TCustomEmbeddedWB.UpdateUI: HRESULT; begin Result := S_FALSE; if Assigned(FOnUpdateUI) then FOnUpdateUI(Self, Result); end; procedure TCustomEmbeddedWB.UpdateUserInterfaceValues; const acardUserInterfaceValues: array[TUserInterfaceOption] of Cardinal = ($00000001, $00000002, $00000004, $00000008, $00000010, $00000020, $00000040, $00000080, $00000100, $00000200, $00000400, $00000800, $00001000, $00002000, $00004000, $00010000, $00020000, $00040000, $00080000, $00100000, $00200000, $00400000, $00800000, $01000000, $02000000, $04000000, $08000000, $10000000, $20000000); var uio: TUserInterfaceOption; begin FUserInterfaceValue := 0; if (FUserInterfaceOptions <> []) then for uio := Low(TUserInterfaceOption) to High(TUserInterfaceOption) do if (uio in FUserInterfaceOptions) then Inc(FUserInterfaceValue, acardUserInterfaceValues[uio]); end; procedure TCustomEmbeddedWB.UpdateDownloadControlValues; const acardDownloadControlValues: array[TDownloadControlOption] of Cardinal = ($00000010, $00000020, $00000040, $00000080, $00000100, $00000200, $00000400, $00000800, $00001000, $00002000, $00004000, $00008000, $00010000, $00020000, $00040000, $10000000, $20000000, $40000000, $80000000); var dco: TDownloadControlOption; begin FDownloadOptionValue := 0; if (FDownloadControlOptions <> []) then for dco := Low(TDownloadControlOption) to High(TDownloadControlOption) do if (dco in FDownloadControlOptions) then Inc(FDownloadOptionValue, acardDownloadControlValues[dco]); end; function TCustomEmbeddedWB.ZoomRangeHigh: Integer; var vaIn, vaOut: OleVariant; begin InvokeCommand(nil, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); Result := HiWord(DWORD(vaOut)); end; function TCustomEmbeddedWB.ZoomRangeLow: Integer; var vaIn, vaOut: OleVariant; begin InvokeCommand(nil, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); Result := LoWord(DWORD(vaOut)); end; function TCustomEmbeddedWB._getCookie: WideString; var D: IHTMLDocument2; begin if Supports(Document, IHTMLDocument2, D) then Result := OleObject.Document.Cookie else Result := ''; end; procedure TCustomEmbeddedWB.Client2HostWin(var CX, CY: Integer); var F: TCustomForm; begin F := GetParentForm(Self); if F <> nil then begin Inc(CX, F.ClientWidth - Self.Width); Inc(CY, F.ClientHeight - Self.Height); end; end; {$IFDEF USE_IOLECOMMANDTARGET} //======IOleCommandTarget interface ============================================ function TCustomEmbeddedWB.CommandTarget_QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; begin Result := S_OK; end; function TCustomEmbeddedWB.CommandTarget_Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; var tmpCancel: Boolean; const {$J+} LastTickEvent: Cardinal = 0; {$J-} begin Result := OLECMDERR_E_NOTSUPPORTED; if CmdGroup <> nil then begin if IsEqualGuid(cmdGroup^, CGID_EXPLORER) then begin case nCmdID of OLECMDID_ONUNLOAD: if Assigned(FOnUnload) then begin FOnUnload(Self); Result := S_OK; Exit; end; OLECMDID_PREREFRESH: begin if Assigned(FOnPreRefresh) then begin if GetTickCount - LastTickEvent > 150 then begin LastTickEvent := GetTickCount; FOnPreRefresh(Self); end; end; if Assigned(FOnHookChildWindow) then if (GetIEWin('Internet Explorer_Server') <> 0) or (GetIEWin('SysListView32') <> 0) then FOnHookChildWindow(Self); end; end end else if IsEqualGuid(cmdGroup^, CGID_DocHostCommandHandler) then begin case nCmdID of ID_IE_F5_REFRESH {nCmdID 6041, F5}, ID_IE_CONTEXTMENU_REFRESH {nCmdID 6042, Refresh by ContextMenu}, IDM_REFRESH {nCmdID 2300}: begin if Assigned(FOnRefresh) then begin tmpCancel := False; FOnRefresh(Self, nCmdID, tmpCancel); if tmpCancel then Result := S_OK; //FIXME is it true? Why not OLECMDERR_E_CANCELED end; Exit; end; OLECMDID_SHOWSCRIPTERROR: begin Result := ScriptErrorHandler(vaIn, vaOut); Exit; end; end; end; end; if Assigned(OnCommandExec) then Self.OnCommandExec(Self, CmdGroup, nCmdID, nCmdexecopt, vaIn, vaOut, Result); end; {$ENDIF} function TCustomEmbeddedWB.ScriptErrorHandler(const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; var EventObject: IHTMLEventObj; CurWindow: IHTMLWindow2; CurDocument: IHTMLDocument2; CurUnknown: IUnknown; function GetProperty(const PropName: WideString): OleVariant; var DispParams: TDispParams; Disp, Status: Integer; ExcepInfo: TExcepInfo; PPropName: PWideChar; begin DispParams.rgvarg := nil; DispParams.rgdispidNamedArgs := nil; DispParams.cArgs := 0; DispParams.cNamedArgs := 0; PPropName := PWideChar(PropName); Status := EventObject.GetIDsOfNames(GUID_NULL, @PPropName, 1, LOCALE_SYSTEM_DEFAULT, @Disp); if Status = 0 then begin Status := EventObject.Invoke(disp, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, DispParams, @Result, @ExcepInfo, nil); if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); end else if Status = DISP_E_UNKNOWNNAME then raise EOleError.CreateFmt('''%s'' is not supported.', [PropName]) else OleCheck(Status); end; begin Result := S_OK; case FScriptErrorAction of eaAskUser: Result := S_FALSE; //E_FAIL; eaContinue: vaOut := True; eaCancel: vaOut := False; end; if Assigned(FOnScriptError) then begin CurUnknown := IUnknown(TVarData(vaIn).VUnknown); if Succeeded(CurUnknown.QueryInterface(IID_IHTMLDocument2, CurDocument)) then begin CurWindow := CurDocument.Get_parentWindow; CurDocument := nil; if Assigned(CurWindow) then begin EventObject := CurWindow.Get_event; if EventObject <> nil then begin FOnScriptError(Self, GetProperty('errorline'), GetProperty('errorCharacter'), GetProperty('errorCode'), GetProperty('errorMessage'), GetProperty('errorUrl'), FScriptErrorAction); end; end; end; end; end; function TCustomEmbeddedWB.PopulateNamespaceTable: HRESULT; begin Result := S_OK; if Assigned(fOnPopulateNSTable) then FOnPopulateNSTable(Self); end; function TCustomEmbeddedWB.GetElementNamespaceTable( out aTable: IElementNamespaceTable): Boolean; var SP: IServiceProvider; begin Result := Supports(Self.Document, IServiceProvider, SP) and (SP.QueryService(IID_IElementNamespaceTable, IID_IElementNamespaceTable, aTable) = S_OK); end; function WideStringToLPOLESTR(const Src: WideString): POLEStr; begin Result := CoTaskMemAlloc((Length(Src) + 1) * SizeOf(WideChar)); if Result <> nil then Move(PWideChar(Src)^, Result^, (Length(Src) + 1) * SizeOf(WideChar)); end; function TCustomEmbeddedWB.Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR): HRESULT; var aUser, aPwd: WideString; begin Result := S_OK; hwnd := Self.Handle; aUser := ''; aPwd := ''; if Assigned(OnAuthenticate) then OnAuthenticate(Self, hwnd, aUser, aPwd, Result); if aUser <> '' then szUserName := WideStringToLPOLESTR(aUser) else szUserName := nil; if aPwd <> '' then szPassWord := WideStringToLPOLESTR(aPwd) else szPassWord := nil; end; { TEwbCore } function TEwbCore.IsCtrlCharMask: Boolean; begin Result := FDisableCtrlShortcuts <> 'N'; end; end.