source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EwbCore.pas@ 541

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

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 68.6 KB
Line 
1//*************************************************************
2// TEwbCore *
3// *
4// Freeware Component *
5// For Delphi *
6// by *
7// Per Lindso Larsen *
8// Developing Team: *
9// Eran Bodankin (bsalsa) -(bsalsa@gmail.com) *
10// Serge Voloshenyuk (SergeV@bsalsa.com) *
11// Thomas Stutz (smot777@yahoo.com *
12// *
13// Documentation and updated versions: *
14// *
15// http://www.bsalsa.com *
16//*************************************************************
17{LICENSE:
18THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
19EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
20WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
21YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
22AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
23AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
24OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
25OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
26INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
27OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
28AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
29DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
30
31You may use/change/modify the component under 4 conditions:
321. In your web site, add a link to "http://www.bsalsa.com"
332. In your application, add credits to "Embedded Web Browser"
343. Mail me (bsalsa@gmail.com) any code change in the unit for the benefit
35 of the other users.
364. Please, consider donation in our web site!
37{*******************************************************************************}
38
39
40unit EwbCore;
41
42interface
43
44{$I EWB.inc}
45
46uses
47{$IFDEF DELPHI6_UP}Variants, {$ENDIF}
48 Dialogs, Windows, Messages, Classes, MSHTML_EWB, EWBAcc, Controls, Forms,
49 ExtCtrls, ActiveX, ShlObj, SHDocVw_EWB, UrlMon, IEConst;
50
51type
52 TCustomEmbeddedWB = class;
53
54 TOleCmdArray = array of TOleCmd;
55 TDragDropHandlingType = (
56 ddtMS, // Microsoft implementation
57 ddtMy, // TCustomEmbeddedWB event handlers
58 ddtCustom, // granted by user in OnGetDropTarget event handler
59 ddtNo // No drag and drop
60 );
61 TDocDesignMode = (ddmOn, ddmOff, ddmInherit, ddmUnknown);
62
63 TIEPopupMenu = (
64 rcmDefault,
65 rcmImage,
66 rcmControl,
67 rcmTable,
68 rcmSelText,
69 rcmAnchor,
70 rcmUnKnown,
71 rcmImageArt,
72 rcmImgDynSrc,
73 rcmDebug,
74 rcmAll
75 );
76 TIEPopupMenus = set of TIEPopupMenu;
77
78 TIEPopupMenuItem = (
79 rcsBack,
80 rcsForward,
81 rcsSavePageBkg,
82 rcsSetAsBkg,
83 rcsCopyBkg,
84 rcsSetAsDeskT,
85 rcsSelectAll,
86 rcsPaste,
87 rcsCreateSC,
88 rcsAddToFav,
89 rcsEncoding,
90 rcsRefresh,
91 rcsViewSource,
92 rcsProperties,
93 rcsPrint,
94 rcsOpenNWindow,
95 rcsOpenLink
96 );
97 TIEPopupMenuItems = set of TIEPopupMenuItem;
98
99 {============================================================================}
100 { Controlling Download and Execution }
101 { http://msdn.microsoft.com/en-us/library/aa770041.aspx }
102 { TDownloadControlOption = (
103 DLCTL_DLIMAGES, DLCTL_VIDEOS, DLCTL_BGSOUNDS,
104 DLCTL_NO_SCRIPTS, DLCTL_NO_JAVA,
105 DLCTL_NO_RUNACTIVEXCTLS, DLCTL_NO_DLACTIVEXCTLS,
106 DLCTL_DOWNLOADONLY,
107 DLCTL_NO_FRAMEDOWNLOAD,
108 DLCTL_RESYNCHRONIZE,
109 DLCTL_PRAGMA_NO_CACHE,
110 DLCTL_NO_BEHAVIORS, DLCTL_NO_METACHARSET,
111 DLCTL_URL_ENCODING_DISABLE_UTF8, DLCTL_URL_ENCODING_ENABLE_UTF8,
112 DLCTL_FORCEOFFLINE, DLCTL_NO_CLIENTPULL,
113 DLCTL_SILENT, DLCTL_OFFLINE);
114 }
115 TDownloadControlOption = (
116 DownloadImages, DownloadVideos, DownloadBGSounds, DontExecuteScripts,
117 DontExecuteJava, DontExecuteActiveX, DontDownloadActiveX,
118 DownloadButDontDisplay, DontDownloadFrame, CheckPageResynchronize,
119 DownloadAndIgnoreCache, DontDownloadBehaviors, SuppressedMetaCharset,
120 DisableUrlIfEncodingUTF8, EnableUrlIfEncodingUTF8,
121 ForceOfflineMode, DontPerformClientPull, DownloadInSilentMode, WorkOffline);
122 TDownloadControlOptions = set of TDownloadControlOption;
123
124 { Doc Host Flags:
125 http://msdn.microsoft.com/en-us/library/aa753277.aspx }
126 { TUserInterfaceOption = (DIALOG, DISABLE_HELP_MENU, NO3DBORDER,
127 SCROLL_NO, DISABLE_SCRIPT_INACTIVE, OPENNEWWIN, DISABLE_OFFSCREEN,
128 FLAT_SCROLLBAR, DIV_BLOCKDEFAULT, ACTIVATE_CLIENTHIT_ONLY,
129 OVERRIDEBEHAVIORFACTORY,
130 CODEPAGELINKEDFONTS, URL_ENCODING_DISABLE_UTF8,
131 URL_ENCODING_ENABLE_UTF8,
132 ENABLE_FORMS_AUTOCOMPLETE, ENABLE_INPLACE_NAVIGATION,
133 IME_ENABLE_RECONVERSION,
134 THEME, NOTHEME, NOPICS, NO3DOUTERBORDER, DISABLE_EDIT_NS_FIXUP,
135 LOCAL_MACHINE_ACCESS_CHECK, DISABLE_UNTRUSTEDPROTOCOL,
136 HOST_NAVIGATES, ENABLE_REDIRECT_NOTIFICATION, USE_WINDOWLESS_SELECTCONTROL,
137 USE_WINDOWED_SELECTCONTROL, ENABLE_ACTIVEX_INACTIVATE_MODE);
138 }
139 TUserInterfaceOption = (DisableTextSelect, DisableHelpMenu, DontUse3DBorders,
140 DontUseScrollBars, PostponeScriptUntilActive, ForceOpenNewWindow,
141 Reserved_OFFSCREEN,
142 ForceFlatScrollBars, InsertDivTagOnEditMode, ActivateUIOnlyOnDocClick,
143 ConsultBeforeRetrievingBehavior,
144 CheckFontSupportsCodePage, DisableSubmitUrlInUTF8,
145 EnableSubmitUrlInUTF8,
146 EnablesFormsAutoComplete, ForceSameWindowNavigation,
147 EmableImeLocalLanguages,
148 EnableThemes, DisableThemes, DisablePicsRatings, DisableFrameSetBorder,
149 DisablesAutoNameSpaceCorrection,
150 DisableLocalFileAccess, DisableUntrustedProtocol,
151 CheckNavigationDelegatedToHost, EnableRedirectNotification, EnableDomWindlessControls,
152 EnableWindowedControls, ForceUserActivationOnActiveXJava);
153 TUserInterfaceOptions = set of TUserInterfaceOption;
154
155 {events}
156 TMenuPreprocess = procedure(Sender: TObject; ID: DWORD; Menu: HMENU; const Context: IDispatch) of object;
157
158 TEWBNotifyEvent = procedure(Sender: TObject; var Rezult: HRESULT) of object;
159 TBoolQueryEvent = procedure(Sender: TObject; var Value: BOOL) of object;
160 TMaskedCtrlCharEvent = procedure(Sender: TCustomEmbeddedWB; MaskedChar: Char) of object;
161 TOMWindowMoveEvent = procedure(Sender: TCustomEmbeddedWB; cx, cy: Integer) of object;
162
163 {IDocHostShowUI Interface}
164 TShowHelpEvent = function(Sender: TObject; HWND: THandle; pszHelpFile: POleStr; uCommand: Integer;
165 dwData: Longint; ptMouse: TPoint;
166 var pDispatchObjectHit: IDispatch): HRESULT of object;
167 TShowMessageEvent = function(Sender: TObject; HWND: THandle;
168 lpstrText: POleStr; lpstrCaption: POleStr; dwType: Longint; lpstrHelpFile: POleStr;
169 dwHelpContext: Longint; var plResult: LRESULT): HRESULT of object;
170 {IDocHostUIHandler Interface}
171 TEnableModelessEvent = procedure(Sender: TCustomEmbeddedWB; const fEnable: BOOL) of object;
172 TFilterDataObjectEvent = procedure(Sender: TCustomEmbeddedWB; const pDO: IDataObject;
173 var ppDORet: IDataObject) of object;
174 TGetDropTargetEvent = procedure(Sender: TCustomEmbeddedWB; var DropTarget: IDropTarget) of object;
175 TGetExternalEvent = procedure(Sender: TCustomEmbeddedWB; var ppDispatch: IDispatch) of object;
176 TGetHostInfoEvent = procedure(Sender: TCustomEmbeddedWB; var pInfo: TDOCHOSTUIINFO) of object;
177 TGetOptionKeyPathEvent = procedure(Sender: TCustomEmbeddedWB; var pchKey: POleStr) of object;
178 TOnActivateEvent = procedure(Sender: TCustomEmbeddedWB; const fActivate: BOOL) of object;
179 TResizeBorderEvent = procedure(Sender: TCustomEmbeddedWB; const prcBorder: PRect;
180 const pUIWindow: IOleInPlaceUIWindow;
181 const fRameWindow: BOOL) of object;
182 TShowContextMenuEvent = procedure(Sender: TCustomEmbeddedWB; const dwID: DWORD; const ppt: PPOINT;
183 const CommandTarget: IUnknown; const Context: IDispatch; var Result: HRESULT) of object;
184 TShowUIEvent = procedure(Sender: TCustomEmbeddedWB; const dwID: DWORD; const
185 pActiveObject: IOleInPlaceActiveObject;
186 const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
187 const pDoc: IOleInPlaceUIWindow; var Rezult: HRESULT) of object;
188 TTranslateAcceleratorEvent = procedure(Sender: TCustomEmbeddedWB; const lpMsg: PMSG;
189 const pguidCmdGroup: PGUID;
190 const nCmdID: DWORD; var Done: Boolean) of object;
191 TTranslateUrlEvent = procedure(Sender: TCustomEmbeddedWB; const pchURLIn: POleStr;
192 var ppchURLOut: WideString) of object;
193
194{$IFDEF USE_IOLECOMMANDTARGET}
195 TRefreshEvent = procedure(Sender: TCustomEmbeddedWB; CmdID: Integer; var Cancel: Boolean) of object;
196{$ENDIF}
197 {INewWindowManager Interface}
198 TEvaluateNewWindowEvent = procedure(Sender: TCustomEmbeddedWB; pszUrl, pszName,
199 pszUrlContext, pszFeatures: LPCWSTR;
200 fReplace: BOOL; dwFlags, dwUserActionTime: DWORD; var Rezult: HRESULT) of object;
201 {IDownloadManager Interface}
202 TDownloadEvent = procedure(Sender: TCustomEmbeddedWB; pmk: IMoniker; pbc: IBindCtx;
203 dwBindVerb: DWORD;
204 grfBINDF: DWORD; pBindInfo: PBindInfo; pszHeaders: PWideChar;
205 pszRedir: PWidechar; uiCP: UINT; var Rezult: HRESULT) of object;
206 {IAuthenticate Interface}
207 TAuthenticateEvent = procedure(Sender: TCustomEmbeddedWB; var hwnd: HWnd;
208 var szUserName, szPassWord: WideString; var Rezult: HRESULT) of object;
209 {IZoomEvents Interface}
210 TZoomPercentChangedEvent = function(Sender: TCustomEmbeddedWB; const ulZoomPercent: uLong): HRESULT of object;
211 {Script Error handling}
212 TScriptErrorAction = (eaContinue, eaCancel, eaAskUser);
213 TScriptErrorEvent = procedure(Sender: TObject; ErrorLine, ErrorCharacter, ErrorCode, ErrorMessage, ErrorUrl: string;
214 var ScriptErrorAction: TScriptErrorAction) of object;
215
216 {User Agent Mode Event}
217 TSetUserAgentEvent = function(var UserAgent: string): HRESULT of object;
218
219 { TCustomEmbeddedWB }
220 TCustomEmbeddedWB = class(TEWB
221 , IDispatch // http://msdn.microsoft.com/en-us/library/ms221608.aspx
222 , IDocHostShowUI // http://msdn.microsoft.com/en-us/library/aa753269.aspx
223 , IDocHostUIHandler // http://msdn.microsoft.com/en-us/library/aa753260(VS.85).aspx
224 , IDocHostUIHandler2 // http://msdn.microsoft.com/en-us/library/aa753275(VS.85).aspx
225 , IDropTarget // http://msdn.microsoft.com/en-us/library/ms679679.aspx
226{$IFDEF USE_IOLECOMMANDTARGET}
227 , IOleCommandTarget // http://msdn.microsoft.com/en-us/library/ms683797.aspx
228{$ENDIF}
229 , IServiceProvider // http://msdn.microsoft.com/en-us/library/cc678965(VS.85).aspx
230 , INewWindowManager // http://msdn.microsoft.com/en-us/library/bb775418(VS.85).aspx
231 , IProtectFocus // http://msdn2.microsoft.com/en-us/library/aa361771.aspx
232 , IDownloadManager // http://msdn.microsoft.com/en-us/library/aa753613(VS.85).aspx
233 , IHTMLOMWindowServices //http://msdn.microsoft.com/library/default.asp?url=/workshop/browser/hosting/reference/ifaces/IHTMLOMWindowServices/IHTMLOMWindowServices.asp
234 , IHostBehaviorInit // http://msdn.microsoft.com/en-us/library/aa753687(VS.85).aspx
235 , IZoomEvents // http://msdn.microsoft.com/en-us/library/aa770056(VS.85).aspx
236 , IAuthenticate // http://msdn.microsoft.com/en-us/library/ms835407.aspx
237 )
238
239 private
240 FOnZoomPercentChanged: TZoomPercentChangedEvent;
241 FOnGetIDsOfNames: TGetIDsOfNamesEvent;
242 FOnGetTypeInfo: TGetTypeInfoEvent;
243 FOnGetTypeInfoCount: TGetTypeInfoCountEvent;
244 FOnInvoke: TInvokeEvent;
245 FDownloadControlOptions: TDownloadControlOptions;
246 FOnShowMessage: TShowMessageEvent;
247 FOnShowHelp: TShowHelpEvent;
248 FHelpFile: string;
249 fOptionKeyPath: string;
250 fOverOptionKeyPath: Boolean;
251 FOnFilterDataObject: TFilterDataObjectEvent;
252 FOnGetExternal: TGetExternalEvent;
253 FOnGetHostInfo: TGetHostInfoEvent;
254 FUserInterfaceOptions: TUserInterfaceOptions;
255 FOnEnableModeless: TEnableModelessEvent;
256{$IFDEF GETKEYPATH_HANDLERS}
257 FOnGetOptionKeyPath: TGetOptionKeyPathEvent;
258 FOnGetOverrideKeyPath: TGetOptionKeyPathEvent;
259{$ENDIF}
260 FOnGetDropTarget: TGetDropTargetEvent;
261 FOnHideUI: TEWBNotifyEvent;
262 FOnOnDocWindowActivate: TOnActivateEvent;
263 FOnOnFrameWindowActivate: TOnActivateEvent;
264 FOnResizeBorder: TResizeBorderEvent;
265 FOnShowContextmenu: TShowContextMenuEvent;
266 FOnShowUI: TShowUIEvent;
267 FOnTranslateAccelerator: TTranslateAcceleratorEvent;
268 FOnTranslateUrL: TTranslateUrlEvent;
269 FOnUpdateUI: TEWBNotifyEvent;
270 FOnDragLeaveEvent: TNotifyEvent;
271 FOnDragEnterEvent: TOnDragEnterEvent;
272 FOnDragOverEvent: TOnDragOverEvent;
273 FOnDropEvent: TOnDropEvent;
274 FOnScriptError: TScriptErrorEvent;
275 FScriptErrorAction: TScriptErrorAction;
276{$IFDEF USE_IOLECOMMANDTARGET}
277 FOnUnload: TNotifyEvent;
278 FOnRefresh: TRefreshEvent;
279 FOnCommandExec: TComTargetExecEvent;
280{$ENDIF}
281 FOnQueryService: TQueryServiceEvent;
282 FOnEvaluateNewWindow: TEvaluateNewWindowEvent;
283 FCanGrabFocus: Boolean;
284 FOnAllowFocusChange: TBoolQueryEvent;
285 FOnDownload: TDownloadEvent;
286 FDropHandlingType: TDragDropHandlingType;
287 FZoomPercent: Integer;
288 FDesignMode: Boolean;
289 FDisabledPopupMenus: TIEPopupMenus;
290 FOnFilterPopupMenu: TMenuPreprocess;
291 FOnMaskedCtrlChar: TMaskedCtrlCharEvent;
292 FDisableCtrlShortcuts: string;
293 FOnResize: TOMWindowMoveEvent;
294 FOnMoveBy: TOMWindowMoveEvent;
295 FOnMove: TOMWindowMoveEvent;
296 FOnResizeBy: TOMWindowMoveEvent;
297 FFloatingHosting: Boolean;
298 FOnPopulateNSTable: TNotifyEvent;
299 FOnAuthenticate: TAuthenticateEvent;
300{$IFDEF RESEARCH_MODE}
301 FOnQueryInterface: OnQueryInterfaceEvent;
302{$ENDIF}
303 procedure SetDownloadOptions(const Value: TDownloadControlOptions);
304 procedure SetUserInterfaceOptions(const Value: TUserInterfaceOptions);
305 function GetDoc2: IHtmlDocument2;
306 function GetDoc3: IHtmlDocument3;
307 function GetDoc4: IHtmlDocument4;
308 function GetDoc5: IHtmlDocument5;
309 function GetElemByID(const ID: WideString): IHTMLElement;
310 function GetZoom: Integer;
311 procedure SetZoom(const Value: Integer);
312 procedure setOpticalZoom(const Value: Integer);
313 function _getCookie: WideString;
314 function GetCharSet: WideString;
315 procedure SetCharSet(const Value: WideString);
316 procedure SetDropHandlingType(const Value: TDragDropHandlingType);
317 procedure SetDesignMode(const Value: Boolean);
318 function GetDocDesignMode: TDocDesignMode;
319 procedure SetDocDesignMode(const Value: TDocDesignMode);
320 function GetBody: IHTMLElement;
321
322 protected
323 CurrentHandle: HWND; //jls
324 procedure CreateWnd; override; //jls
325 procedure DestroyWnd; override; //jls
326 protected
327{$IFDEF RESEARCH_MODE}
328 { IInterface }
329 function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall;
330{$ENDIF}
331 {IDispatch Interface}
332 function GetIDsOfNames(const IID: TGUID; Names: Pointer;
333 NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
334 function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT;
335 stdcall;
336 function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
337 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
338 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
339 stdcall;
340 {IDocHostShowUI Interface }
341 function ShowHelp(HWND: THandle; pszHelpFile: POleStr; uCommand: Integer;
342 dwData: Longint; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT; stdcall;
343 function ShowMessage(HWND: THandle; lpstrText: POleStr; lpstrCaption: POleStr;
344 dwType: Longint; lpstrHelpFile: POleStr; dwHelpContext: Longint;
345 var plResult: LRESULT): HRESULT; stdcall;
346 {IDocHostUIHandler Interface}
347 function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
348 function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall;
349 function GetDropTarget(const pDropTarget: IDropTarget;
350 out ppDropTarget: IDropTarget): HRESULT; stdcall;
351 function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
352 function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
353 function GetOptionKeyPath(out pchKey: POleStr; const dw: DWORD): HRESULT; stdcall;
354 function HideUI: HRESULT; stdcall;
355 function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
356 function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
357 function ResizeBorder(const prcBorder: PRECT; const pUIWindow:
358 IOleInPlaceUIWindow;
359 const FrameWindow: BOOL): HRESULT; stdcall;
360 function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
361 const CommandTarget: IUnknown; const Context: IDispatch): HRESULT; stdcall;
362 function ShowUI(const dwID: DWORD; const pActiveObject:
363 IOleInPlaceActiveObject;
364 const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
365 const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
366 function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
367 const nCmdID: DWORD): HRESULT; stdcall;
368 function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POleStr;
369 out ppchURLOut: POleStr): HRESULT; stdcall;
370 function UpdateUI: HRESULT; stdcall;
371 {IDocHostUIHandler2 Interface}
372 function GetOverrideKeyPath(out pchKey: POleStr; dw: DWORD): HRESULT; stdcall;
373 {IDropTarget Interface}
374 function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
375 pt: TPoint; var dwEffect: Longint): HRESULT; stdcall;
376 function IDropTarget.DragOver = DropTargetDragOver;
377 function DropTargetDragOver(grfKeyState: Longint; pt: TPoint;
378 var dwEffect: Longint): HRESULT; stdcall;
379 function DragLeave: HRESULT; stdcall;
380 function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
381 var dwEffect: Longint): HRESULT; stdcall;
382{$IFDEF USE_IOLECOMMANDTARGET}
383 {IOleCommandTarget interface}
384 function IOleCommandTarget.QueryStatus = CommandTarget_QueryStatus;
385 function CommandTarget_QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
386 prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; stdcall;
387 function IOleCommandTarget.Exec = CommandTarget_Exec;
388 function CommandTarget_Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
389 const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall;
390{$ENDIF}
391 {IServiceProvider Interface}
392 function QueryService(const rsid, iid: TGUID; out Obj): HRESULT; stdcall;
393 {INewWindowManager Interface}
394 function EvaluateNewWindow(pszUrl, pszName, pszUrlContext, pszFeatures: LPCWSTR;
395 fReplace: BOOL; dwFlags, dwUserActionTime: DWORD): HRESULT; stdcall;
396 {IProtectFocus IE7 interface}
397 function AllowFocusChange(out pfAllow: BOOL): HRESULT; stdcall;
398 {IDownloadManager Interface}
399 function Download(
400 pmk: IMoniker; // Identifies the object to be downloaded
401 pbc: IBindCtx; // Stores information used by the moniker to bind
402 dwBindVerb: DWORD; // The action to be performed during the bind
403 grfBINDF: DWORD; // Determines the use of URL encoding during the bind
404 pBindInfo: PBindInfo; // Used to implement IBindStatusCallback::GetBindInfo
405 pszHeaders: PWidechar; // Additional headers to use with IHttpNegotiate
406 pszRedir: PWidechar; // The URL that the moniker is redirected to
407 uiCP: UINT // The code page of the object's display name
408 ): HRESULT; stdcall;
409 {IHostBehaviorInit}
410 function PopulateNamespaceTable: HRESULT; stdcall;
411 {IHTMLOMWindowServices Interface}
412 function ResizeBy(const x, y: Integer): HRESULT; stdcall;
413 function ResizeTo(const x, y: Integer): HRESULT; stdcall;
414 function MoveBy(const x, y: Integer): HRESULT; stdcall;
415 function MoveTo(const x, y: Integer): HRESULT; stdcall;
416 {IZoomEvents interface}
417 function OnZoomPercentChanged(const ulZoomPercent: uLong): HRESULT; stdcall;
418 {IAuthenticate}
419 function Authenticate(var hwnd: HWnd; var szUserName, szPassWord: LPWSTR):
420 HRESULT; stdcall;
421 protected
422 FDownloadOptionValue: Longint;
423 FUserInterfaceValue: Cardinal;
424 FOnSetUserAgent: TSetUserAgentEvent;
425 FOnPreRefresh: TNotifyEvent;
426 FOnHookChildWindow : TNotifyEvent;
427 procedure UpdateDownloadControlValues;
428 procedure UpdateUserInterfaceValues;
429 function CopyOptionKeyPath(Overrided: Boolean): PWideChar;
430 function DoFilterMsg(const lpMsg: PMSG): Boolean; virtual;
431 function ScriptErrorHandler(const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; virtual;
432 function DoQueryService(const rsid, iid: TGUID; var Obj): Boolean; virtual;
433 function FilterPopupMenu: Boolean; virtual;
434 procedure DoFilterPopupMenu(Sender: TObject; ID: DWORD; Menu: HMENU; const Context:
435 IDispatch); virtual;
436 procedure MoveParentForm(x, y: Integer; Delta: Boolean);
437 procedure ResizeParentForm(w, h: Integer; Delta: Boolean);
438 public
439 class function dwEffectToStr(Command: Int64): string;
440 class procedure DropEffect(grfKeyState: Longint; var dwEffect: longint);
441 constructor Create(AOwner: TComponent); override;
442 destructor Destroy; override;
443 function InvokeCommand(CmdGroup: PGUID; Cmd, nCmdexecopt: DWORD;
444 var vaIn, vaOut: OleVariant): HRESULT; overload;
445 function InvokeCommand(CmdGroup: PGUID; Cmd: DWORD): HRESULT; overload;
446 function QueryCommandStatus(CmdGroup: PGUID; cCmds: Cardinal;
447 prgCmds: POleCmd; CmdText: POleCmdText): HRESULT;
448 function QueryCMDEnabled(CmdGroup: PGUID; cmdID: Cardinal): Boolean;
449 function QueryCMDLatched(CmdGroup: PGUID; cmdID: Cardinal): Boolean;
450 function QueryCMDStatus(CmdGroup: PGUID; cmdID: Cardinal): OLECMDF;
451 function QueryCMDArrayStatus(CmdGroup: PGUID; cmds: TOleCmdArray): Boolean;
452
453 procedure Client2HostWin(var CX, CY: Integer);
454 // just call it in OnClientToHostWindow handler
455
456 function GetIEWin(const ClassName: string): HWND;
457 procedure SetFocusToDoc;
458 procedure SetFocusToBody;
459 procedure SetFocusToParent;
460
461 function ZoomRangeHigh: Integer;
462 function ZoomRangeLow: Integer;
463 property Zoom: Integer read getZoom write setZoom;
464 property ZoomPercent: Integer read FZoomPercent write setOpticalZoom default 100;
465
466 property Cookie: WideString read _getCookie;
467 property DesignMode: Boolean read FDesignMode write SetDesignMode;
468 {html functions}
469 property Doc2: IHtmlDocument2 read GetDoc2;
470 property Doc3: IHtmlDocument3 read GetDoc3;
471 property Doc4: IHtmlDocument4 read GetDoc4;
472 property Doc5: IHtmlDocument5 read GetDoc5;
473
474 property Body: IHTMLElement read getBody;
475 property DocDesignMode: TDocDesignMode read getDocDesignMode write
476 setDocDesignMode;
477 property CharactersSet: WideString read GetCharSet write SetCharSet;
478 property ElementByID[const ID: WideString]: IHTMLElement read getElemByID;
479 function ScrollToElement(Element: IHTMLElement): Boolean;
480
481
482 function GetElementNamespaceTable(out aTable: IElementNamespaceTable):
483 Boolean;
484
485{$IFDEF RESEARCH_MODE}
486 property OnQueryInterface: OnQueryInterfaceEvent read fOnQueryInterface write fOnQueryInterface;
487{$ENDIF}
488 property CanGrabFocus: Boolean read FCanGrabFocus write FCanGrabFocus default True;
489 published
490 property OnAllowFocusChange: TBoolQueryEvent read FOnAllowFocusChange write
491 FOnAllowFocusChange;
492 property DisableCtrlShortcuts: string read FDisableCtrlShortcuts write FDisableCtrlShortcuts;
493 property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions
494 write SetDownloadOptions default [DownloadImages, DownloadVideos, DownloadBGSounds];
495 property UserInterfaceOptions: TUserInterfaceOptions read FUserInterfaceOptions
496 write SetUserInterfaceOptions default [];
497 property HelpFile: string read FHelpFile write FHelpFile;
498 property OptionKeyPath: string read FOptionKeyPath write FOptionKeyPath;
499 property OverrideOptionKeyPath: Boolean read FOverOptionKeyPath write
500 FOverOptionKeyPath default False;
501
502 property DropHandlingType: TDragDropHandlingType read FDropHandlingType write
503 setDropHandlingType default ddtMS;
504 property DisabledPopupMenus: TIEPopupMenus
505 read FDisabledPopupMenus write FDisabledPopupMenus default [];
506 property FloatingHosting: Boolean read FFloatingHosting write
507 fFloatingHosting default False;
508
509 property OnGetIDsOfNames: TGetIDsOfNamesEvent read FOnGetIDsOfNames write
510 FOnGetIdsOfNames;
511 property OnGetTypeInfo: TGetTypeInfoEvent read FonGetTypeInfo write
512 FOnGetTypeInfo;
513 property OnGetTypeInfoCount: TGetTypeInfoCountEvent read FonGetTypeInfoCount
514 write FOnGetTypeInfoCount;
515 property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
516 property OnShowHelpRequest: TShowHelpEvent read FOnShowHelp write
517 FOnShowHelp;
518 property OnShowMessage: TShowMessageEvent read FOnShowMessage write
519 FOnShowMessage;
520 property OnFilterDataObject: TFilterDataObjectEvent read FOnFilterDataObject
521 write FOnFilterDataObject;
522 property OnGetExternal: TGetExternalEvent read FOnGetExternal write
523 FOnGetExternal;
524 property OnGetHostInfo: TGetHostInfoEvent read FOnGetHostInfo write
525 FOnGetHostInfo;
526 property OnEnableModeless: TEnableModelessEvent read FOnEnableModeless
527 write FOnEnableModeless;
528{$IFDEF GETKEYPATH_HANDLERS}
529 property OnGetOptionKeyPath: TGetOptionKeyPathEvent read FOnGetOptionKeyPath
530 write FOnGetOptionKeyPath;
531 property OnGetOverrideKeyPath: TGetOptionKeyPathEvent read
532 FOnGetOverrideKeyPath
533 write FOnGetOverrideKeyPath;
534{$ENDIF}
535 property OnZoomPercentChange: TZoomPercentChangedEvent read FOnZoomPercentChanged write FOnZoomPercentChanged;
536 property OnGetDropTarget: TGetDropTargetEvent read FOnGetDropTarget write FOnGetDropTarget;
537 property OnHideUI: TEWBNotifyEvent read FOnHideUI write FOnHideUI;
538 property OnOnDocWindowActivate: TOnActivateEvent read FOnOnDocWindowActivate
539 write FOnOnDocWindowActivate;
540 property OnOnFrameWindowActivate: TOnActivateEvent read
541 FOnOnFrameWindowActivate
542 write FOnOnFrameWindowActivate;
543 property OnResizeBorder: TResizeBorderEvent read FOnResizeBorder write
544 FOnResizeBorder;
545 property OnShowContextMenu: TShowContextMenuEvent read FOnShowContextmenu
546 write FOnShowContextmenu;
547 property OnShowUI: TShowUIEvent read FOnShowUI write FOnShowUI;
548 property OnTranslateAccelerator: TTranslateAcceleratorEvent read
549 FOnTranslateAccelerator
550 write FOnTranslateAccelerator;
551 property OnTranslateUrl: TTranslateUrlEvent read FOnTranslateUrL
552 write FOnTranslateUrL;
553 property OnUpdateUI: TEWBNotifyEvent read FOnUpdateUI write FOnUpdateUI;
554
555 property OnDragEnter: TOnDragEnterEvent read FOnDragEnterEvent write
556 FOnDragEnterEvent;
557 property OnDragLeave: TNotifyEvent read FOnDragLeaveEvent write
558 FOnDragLeaveEvent;
559 property OnDragOver2: TOnDragOverEvent read FOnDragOverEvent write
560 FOnDragOverEvent;
561 property OnDropEvent: TOnDropEvent read FOnDropEvent write FOnDropEvent;
562
563 property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError;
564 property ScriptErrorAction: TScriptErrorAction read FScriptErrorAction
565 write FScriptErrorAction default eaContinue;
566{$IFDEF USE_IOLECOMMANDTARGET}
567 property OnRefresh: TRefreshEvent read FOnRefresh write FOnRefresh;
568 property OnUnload: TNotifyEvent read FOnUnload write FOnUnload;
569 property OnCommandExec: TComTargetExecEvent read FOnCommandExec write
570 fOnCommandExec;
571{$ENDIF}
572 property OnQueryService: TQueryServiceEvent read FOnQueryService write
573 FOnQueryService;
574 property OnEvaluateNewWindow: TEvaluateNewWindowEvent read
575 FOnEvaluateNewWindow
576 write FOnEvaluateNewWindow;
577 property OnFileDownload: TDownloadEvent read FOnDownload write FOnDownload;
578 property OnFilterPopupMenu: TMenuPreprocess read FOnFilterPopupMenu write
579 FOnFilterPopupMenu;
580 property OnMaskedCtrlChar: TMaskedCtrlCharEvent read FOnMaskedCtrlChar write
581 FOnMaskedCtrlChar;
582
583 property OnMove: TOMWindowMoveEvent read FOnMove write FOnMove;
584 property OnMoveBy: TOMWindowMoveEvent read FOnMoveBy write FOnMoveBy;
585 property OnResize: TOMWindowMoveEvent read FOnResize write FOnResize;
586 property OnResizeBy: TOMWindowMoveEvent read FOnResizeBy write FOnResizeBy;
587 property OnPopulateNSTable: TNotifyEvent read FOnPopulateNSTable write
588 FOnPopulateNSTable;
589 property OnAuthenticate: TAuthenticateEvent read FOnAuthenticate write
590 FOnAuthenticate;
591 property OnPreRefresh: TNotifyEvent read FOnPreRefresh write FOnPreRefresh;
592 end;
593
594 TEwbCore = class(TCustomEmbeddedWB)
595 private
596 function IsCtrlCharMask: Boolean;
597 published
598 property DisableCtrlShortcuts stored IsCtrlCharMask;
599 end;
600
601//this two functions for using in custom OnShowContextMenu handler.
602function IsSeTIEPopupMenus(ID: DWORD; rcm: TIEPopupMenus): Boolean;
603function ShowRightClickMenu(Sender: TObject; dwID: DWORD;
604 const Target: IUnknown; const Context: IDispatch;
605 const ppt: PPOINT;
606 const EncodingSubMenu: OleVariant;
607 preprocess: TMenuPreprocess = nil): Boolean;
608
609
610implementation
611
612uses
613 SysUtils, ComObj, EwbCoreTools, Registry;
614
615function IsSeTIEPopupMenus(ID: DWORD; rcm: TIEPopupMenus): Boolean;
616begin
617 Result := (rcmAll in rcm) or
618 ((ID in [0..9]) and (TIEPopupMenu(ID) in rcm));
619end;
620
621function ShowRightClickMenu(Sender: TObject; dwID: DWORD; const Target: IUnknown; const Context:
622 IDispatch;
623 const ppt: PPOINT; const EncodingSubMenu: OleVariant;
624 Preprocess: TMenuPreprocess = nil): Boolean;
625var
626 ShDocLcHandle: THandle;
627 OleCommandTarget: IOleCommandTarget;
628 OleWindow: IOleWindow;
629 WindowHandle: HWND;
630 ParentMenu, SubMenu: HMENU;
631 SubMenuItemInfo: MENUITEMINFO;
632 PopupResult: LongBool;
633begin
634 Result := False;
635 ShDocLcHandle := GetSHDOCLCModule;
636
637 if ShDocLcHandle = 0 then Exit;
638
639 if Supports(Target, IOleCommandTarget, OleCommandTarget) and
640 Supports(Target, IOleWindow, OleWindow) and
641 ActiveX.Succeeded(OleWindow.GetWindow(WindowHandle)) then
642 begin
643 ParentMenu := Windows.LoadMenu(ShDocLcHandle,
644 MAKEINTRESOURCE(CContextMenuID));
645 if ParentMenu <> 0 then
646 try
647 SubMenu := GetSubMenu(ParentMenu, dwID);
648 FillChar(SubMenuItemInfo, SizeOf(SubMenuItemInfo), 0);
649 SubMenuItemInfo.cbSize := SizeOf(MENUITEMINFO);
650 SubMenuItemInfo.fMask := MIIM_SUBMENU;
651 SubMenuItemInfo.hSubMenu := HMENU(@EncodingSubMenu);
652 SetMenuItemInfo(SubMenu, IDM_LANGUAGE, False, SubMenuItemInfo);
653
654 if Assigned(Preprocess) then
655 Preprocess(Sender, dwID, SubMenu, Context);
656
657 PopupResult := Windows.TrackPopupMenuEx(SubMenu, TPM_LEFTALIGN
658 or TPM_TOPALIGN or TPM_RETURNCMD or TPM_RIGHTBUTTON
659 or TPM_HORPOSANIMATION or TPM_VERPOSANIMATION, ppt^.X, ppt^.Y,
660 WindowHandle, nil);
661 if PopupResult then
662 SendMessage(WindowHandle, WM_COMMAND, MakeWParam(LOWORD(PopupResult), 0), 0);
663 Result := True;
664 finally
665 DestroyMenu(ParentMenu);
666 end;
667 end;
668end;
669
670
671type
672 { TnoDragDrop }
673 TnoDragDrop = class(TInterfacedObject, IDropTarget)
674 protected
675 function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;
676 pt: TPoint; var dwEffect: Longint): HRESULT; stdcall;
677 function DragOver(grfKeyState: Longint; pt: TPoint;
678 var dwEffect: Longint): HRESULT; stdcall;
679 function DragLeave: HRESULT; stdcall;
680 function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
681 var dwEffect: Longint): HRESULT; stdcall;
682 end;
683
684function TnoDragDrop.DragEnter(const dataObj: IDataObject; grfKeyState: Integer;
685 pt: TPoint; var dwEffect: Integer): HRESULT;
686begin
687 dwEffect := DROPEFFECT_NONE;
688 Result := S_OK;
689end;
690
691function TnoDragDrop.DragLeave: HRESULT;
692begin
693 Result := S_OK;
694end;
695
696function TnoDragDrop.DragOver(grfKeyState: Integer; pt: TPoint;
697 var dwEffect: Integer): HRESULT;
698begin
699 dwEffect := DROPEFFECT_NONE;
700 Result := S_OK;
701end;
702
703function TnoDragDrop.Drop(const dataObj: IDataObject; grfKeyState: Integer;
704 pt: TPoint; var dwEffect: Integer): HRESULT;
705begin
706 dwEffect := DROPEFFECT_NONE;
707 Result := S_OK;
708end;
709
710{ TCustomEmbeddedWB }
711
712class function TCustomEmbeddedWB.dwEffectToStr(Command: Int64): string;
713const
714 E_UNSPEC = E_Fail;
715begin
716 case (Command) of
717 DROPEFFECT_NONE: Result := 'Drop target cannot accept the data.';
718 DROPEFFECT_COPY: Result := 'Drag source should copy the data.';
719 DROPEFFECT_MOVE: Result := 'Drag source should remove the data.';
720 DROPEFFECT_LINK: Result :=
721 'Drag source should create a link to the original data.';
722 DRAGDROP_S_DROP: Result := 'The drag-and-drop operation was successful.';
723 DRAGDROP_S_CANCEL: Result := 'The drag-and-drop operation was canceled.';
724 DRAGDROP_S_USEDEFAULTCURSORS: Result :=
725 'Successful completion. Restoring defaults.';
726 DRAGDROP_E_INVALIDHWND: Result :=
727 'Invalid handle returned in the hwnd parameter.';
728 DRAGDROP_E_NOTREGISTERED: Result :=
729 'Failed to revoke a drop target that has not been registered.';
730 E_UNSPEC: Result := 'Unexpected error occurred.';
731 E_OUTOFMEMORY: Result := 'Out of memory.';
732 7: Result := 'operation was successful.';
733 else
734 Result := 'Unknown.';
735 end;
736end;
737
738class procedure TCustomEmbeddedWB.DropEffect(grfKeyState: Longint; var dwEffect:
739 longint);
740begin
741 if (grfKeyState and MK_CONTROL = 0) and (grfKeyState and MK_SHIFT <> 0) and
742 (dwEffect and DropEffect_Move <> 0) then
743 dwEffect := DropEffect_Move
744 else if (grfKeyState and MK_CONTROL <> 0) and (grfKeyState and MK_SHIFT <> 0)
745 and
746 (dwEffect and DropEffect_Link <> 0) then
747 dwEffect := DropEffect_Link
748 else if (dwEffect and DropEffect_Copy <> 0) then
749 dwEffect := DropEffect_Copy
750 else if (dwEffect and DropEffect_Move <> 0) then
751 dwEffect := DropEffect_Move
752 else if (dwEffect and DropEffect_Link <> 0) then
753 dwEffect := DropEffect_Link
754 else
755 dwEffect := DropEffect_None;
756end;
757
758function TCustomEmbeddedWB.AllowFocusChange(out pfAllow: BOOL): HRESULT;
759begin
760 Result := S_OK;
761 pfAllow := CanGrabFocus;
762 if Assigned(OnAllowFocusChange) then
763 OnAllowFocusChange(Self, pfAllow);
764end;
765
766function TCustomEmbeddedWB.CopyOptionKeyPath(Overrided: Boolean): PWideChar;
767begin
768 if (OptionKeyPath = '') or
769 (OverrideOptionKeyPath xor Overrided) then
770 Result := nil
771 else
772 Result := StringToLPOLESTR(OptionKeyPath);
773end;
774
775constructor TCustomEmbeddedWB.Create(AOwner: TComponent);
776begin
777 inherited;
778 FCanGrabFocus := True;
779 FScriptErrorAction := eaContinue;
780 DownloadOptions := [DownloadImages, DownloadVideos, DownloadBGSounds];
781 UserInterfaceOptions := [EnableThemes, EnablesFormsAutoComplete];
782 FDropHandlingType := ddtMS;
783 FDisableCtrlShortcuts := 'N';
784end;
785
786destructor TCustomEmbeddedWB.Destroy();
787begin
788 inherited;
789end;
790
791procedure TCustomEmbeddedWB.CreateWnd; //jls
792begin
793 if (CurrentHandle <> 0) and IsWindow(CurrentHandle) then
794 begin
795 WindowHandle := CurrentHandle;
796 CurrentHandle := 0;
797 Windows.SetParent(WindowHandle, TWinControl(Self).Parent.Handle);
798 MoveWindow(WindowHandle, 0, 0, TWinControl(Self).Parent.Width,
799 TWinControl(Self).Parent.Height, True); //Force a resize on the client window
800 end
801 else
802 inherited;
803end;
804
805procedure TCustomEmbeddedWB.DestroyWnd; //jls
806begin
807 if (csDestroying in ComponentState) then
808 inherited
809 else
810 begin
811 Windows.SetParent(WindowHandle, Forms.Application.Handle); //Parent to the Application window which is 0x0 in size
812 CurrentHandle := WindowHandle; // Save the WindowHandle
813 WindowHandle := 0; // Set it to 0 so Createwnd will be called again...
814 end;
815end;
816
817function TCustomEmbeddedWB.EnableModeless(const fEnable: BOOL): HRESULT;
818begin
819 Result := S_OK;
820 if Assigned(FOnEnableModeless) then
821 FOnEnableModeless(Self, fEnable);
822end;
823
824function TCustomEmbeddedWB.EvaluateNewWindow(pszUrl, pszName, pszUrlContext,
825 pszFeatures: LPCWSTR; fReplace: BOOL; dwFlags,
826 dwUserActionTime: DWORD): HRESULT;
827begin
828 Result := E_FAIL;
829 if Assigned(FOnEvaluateNewWindow) then
830 FOnEvaluateNewWindow(Self, pszUrl, pszName, pszUrlContext, pszFeatures,
831 FReplace, dwFlags, dwUserActionTime, Result);
832end;
833
834function TCustomEmbeddedWB.FilterDataObject(const pDO: IDataObject;
835 out ppDORet: IDataObject): HRESULT;
836begin
837 ppDORet := nil;
838 if Assigned(FOnFilterDataObject) then
839 FOnFilterDataObject(Self, pDO, ppDORet);
840 if ppDORet = nil then
841 Result := S_FALSE
842 else
843 Result := S_OK;
844end;
845
846function TCustomEmbeddedWB.GetDoc2: IHtmlDocument2;
847begin
848 if not Supports(Document, IHtmlDocument2, Result) then
849 Result := nil;
850end;
851
852function TCustomEmbeddedWB.GetDoc3: IHtmlDocument3;
853begin
854 if not Supports(Document, IHtmlDocument3, Result) then
855 Result := nil;
856end;
857
858function TCustomEmbeddedWB.GetDoc4: IHtmlDocument4;
859begin
860 if not Supports(Document, IHtmlDocument4, Result) then
861 Result := nil;
862end;
863
864function TCustomEmbeddedWB.GetDoc5: IHtmlDocument5;
865begin
866 if not Supports(Document, IHtmlDocument5, Result) then
867 Result := nil;
868end;
869
870function TCustomEmbeddedWB.getBody: IHTMLElement;
871var
872 D: IHtmlDocument2;
873begin
874 if Supports(Document, IHtmlDocument2, D) then
875 Result := D.body
876 else
877 Result := nil;
878end;
879
880function TCustomEmbeddedWB.GetExternal(out ppDispatch: IDispatch): HRESULT;
881begin
882 ppDispatch := nil;
883 if Assigned(FOnGetExternal) then
884 FOnGetExternal(Self, ppDispatch);
885 if ppDispatch = nil then
886 Result := S_FALSE
887 else
888 Result := S_OK;
889end;
890
891function TCustomEmbeddedWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
892begin
893 FillChar(pInfo, SizeOf(TDOCHOSTUIINFO), #0);
894 pInfo.cbSize := SizeOf(pInfo);
895 pInfo.dwFlags := FUserInterfaceValue;
896 pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT;
897 Result := S_OK;
898
899 if Assigned(FOnGetHostInfo) then
900 FOnGetHostInfo(Self, pInfo);
901end;
902
903function TCustomEmbeddedWB.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
904 LocaleID: Integer; DispIDs: Pointer): HRESULT;
905begin
906 Result := inherited GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
907 if Assigned(FOnGetIDsOfNames) then
908 FOnGetIDsOfNames(Self, IID, Names, NameCount, LocaleID, DispIds, Result);
909end;
910
911function TCustomEmbeddedWB.GetIEWin(const ClassName: string): HWND;
912var
913 szClass: array[0..255] of char;
914begin
915 if HandleAllocated then
916 begin
917 Result := GetWindow(WindowHandle, GW_CHILD);
918 repeat
919 if (GetClassName(Result, szClass, SizeOf(szClass)) > 0) and
920 (AnsiStrComp(PChar(ClassName), szClass) = 0) then Exit;
921 Result := GetWindow(Result, GW_CHILD);
922 until not IsWindow(Result);
923 end;
924 Result := 0;
925end;
926
927function TCustomEmbeddedWB.GetOptionKeyPath(out pchKey: POleStr;
928 const dw: DWORD): HRESULT;
929begin
930 pchKey := CopyOptionKeyPath(False);
931{$IFDEF GETKEYPATH_HANDLERS}
932 if Assigned(FOnGetOptionKeyPath) then
933 FOnGetOptionKeyPath(Self, pchKey);
934{$ENDIF}
935 if pchKey = nil then
936 Result := S_FALSE
937 else
938 Result := S_OK;
939end;
940
941function TCustomEmbeddedWB.GetOverrideKeyPath(out pchKey: POleStr; dw: DWORD): HRESULT;
942begin
943 pchKey := CopyOptionKeyPath(True);
944{$IFDEF GETKEYPATH_HANDLERS}
945 if Assigned(FOnGetOverrideKeyPath) then
946 FOnGetOverrideKeyPath(Self, pchKey);
947{$ENDIF}
948 if pchKey = nil then
949 Result := S_FALSE
950 else
951 Result := S_OK;
952end;
953
954function TCustomEmbeddedWB.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT;
955begin
956 Result := inherited GetTypeInfo(Index, LocaleID, TypeInfo);
957 if Assigned(FOnGetTypeInfo) then
958 FOnGetTypeInfo(Self, Index, LocaleID, ITypeInfo(TypeInfo), Result);
959end;
960
961function TCustomEmbeddedWB.GetTypeInfoCount(out Count: Integer): HRESULT;
962begin
963 Result := inherited GetTypeInfoCount(Count);
964 if Assigned(FOnGetTypeInfoCount) then
965 FOnGetTypeInfoCount(Self, Count, Result);
966end;
967
968function TCustomEmbeddedWB.GetZoom: Integer;
969var
970 vaIn, vaOut: OleVariant;
971begin
972 vaIn := NULL;
973 InvokeCommand(nil, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
974 Result := vaOut;
975end;
976
977procedure TCustomEmbeddedWB.SetZoom(const Value: Integer);
978var
979 vaIn, vaOut: OleVariant;
980 Range: DWORD;
981begin
982 InvokeCommand(nil, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn,
983 vaOut);
984 Range := DWORD(vaOut);
985 if Value < LoWord(Range) then
986 vaIn := LoWord(Range)
987 else if Value > HiWord(Range) then
988 vaIn := HiWord(Range)
989 else
990 vaIn := Value;
991 InvokeCommand(nil, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
992end;
993
994procedure TCustomEmbeddedWB.SetOpticalZoom(const Value: Integer);
995var
996 vaIn, vaOut: OleVariant;
997 Range: DWORD;
998begin
999 if FZoomPercent <> Value then
1000 begin
1001 FZoomPercent := Value;
1002 InvokeCommand(nil, OLECMDID_OPTICAL_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
1003 Range := DWORD(vaOut);
1004 if Value < LoWord(Range) then
1005 vaIn := LoWord(Range)
1006 else
1007 if Value > HiWord(Range) then
1008 vaIn := HiWord(Range)
1009 else
1010 vaIn := Value;
1011 InvokeCommand(nil, OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
1012 if Assigned(FOnZoomPercentChanged) then
1013 FOnZoomPercentChanged(Self, vaOut);
1014 end;
1015end;
1016
1017function TCustomEmbeddedWB.HideUI: HRESULT;
1018begin
1019 Result := S_FALSE;
1020 if Assigned(FOnHideUI) then
1021 FOnHideUI(Self, Result);
1022end;
1023
1024function TCustomEmbeddedWB.InvokeCommand(CmdGroup: PGUID; Cmd, nCmdexecopt: DWORD;
1025 var vaIn, vaOut: OleVariant): HRESULT;
1026var
1027 CmdTarget: IOleCommandTarget;
1028begin
1029 if Supports(Document, IOleCommandTarget, CmdTarget) then
1030 Result := CmdTarget.Exec(CmdGroup, Cmd, nCmdexecopt, vaIn, vaOut)
1031 else
1032 Result := E_UNEXPECTED;
1033end;
1034
1035function TCustomEmbeddedWB.InvokeCommand(CmdGroup: PGUID; Cmd: DWORD): HRESULT;
1036var
1037 CmdTarget: IOleCommandTarget;
1038 vaIn, vaOut: Olevariant;
1039begin
1040 if Supports(Document, IOleCommandTarget, CmdTarget) then
1041 Result := CmdTarget.Exec(CmdGroup, Cmd, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut)
1042 else
1043 Result := E_UNEXPECTED;
1044end;
1045
1046function TCustomEmbeddedWB.QueryCMDArrayStatus(CmdGroup: PGUID;
1047 cmds: TOleCmdArray): Boolean;
1048var
1049 CmdTarget: IOleCommandTarget;
1050begin
1051 if Supports(Document, IOleCommandTarget, CmdTarget) then
1052 Result := CmdTarget.QueryStatus(CmdGroup,
1053 Length(cmds), @Cmds, nil) = S_OK
1054 else
1055 Result := False;
1056end;
1057
1058function TCustomEmbeddedWB.QueryCMDEnabled(CmdGroup: PGUID; cmdID: Cardinal): Boolean;
1059begin
1060 Result := (QueryCMDStatus(CmdGroup, cmdID) and OLECMDF_ENABLED) <> 0;
1061end;
1062
1063function TCustomEmbeddedWB.QueryCMDLatched(CmdGroup: PGUID; cmdID: Cardinal): Boolean;
1064begin
1065 Result := (QueryCMDStatus(CmdGroup, cmdID) and OLECMDF_LATCHED) <> 0;
1066end;
1067
1068function TCustomEmbeddedWB.QueryCMDStatus(CmdGroup: PGUID; cmdID: Cardinal): OLECMDF;
1069var
1070 CmdTarget: IOleCommandTarget;
1071 Cmd: TOleCmd;
1072begin
1073 Result := 0;
1074 if Supports(Document, IOleCommandTarget, CmdTarget) then
1075 begin
1076 Cmd.CmdID := cmdID;
1077 Cmd.cmdf := 0;
1078 if CmdTarget.QueryStatus(CmdGroup, 1, @Cmd, nil) = S_OK then
1079 Result := Cmd.cmdf;
1080 end;
1081end;
1082
1083function TCustomEmbeddedWB.QueryCommandStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds:
1084 POleCmd;
1085 CmdText: POleCmdText): HRESULT;
1086var
1087 CmdTarget: IOleCommandTarget;
1088begin
1089 if Supports(Document, IOleCommandTarget, CmdTarget) then
1090 Result := CmdTarget.QueryStatus(CmdGroup, cCmds, prgCmds, CmdText)
1091 else
1092 Result := E_UNEXPECTED;
1093end;
1094
1095{$IFDEF RESEARCH_MODE}
1096
1097function TCustomEmbeddedWB.QueryInterface(const IID: TGUID; out Obj): HRESULT;
1098begin
1099 Result := inherited QueryInterface(IID, Obj);
1100 if Assigned(OnQueryInterface) then
1101 OnQueryInterface(Self, IID, Obj, Result);
1102end;
1103{$ENDIF}
1104
1105
1106function TCustomEmbeddedWB.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
1107 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
1108var
1109 UserAgent: string;
1110begin
1111 try
1112 Result := S_FALSE;
1113 if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
1114 begin
1115 Result := S_OK;
1116 case DispID of
1117 DISPID_AMBIENT_DLCONTROL:
1118 begin
1119 PVariant(VarResult)^ := FDownloadOptionValue;
1120 end;
1121 DISPID_AMBIENT_USERMODE:
1122 begin
1123 POleVariant(VarResult)^ := not DesignMode;
1124 end;
1125 DISPID_AMBIENT_USERAGENT:
1126 begin
1127 Result := S_FALSE;
1128 if Assigned(FOnSetUserAgent) then
1129 begin
1130 if FOnSetUserAgent(UserAgent) = S_OK then
1131 if UserAgent <> '' then
1132 begin
1133 POleVariant(VarResult)^ := UserAgent + #13#10;
1134 Result := S_OK;
1135 end;
1136 end;
1137 end;
1138 else
1139 Result := S_FALSE;
1140 end;
1141 end
1142
1143 else if (Flags and DISPATCH_PROPERTYPUT <> 0) and
1144 (DispID = DISPID_AMBIENT_USERMODE) then
1145 begin
1146 Result := S_OK;
1147 Self.FDesignMode := POleVariant(TDispParams(Params).rgvarg)^;
1148 end;
1149
1150 if Result = S_FALSE then
1151 begin
1152 Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params,
1153 VarResult, ExcepInfo, ArgErr);
1154 if (result = DISP_E_MEMBERNOTFOUND) and Assigned(FOnInvoke) then
1155 FOnInvoke(Self, DispID, IID, LocaleID, Flags, TagDispParams(Params),
1156 VarResult, ExcepInfo, ArgErr, Result);
1157 end;
1158 except
1159 on E: Exception do
1160 begin
1161 Result := DISP_E_EXCEPTION;
1162 with PExcepInfo(ExcepInfo)^ do
1163 begin
1164 wCode := 9999;
1165 bstrDescription := E.Message;
1166 bstrSource := E.ClassName;
1167 dwHelpContext := E.HelpContext;
1168 end;
1169 end;
1170 end;
1171end;
1172
1173function TCustomEmbeddedWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
1174begin
1175 if Assigned(FOnOnDocWindowActivate) then
1176 FOnOnDocWindowActivate(Self, FActivate);
1177 Result := S_OK;
1178end;
1179
1180function TCustomEmbeddedWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
1181begin
1182 if Assigned(FOnOnFrameWindowActivate) then
1183 FOnOnFrameWindowActivate(Self, fActivate);
1184 Result := S_OK;
1185end;
1186
1187function TCustomEmbeddedWB.DoQueryService(const rsid, iid: TGUID; var Obj): Boolean;
1188begin
1189 if (IsEqualGuid(rsid, IID_INewWindowManager) and Assigned(FOnEvaluateNewWindow))
1190 or IsEqualGuid(rsid, IID_IProtectFocus)
1191 or (IsEqualGuid(rsid, IID_IDownloadManager) and Assigned(FOnDownload))
1192 or (IsEqualGuid(rsid, IID_IHostBehaviorInit) and Assigned(OnPopulateNSTable))
1193 or (IsEqualGuid(rsid, IID_IHTMLOMWindowServices) and
1194 (FloatingHosting or Assigned(OnMove) or Assigned(Self.OnMoveBy)
1195 or Assigned(OnResize) or Assigned(OnResizeBy)))
1196 or (IsEqualGUID(iid, IID_IAuthenticate) and Assigned(OnAuthenticate))
1197 then Result := QueryInterface(iid, Obj) = S_OK
1198 else Result := False;
1199end;
1200
1201function TCustomEmbeddedWB.QueryService(const rsid, iid: TGUID; out Obj): HRESULT;
1202begin
1203 Pointer(Obj) := nil;
1204 if (not DoQueryService(rsid, iid, Obj)) and Assigned(FOnQueryService) then
1205 FOnQueryService(Self, rsid, iid, IUnknown(obj));
1206
1207 if Pointer(Obj) <> nil then
1208 Result := S_OK
1209 else
1210 Result := E_NOINTERFACE;
1211end;
1212
1213function TCustomEmbeddedWB.ResizeBorder(const prcBorder: PRECT;
1214 const pUIWindow: IOleInPlaceUIWindow; const FrameWindow: BOOL): HRESULT;
1215begin
1216 if Assigned(FOnResizeBorder) then
1217 FOnResizeBorder(Self, prcBorder, pUIWindow, fRameWindow);
1218 Result := S_OK;
1219end;
1220
1221procedure TCustomEmbeddedWB.MoveParentForm(x, y: Integer; Delta: Boolean);
1222var
1223 F: TCustomForm;
1224begin
1225 F := GetParentForm(Self);
1226 if F <> nil then
1227 begin
1228 if Delta then
1229 begin
1230 x := F.Left + x;
1231 y := F.Top + y;
1232 end; //FIXME defend from moving outside of screen (don't forget multimonitor)
1233 F.SetBounds(x, y, F.Width, F.Height);
1234 end;
1235end;
1236
1237procedure TCustomEmbeddedWB.ResizeParentForm(w, h: Integer; Delta: Boolean);
1238var
1239 F: TCustomForm;
1240begin
1241 F := GetParentForm(Self);
1242 if F <> nil then
1243 begin
1244 if Delta then
1245 begin
1246 w := F.Width + w;
1247 h := F.Height + h;
1248 end;
1249 F.SetBounds(F.Left, F.Top, w, h);
1250 end;
1251end;
1252
1253function TCustomEmbeddedWB.ResizeBy(const x, y: Integer): HRESULT;
1254begin
1255 if FloatingHosting then
1256 ResizeParentForm(x, y, True);
1257 if Assigned(OnResizeBy) then
1258 OnResizeBy(Self, x, y);
1259 Result := S_OK; // always return success to prevent script error messages
1260end;
1261
1262function TCustomEmbeddedWB.ResizeTo(const x, y: Integer): HRESULT;
1263begin
1264 if FloatingHosting then
1265 ResizeParentForm(x, y, False);
1266 if Assigned(OnResize) then
1267 OnResize(self, x, y);
1268 Result := S_OK; // always return success to prevent script error messages
1269end;
1270
1271function TCustomEmbeddedWB.MoveBy(const x, y: Integer): HRESULT;
1272begin
1273 if FloatingHosting then
1274 MoveParentForm(x, y, True);
1275 if Assigned(OnMoveBy) then
1276 OnMoveBy(self, x, y);
1277 Result := S_OK; // always return success to prevent script error messages
1278end;
1279
1280function TCustomEmbeddedWB.MoveTo(const x, y: Integer): HRESULT;
1281begin
1282 if FloatingHosting then
1283 MoveParentForm(x, y, False);
1284 if Assigned(OnMove) then
1285 OnMove(self, x, y);
1286 Result := S_OK; // always return success to prevent script error messages
1287end;
1288
1289function TCustomEmbeddedWB.OnZoomPercentChanged(const ulZoomPercent: uLong): HRESULT;
1290begin
1291 if Assigned(FOnZoomPercentChanged) then
1292 Result := FOnZoomPercentChanged(Self, ulZoomPercent)
1293 else
1294 Result := S_FALSE;
1295end;
1296
1297function TCustomEmbeddedWB.GetElemByID(const ID: WideString): IHTMLElement;
1298var
1299 Doc3: IHTMLDocument3;
1300begin
1301 if Supports(Document, IHTMLDocument3, Doc3) then
1302 Result := Doc3.getElementById(ID)
1303 else
1304 Result := nil;
1305end;
1306
1307function TCustomEmbeddedWB.ScrollToElement(Element: IHTMLElement): Boolean;
1308var
1309 RV: IHTMLRect;
1310begin
1311 Result := Element <> nil;
1312 if Result then
1313 begin
1314 RV := (Element as IHTMLElement2).getBoundingClientRect;
1315 Doc2.parentWindow.scrollBy(RV.left, RV.top);
1316 end;
1317end;
1318
1319function TCustomEmbeddedWB.GetCharSet: WideString;
1320begin
1321 Result := Doc2.charset;
1322end;
1323
1324procedure TCustomEmbeddedWB.SetCharSet(const Value: WideString);
1325var
1326 Level: OleVariant;
1327begin
1328 Doc2.charset := Value;
1329 Level := 7;
1330 DefaultInterface.Refresh2(Level);
1331end;
1332
1333procedure TCustomEmbeddedWB.SetDesignMode(const Value: Boolean);
1334var
1335 Control: IOleControl;
1336begin
1337 FDesignMode := Value;
1338 if DefaultInterface.QueryInterface(IOleControl, Control) = 0 then
1339 with (Application as IOleControl) do
1340 begin
1341 OnAmbientPropertyChange(DISPID_AMBIENT_USERMODE);
1342 _Release;
1343 end;
1344end;
1345
1346const
1347 _DesignModeValues: array[TDocDesignMode] of string =
1348 ('On', 'Off', 'Inherit', '');
1349
1350function TCustomEmbeddedWB.GetDocDesignMode: TDocDesignMode;
1351var
1352 D: IHTMLDocument2;
1353 I: Integer;
1354begin
1355 Result := ddmUnknown;
1356 if Supports(Document, IHTMLDocument2, D) then
1357 begin
1358 I := AnsiIndexStr(D.designMode, _DesignModeValues);
1359 if I in [0..2] then
1360 Result := TDocDesignMode(I);
1361 end;
1362end;
1363
1364procedure TCustomEmbeddedWB.SetDocDesignMode(const Value: TDocDesignMode);
1365var
1366 D: IHTMLDocument2;
1367begin
1368 if (Value <> ddmUnknown) and Supports(Document, IHTMLDocument2, D) then
1369 D.designMode := _DesignModeValues[Value];
1370end;
1371
1372procedure TCustomEmbeddedWB.SetDownloadOptions(const Value: TDownloadControlOptions);
1373begin
1374 FDownloadControlOptions := Value;
1375 UpdateDownloadControlValues;
1376 with (Application as IOleControl) do
1377 begin
1378 OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
1379 _Release;
1380 end;
1381end;
1382
1383procedure TCustomEmbeddedWB.SetFocusToBody;
1384var
1385 bodyElement: IHTMLElement2;
1386 HTMLDoc2: IHTMLDocument2;
1387begin
1388 HTMLDoc2 := GetDoc2;
1389 if Assigned(HTMLDoc2) then
1390 begin
1391 bodyElement := HTMLDoc2.body as IHTMLElement2;
1392 if Assigned(bodyElement) then
1393 bodyElement.focus;
1394 end;
1395end;
1396
1397procedure TCustomEmbeddedWB.SetFocusToDoc;
1398var
1399 bCanGrabFocus: Boolean;
1400 ParentForm: TCustomForm;
1401begin
1402 if Document <> nil then
1403 begin
1404 bCanGrabFocus := CanGrabFocus;
1405 CanGrabFocus := True;
1406 with (Application as IOleObject) do
1407 begin
1408 if DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0, Handle, GetClientRect) = S_OK then
1409 begin
1410 ParentForm := GetParentForm(Self);
1411 if Assigned(ParentForm) and Self.CanFocus then
1412 ParentForm.ActiveControl := Self;
1413 end;
1414 end;
1415 CanGrabFocus := bCanGrabFocus;
1416 end;
1417end;
1418
1419procedure TCustomEmbeddedWB.SetFocusToParent;
1420begin
1421 {if IsWindow(WindowHandle) then
1422 begin
1423 Windows.SetParent(WindowHandle, Parent.Handle);
1424 MoveWindow(WindowHandle, 0, 0, Parent.Width, Parent.Height, True);
1425 Parent.SetFocus;
1426 end;}
1427 if IsWindow(WindowHandle) then
1428 begin
1429 Windows.SetParent(WindowHandle, TWinControl(Self).Parent.Handle);
1430 MoveWindow(WindowHandle, 0, 0, TWinControl(Self).Parent.Width,
1431 TWinControl(Self).Parent.Height, True);
1432 TWinControl(Self).Parent.SetFocus;
1433 end;
1434end;
1435
1436procedure TCustomEmbeddedWB.SetUserInterfaceOptions(const Value: TUserInterfaceOptions);
1437begin
1438 FUserInterfaceOptions := Value;
1439 UpdateUserInterfaceValues;
1440 with (Application as IOleControl) do
1441 begin
1442 OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
1443 _Release;
1444 end;
1445end;
1446
1447procedure TCustomEmbeddedWB.SetDropHandlingType(const Value: TDragDropHandlingType);
1448var
1449 innerWnd: LongWord;
1450 Impl: IDropTarget;
1451begin
1452 if FDropHandlingType <> Value then
1453 begin
1454 FDropHandlingType := Value;
1455
1456 if HandleAllocated then
1457 innerWnd := GetIEWin('Internet Explorer_Server')
1458 else
1459 innerWnd := 0;
1460 if innerWnd <> 0 then
1461 RevokeDragDrop(innerWnd);
1462
1463 Impl := nil;
1464 case Value of
1465 ddtMS:
1466 DefaultInterface.RegisterAsDropTarget := True;
1467 ddtMy: Impl := Self;
1468 ddtCustom:
1469 if innerWnd <> 0 then
1470 begin
1471 Impl := Self;
1472 if Assigned(FOnGetDropTarget) then
1473 FOnGetDropTarget(Self, Impl);
1474 end;
1475 ddtNo:
1476 DefaultInterface.RegisterAsDropTarget := False;
1477 end;
1478 if (innerWnd <> 0) and (Impl <> nil) then
1479 RegisterDragDrop(innerWnd, Impl);
1480 end;
1481end;
1482
1483function TCustomEmbeddedWB.GetDropTarget(const pDropTarget: IDropTarget;
1484 out ppDropTarget: IDropTarget): HRESULT;
1485begin
1486 Result := S_OK;
1487 case DropHandlingType of
1488 ddtMS:
1489 begin
1490 DefaultInterface.RegisterAsDropTarget := True;
1491 Result := E_NOTIMPL;
1492 end;
1493 ddtMy:
1494 ppDropTarget := Self;
1495 ddtCustom:
1496 begin
1497 ppDropTarget := Self;
1498 if Assigned(FOnGetDropTarget) then
1499 FOnGetDropTarget(Self, ppDropTarget);
1500 end;
1501 ddtNo:
1502 begin
1503 DefaultInterface.RegisterAsDropTarget := False;
1504 ppDropTarget := nil;
1505 end;
1506 end;
1507end;
1508
1509function TCustomEmbeddedWB.DragEnter(const dataObj: IDataObject; grfKeyState: Integer;
1510 pt: TPoint; var dwEffect: Integer): HRESULT;
1511begin
1512 Result := NOERROR;
1513 dwEffect := DROPEFFECT_NONE;
1514 if Assigned(OnDragEnter) then
1515 OnDragEnter(Self, dataObj, grfKeyState, pt, dwEffect, Result);
1516end;
1517
1518function TCustomEmbeddedWB.DragLeave: HRESULT;
1519begin
1520 Result := NOERROR;
1521 if Assigned(OnDragLeave) then
1522 OnDragLeave(Self);
1523end;
1524
1525function TCustomEmbeddedWB.Drop(const dataObj: IDataObject; grfKeyState: Integer;
1526 pt: TPoint; var dwEffect: Integer): HRESULT;
1527begin
1528 Result := NOERROR;
1529 dwEffect := DROPEFFECT_NONE;
1530 if Assigned(FOnDropEvent) then
1531 FOnDropEvent(Self, dataObj, grfKeyState, pt, dwEffect, Result);
1532end;
1533
1534function TCustomEmbeddedWB.DropTargetDragOver(grfKeyState: Integer; pt: TPoint;
1535 var dwEffect: Integer): HRESULT;
1536begin
1537 Result := NOERROR;
1538 dwEffect := DROPEFFECT_NONE;
1539 if Assigned(FOnDragOverEvent) then
1540 FOnDragOverEvent(Self, grfKeyState, pt, dwEffect, Result);
1541end;
1542
1543function TCustomEmbeddedWB.Download(pmk: IMoniker; pbc: IBindCtx; dwBindVerb,
1544 grfBINDF: DWORD; pBindInfo: PBindInfo; pszHeaders, pszRedir: PWidechar;
1545 uiCP: UINT): HRESULT;
1546begin
1547 Result := E_NOTIMPL;
1548 if Assigned(FOnDownload) then
1549 FOnDownload(Self, pmk, pbc, dwBindVerb, grfBINDF, pBindInfo, pszHeaders,
1550 pszRedir, uiCP, Result);
1551end;
1552
1553function TCustomEmbeddedWB.FilterPopupMenu: Boolean;
1554begin
1555 Result := Assigned(OnFilterPopupMenu);
1556end;
1557
1558procedure TCustomEmbeddedWB.DoFilterPopupMenu(Sender: TObject; ID: DWORD; Menu: HMENU; const Context:
1559 IDispatch);
1560begin
1561 if Assigned(OnFilterPopupMenu) then
1562 OnFilterPopupMenu(Sender, ID, Menu, Context);
1563end;
1564
1565function TCustomEmbeddedWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
1566 const CommandTarget: IUnknown; const Context: IDispatch): HRESULT;
1567var
1568 EncodingSubMenu: OleVariant;
1569begin
1570 Result := E_NOTIMPL;
1571 if Assigned(FOnShowContextMenu) then
1572 FOnShowContextMenu(Self, dwID, ppt, CommandTarget, Context, Result);
1573
1574 if Result = E_NOTIMPL then
1575 begin
1576 if IsSeTIEPopupMenus(dwID, DisabledPopupMenus) then
1577 begin
1578 Result := S_OK;
1579 if Assigned(PopUpMenu) then // Show assigned TPopupMenu
1580 PopUpMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
1581 end else
1582 if FilterPopupMenu then
1583 begin
1584 ExecWB(CGetMimeSubMenuCommandID, OLECMDEXECOPT_DODEFAULT, EncodingSubMenu);
1585 if ShowRightClickMenu(Self, dwID, CommandTarget, Context, ppt, EncodingSubMenu,
1586 DoFilterPopupMenu) then
1587 Result := S_OK
1588 else
1589 Result := S_FALSE;
1590 end
1591 else
1592 Result := S_FALSE;
1593 end;
1594end;
1595
1596function TCustomEmbeddedWB.ShowHelp(HWND: THandle; pszHelpFile: POleStr; uCommand,
1597 dwData: Integer; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT;
1598begin
1599 if Assigned(FOnShowHelp) then
1600 Result := FOnShowHelp(Self, HWND, pszHelpFile, uCommand, dwData, ptMouse, pDispatchObjectHit)
1601 else
1602 if (pszHelpFile = nil) and (HelpFile <> '') then
1603 begin
1604 HtmlHelp(HWND, PChar(HelpFile), uCommand, dwData);
1605 Result := S_OK;
1606 end
1607 else
1608 Result := S_FALSE;
1609end;
1610
1611function TCustomEmbeddedWB.ShowMessage(HWND: THandle; lpstrText, lpstrCaption: POleStr;
1612 dwType: Integer; lpstrHelpFile: POleStr; dwHelpContext: Integer;
1613 var plResult: LRESULT): HRESULT;
1614begin
1615 if Assigned(FOnShowMessage) then
1616 Result := FOnShowMessage(Self, HWND, lpstrText, lpStrCaption, dwType, lpStrHelpFile, dwHelpContext, plResult)
1617 else
1618 Result := S_FALSE;
1619end;
1620
1621function TCustomEmbeddedWB.ShowUI(const dwID: DWORD;
1622 const pActiveObject: IOleInPlaceActiveObject;
1623 const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
1624 const pDoc: IOleInPlaceUIWindow): HRESULT;
1625begin
1626 Result := S_FALSE;
1627 if Assigned(FOnShowUI) then
1628 FOnShowUI(Self, dwID, pActiveObject, pCommandTarget, pFrame, pDoc, Result);
1629end;
1630
1631function TCustomEmbeddedWB.DoFilterMsg(const lpMsg: PMSG): Boolean;
1632type
1633 PWMKey = ^TWMKey;
1634var
1635 ShiftState: TShiftState;
1636begin
1637 {
1638 Result := (FDisableCtrlShortcuts <> '') and (lpMsg^.message = WM_KEYDOWN)
1639 and (((GetKeyState(VK_LCONTROL) < 0) and (GetKeyState(VK_MENU) >= 0)) or
1640 ((GetKeyState(VK_RCONTROL) < 0) and (GetKeyState(VK_LMENU) >= 0)))
1641 and (_CharPos(Char(lpMsg.wParam), FDisableCtrlShortcuts) > 0); }
1642
1643 ShiftState := KeyDataToShiftState(PWMKey(lpMsg)^.KeyData);
1644 Result := (FDisableCtrlShortcuts <> '') and (lpMsg^.message = WM_KEYDOWN)
1645 and ((ShiftState = [ssCtrl]) and (ShiftState <> [ssAlt]))
1646 and (_CharPos(Char(lpMsg.wParam), FDisableCtrlShortcuts) > 0);
1647
1648 if Result and Assigned(OnMaskedCtrlChar) then
1649 OnMaskedCtrlChar(Self, Char(lpMsg.wParam));
1650end;
1651
1652function TCustomEmbeddedWB.TranslateAccelerator(const lpMsg: PMSG;
1653 const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
1654 { Called by MSHTML when IOleInPlaceActiveObject.TranslateAccelerator or
1655 IOleControlSite.TranslateAccelerator is called }
1656var
1657 Filtered: Boolean;
1658begin
1659 Filtered := DoFilterMsg(lpMsg);
1660 if (not Filtered) and Assigned(FOnTranslateAccelerator) then
1661 FOnTranslateAccelerator(Self, lpMsg, pguidCmdGroup, nCmdID, Filtered);
1662
1663 if Filtered then
1664 Result := S_OK
1665 else
1666 Result := S_FALSE;
1667end;
1668
1669
1670function TCustomEmbeddedWB.TranslateUrl(const dwTranslate: DWORD; const pchURLIn:
1671 POleStr; out ppchURLOut: POleStr): HRESULT;
1672var
1673 URLOut: WideString;
1674begin
1675 URLOut := '';
1676 if Assigned(FOnTranslateUrl) then
1677 FOnTranslateUrl(Self, pchUrlIn, URLOut);
1678 if URLOut <> '' then
1679 begin
1680 Result := S_OK;
1681 ppchURLOut := WideStringToLPOLESTR(URLOut);
1682 end
1683 else
1684 Result := S_FALSE;
1685end;
1686
1687function TCustomEmbeddedWB.UpdateUI: HRESULT;
1688begin
1689 Result := S_FALSE;
1690 if Assigned(FOnUpdateUI) then
1691 FOnUpdateUI(Self, Result);
1692end;
1693
1694procedure TCustomEmbeddedWB.UpdateUserInterfaceValues;
1695const
1696 acardUserInterfaceValues: array[TUserInterfaceOption] of Cardinal =
1697 ($00000001, $00000002, $00000004, $00000008,
1698 $00000010, $00000020, $00000040, $00000080,
1699 $00000100, $00000200, $00000400, $00000800,
1700 $00001000, $00002000, $00004000, $00010000, $00020000,
1701 $00040000, $00080000, $00100000, $00200000, $00400000,
1702 $00800000, $01000000, $02000000, $04000000, $08000000,
1703 $10000000, $20000000);
1704var
1705 uio: TUserInterfaceOption;
1706begin
1707 FUserInterfaceValue := 0;
1708 if (FUserInterfaceOptions <> []) then
1709 for uio := Low(TUserInterfaceOption) to High(TUserInterfaceOption) do
1710 if (uio in FUserInterfaceOptions) then
1711 Inc(FUserInterfaceValue, acardUserInterfaceValues[uio]);
1712end;
1713
1714
1715procedure TCustomEmbeddedWB.UpdateDownloadControlValues;
1716const
1717 acardDownloadControlValues: array[TDownloadControlOption] of Cardinal =
1718 ($00000010, $00000020, $00000040, $00000080,
1719 $00000100, $00000200, $00000400, $00000800,
1720 $00001000, $00002000, $00004000, $00008000,
1721 $00010000, $00020000, $00040000, $10000000,
1722 $20000000, $40000000, $80000000);
1723var
1724 dco: TDownloadControlOption;
1725begin
1726 FDownloadOptionValue := 0;
1727 if (FDownloadControlOptions <> []) then
1728 for dco := Low(TDownloadControlOption) to High(TDownloadControlOption) do
1729 if (dco in FDownloadControlOptions) then
1730 Inc(FDownloadOptionValue, acardDownloadControlValues[dco]);
1731end;
1732
1733function TCustomEmbeddedWB.ZoomRangeHigh: Integer;
1734var
1735 vaIn, vaOut: OleVariant;
1736begin
1737 InvokeCommand(nil, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
1738 Result := HiWord(DWORD(vaOut));
1739end;
1740
1741function TCustomEmbeddedWB.ZoomRangeLow: Integer;
1742var
1743 vaIn, vaOut: OleVariant;
1744begin
1745 InvokeCommand(nil, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
1746 Result := LoWord(DWORD(vaOut));
1747end;
1748
1749function TCustomEmbeddedWB._getCookie: WideString;
1750var
1751 D: IHTMLDocument2;
1752begin
1753 if Supports(Document, IHTMLDocument2, D) then
1754 Result := OleObject.Document.Cookie
1755 else
1756 Result := '';
1757end;
1758
1759procedure TCustomEmbeddedWB.Client2HostWin(var CX, CY: Integer);
1760var
1761 F: TCustomForm;
1762begin
1763 F := GetParentForm(Self);
1764 if F <> nil then
1765 begin
1766 Inc(CX, F.ClientWidth - Self.Width);
1767 Inc(CY, F.ClientHeight - Self.Height);
1768 end;
1769end;
1770
1771{$IFDEF USE_IOLECOMMANDTARGET}
1772//======IOleCommandTarget interface ============================================
1773
1774function TCustomEmbeddedWB.CommandTarget_QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
1775 prgCmds: POleCmd; CmdText: POleCmdText): HRESULT;
1776begin
1777 Result := S_OK;
1778end;
1779
1780function TCustomEmbeddedWB.CommandTarget_Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
1781 const vaIn: OleVariant; var vaOut: OleVariant): HRESULT;
1782var
1783 tmpCancel: Boolean;
1784const
1785{$J+}
1786 LastTickEvent: Cardinal = 0;
1787{$J-}
1788begin
1789 Result := OLECMDERR_E_NOTSUPPORTED;
1790 if CmdGroup <> nil then
1791 begin
1792 if IsEqualGuid(cmdGroup^, CGID_EXPLORER) then
1793 begin
1794 case nCmdID of
1795 OLECMDID_ONUNLOAD:
1796 if Assigned(FOnUnload) then
1797 begin
1798 FOnUnload(Self);
1799 Result := S_OK;
1800 Exit;
1801 end;
1802
1803 OLECMDID_PREREFRESH:
1804 begin
1805 if Assigned(FOnPreRefresh) then
1806 begin
1807 if GetTickCount - LastTickEvent > 150 then
1808 begin
1809 LastTickEvent := GetTickCount;
1810 FOnPreRefresh(Self);
1811 end;
1812 end;
1813
1814 if Assigned(FOnHookChildWindow) then
1815 if (GetIEWin('Internet Explorer_Server') <> 0) or (GetIEWin('SysListView32') <> 0) then
1816 FOnHookChildWindow(Self);
1817 end;
1818 end
1819 end else
1820 if IsEqualGuid(cmdGroup^, CGID_DocHostCommandHandler) then
1821 begin
1822 case nCmdID of
1823 ID_IE_F5_REFRESH {nCmdID 6041, F5},
1824 ID_IE_CONTEXTMENU_REFRESH {nCmdID 6042, Refresh by ContextMenu},
1825 IDM_REFRESH {nCmdID 2300}:
1826 begin
1827 if Assigned(FOnRefresh) then
1828 begin
1829 tmpCancel := False;
1830 FOnRefresh(Self, nCmdID, tmpCancel);
1831 if tmpCancel then
1832 Result := S_OK; //FIXME is it true? Why not OLECMDERR_E_CANCELED
1833 end;
1834 Exit;
1835 end;
1836 OLECMDID_SHOWSCRIPTERROR:
1837 begin
1838 Result := ScriptErrorHandler(vaIn, vaOut);
1839 Exit;
1840 end;
1841 end;
1842 end;
1843 end;
1844 if Assigned(OnCommandExec) then
1845 Self.OnCommandExec(Self, CmdGroup, nCmdID, nCmdexecopt,
1846 vaIn, vaOut, Result);
1847end;
1848{$ENDIF}
1849
1850function TCustomEmbeddedWB.ScriptErrorHandler(const vaIn: OleVariant;
1851 var vaOut: OleVariant): HRESULT;
1852var
1853 EventObject: IHTMLEventObj;
1854 CurWindow: IHTMLWindow2;
1855 CurDocument: IHTMLDocument2;
1856 CurUnknown: IUnknown;
1857
1858 function GetProperty(const PropName: WideString): OleVariant;
1859 var
1860 DispParams: TDispParams;
1861 Disp, Status: Integer;
1862 ExcepInfo: TExcepInfo;
1863 PPropName: PWideChar;
1864 begin
1865 DispParams.rgvarg := nil;
1866 DispParams.rgdispidNamedArgs := nil;
1867 DispParams.cArgs := 0;
1868 DispParams.cNamedArgs := 0;
1869 PPropName := PWideChar(PropName);
1870 Status := EventObject.GetIDsOfNames(GUID_NULL, @PPropName, 1, LOCALE_SYSTEM_DEFAULT, @Disp);
1871 if Status = 0 then
1872 begin
1873 Status := EventObject.Invoke(disp, GUID_NULL, LOCALE_SYSTEM_DEFAULT,
1874 DISPATCH_PROPERTYGET, DispParams, @Result, @ExcepInfo, nil);
1875 if Status <> 0 then
1876 DispatchInvokeError(Status, ExcepInfo);
1877 end
1878 else
1879 if Status = DISP_E_UNKNOWNNAME then
1880 raise
1881 EOleError.CreateFmt('''%s'' is not supported.', [PropName])
1882 else
1883 OleCheck(Status);
1884 end;
1885begin
1886 Result := S_OK;
1887 case FScriptErrorAction of
1888 eaAskUser: Result := S_FALSE; //E_FAIL;
1889 eaContinue: vaOut := True;
1890 eaCancel: vaOut := False;
1891 end;
1892
1893 if Assigned(FOnScriptError) then
1894 begin
1895 CurUnknown := IUnknown(TVarData(vaIn).VUnknown);
1896 if Succeeded(CurUnknown.QueryInterface(IID_IHTMLDocument2, CurDocument)) then
1897 begin
1898 CurWindow := CurDocument.Get_parentWindow;
1899 CurDocument := nil;
1900 if Assigned(CurWindow) then
1901 begin
1902 EventObject := CurWindow.Get_event;
1903 if EventObject <> nil then
1904 begin
1905 FOnScriptError(Self,
1906 GetProperty('errorline'),
1907 GetProperty('errorCharacter'),
1908 GetProperty('errorCode'),
1909 GetProperty('errorMessage'),
1910 GetProperty('errorUrl'),
1911 FScriptErrorAction);
1912 end;
1913 end;
1914 end;
1915 end;
1916end;
1917
1918function TCustomEmbeddedWB.PopulateNamespaceTable: HRESULT;
1919begin
1920 Result := S_OK;
1921 if Assigned(fOnPopulateNSTable) then
1922 FOnPopulateNSTable(Self);
1923end;
1924
1925function TCustomEmbeddedWB.GetElementNamespaceTable(
1926 out aTable: IElementNamespaceTable): Boolean;
1927var
1928 SP: IServiceProvider;
1929begin
1930 Result := Supports(Self.Document, IServiceProvider, SP) and
1931 (SP.QueryService(IID_IElementNamespaceTable, IID_IElementNamespaceTable,
1932 aTable) = S_OK);
1933end;
1934
1935function WideStringToLPOLESTR(const Src: WideString): POLEStr;
1936begin
1937 Result := CoTaskMemAlloc((Length(Src) + 1) * SizeOf(WideChar));
1938 if Result <> nil then
1939 Move(PWideChar(Src)^, Result^, (Length(Src) + 1) * SizeOf(WideChar));
1940end;
1941
1942function TCustomEmbeddedWB.Authenticate(var hwnd: HWnd; var szUserName,
1943 szPassWord: LPWSTR): HRESULT;
1944var
1945 aUser, aPwd: WideString;
1946begin
1947 Result := S_OK;
1948 hwnd := Self.Handle;
1949 aUser := '';
1950 aPwd := '';
1951 if Assigned(OnAuthenticate) then
1952 OnAuthenticate(Self, hwnd, aUser, aPwd, Result);
1953 if aUser <> '' then
1954 szUserName := WideStringToLPOLESTR(aUser)
1955 else
1956 szUserName := nil;
1957 if aPwd <> '' then
1958 szPassWord := WideStringToLPOLESTR(aPwd)
1959 else
1960 szPassWord := nil;
1961end;
1962
1963{ TEwbCore }
1964
1965function TEwbCore.IsCtrlCharMask: Boolean;
1966begin
1967 Result := FDisableCtrlShortcuts <> 'N';
1968end;
1969
1970end.
Note: See TracBrowser for help on using the repository browser.