unit EmbeddedWB; {$DEFINE USE_IOLECOMMANDTARGET} //*********************************************************** // EmbeddedWb ver 1.17 (Jan. 1 , 2004) * // * // For Delphi 4, 5, 6 and 7 * // Freeware Component * // by * // Per Linds?Larsen * // per.lindsoe@larsen.mail.dk * // * // * // Contributors: * // * // Mathias Walter (walter@coint.de) * // - all messagehandling code * // * // Neil Moss (NeilM@BuchananInternational.com) * // - code for setting downloadoptions * // * // jezek1 * // - support for D7 (12/09/2002) * // * // Thomas Stutz * // * // - added THEME, NOTHEME, NOPICS, * // NO3DOUTERBORDER to TUserInterfaceOption * // (11/1/04) * // * // Documentation and updated versions: * // * // http://www.euromind.com/iedelphi * //*********************************************************** interface uses Variants, IEConst, IEUtils, Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, EXTCtrls, OleCtrls, SHDocVw, ActiveX, shlObj, Wininet, Urlmon, shellapi, MSHTML; type {$IFDEF USE_IOLECOMMANDTARGET} TScriptErrorEvent = procedure(Sender: TObject; ErrorLine, ErrorCharacter, ErrorCode, ErrorMessage, ErrorUrl: string; var ContinueScript: Boolean; var Showdialog: Boolean) of object; TRefreshEvent = procedure(Sender: TObject; CmdID: Integer; var Cancel: Boolean) of object; TUnloadEvent = procedure(Sender: TObject) of object; {$ENDIF} TGetOverrideKeyPathEvent = function(pchKey: POLESTR; dw: DWORD): HRESULT of object; TShowContextMenuEvent = function(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT of object; TGetHostInfoEvent = function(var pInfo: TDOCHOSTUIINFO): HRESULT of object; TShowUIEvent = function(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT of object; THideUIEvent = function: HRESULT of object; TUpdateUIEvent = function: HRESULT of object; TEnableModelessEvent = function(const fEnable: BOOL): HRESULT of object; TOnDocWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object; TOnFrameWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object; TResizeBorderEvent = function(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT of object; TTranslateAcceleratorEvent = function(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT of object; TGetOptionKeyPathEvent = function(var pchKey: POLESTR; const dw: DWORD): HRESULT of object; TGetDropTargetEvent = function(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT of object; TGetExternalEvent = function(out ppDispatch: IDispatch): HRESULT of object; TTranslateUrlEvent = function(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT of object; TFilterDataObjectEvent = function(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT of object; TShowMessageEvent = function(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT of object; TShowHelpEvent = function(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT of object; TGetTypeInFoCountEvent = function(out Count: Integer): HResult of object; TGetTypeInfoEvent = function(Index, LocaleID: Integer; out TypeInfo: ITypeInfo): HResult of object; TGetIDsOfNamesEvent = function(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult of object; TInvokeEvent = function(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params: TagDispParams; VarResult, ExcepInfo, ArgErr: Pointer): HResult of object; TQueryServiceEvent = function(const rsid, iid: TGuid; out Obj: IUnknown): HResult of object; TShowDialogEvent = procedure(Sender: TObject; h: THandle) of object; 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); TDownloadControlOptions = set of TDownloadControlOption; 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); TUserInterfaceOptions = set of TUserInterfaceOption; type TMeasure = (mMetric, mUS); TPrintOrientationOption = (poPortrait, poLandscape); TMargins = class(TPersistent) private FLeft: Real; FRight: Real; FTop: Real; FBottom: real; published property Left: Real read FLeft write FLeft; property Right: Real read FRight write FRight; property Top: Real read FTop write FTop; property Bottom: Real read FBottom write FBottom; end; TPrintOptions = class(TPersistent) private FHTMLHeader: TStrings; FHeader: string; FFooter: string; FMargins: TMargins; FOrientation: TPrintOrientationOption; FMeasure: TMeasure; procedure SetHTMLHeader(const Value: Tstrings); property Measure: TMeasure read FMeasure; published property Margins: TMargins read FMargins write FMargins; property Header: string read FHeader write FHeader; property HTMLHeader: TStrings read FHTMLHeader write SetHTMLHeader; property Footer: string read FFooter write FFooter; property Orientation: TPrintOrientationOption read FOrientation write FOrientation; end; TEmbeddedWB = class(TWebbrowser, IDocHostShowUI, IDocHostUIHandler, IDocHostUIHandler2, IDispatch, IServiceProvider {$IFDEF USE_IOLECOMMANDTARGET}, IOleCommandTarget{$ENDIF}) private {$IFDEF VER120} SaveMessage: TMessageEvent; {$ENDIF} FUserAgent: string; FReplaceCaption: Boolean; FPrintOptions: TPrintOPtions; FDownloadControlOptions: TDownloadControlOptions; FUserInterfaceOptions: TUserInterfaceOptions; {$IFDEF USE_IOLECOMMANDTARGET} FOnUnload: TUnloadEvent; FOnRefresh: TRefreshEvent; FOnScriptError: TScriptErrorEvent; {$ENDIF} FOnGetOverrideKeyPath: TGetOverrideKeypathEvent; FOnShowContextMenu: TShowcontextmenuEvent; FOnGetHostInfo: TGetHostInfoEvent; FOnShowUI: TShowUIEvent; FOnHideUI: THideUIEvent; FOnUpdateUI: TUpdateUIEvent; FOnEnableModeless: TEnableModelessEvent; FOnOnDocWindowActivate: TOnDocWindowActivateEvent; FOnOnFrameWindowActivate: TOnFrameWindowActivateEvent; FOnResizeBorder: TResizeBorderEvent; FOnTranslateAccelerator: TTranslateAcceleratorEvent; FOnGetOptionKeyPath: TGetOptionKeyPathEvent; FOnGetDropTarget: TGetDropTargetEvent; FOnGetExternal: TGetExternalEvent; FOnTranslateUrL: TTranslateUrlEvent; FOnFilterDataObject: TFilterDataObjectEvent; FHelpFile: string; FOnShowMessage: TShowMessageEvent; FOnShowHelp: TShowHelpEvent; FOnGetTypeInfoCount: TGetTypeInfoCountEvent; FOnGetTypeInfo: TGetTypeInfoEvent; FOnGetIDsOfNames: TGetIDsOfNamesEvent; FOnInvoke: TInvokeEvent; FOnQueryService: TQueryServiceEvent; FOldWindowProc: TWndMethod; FParentForm: TForm; FDownloadOptionValue: Longint; FUserInterfaceValue: Cardinal; FOnCloseQuery: TCloseQueryEvent; FOnShowDialog: TShowDialogEvent; OldWBWndProc: TWndMethod; RuntimeMeasure: TMeasure; DDEHWnd: THandle; FEnableDDE: Boolean; FfpExceptions: Boolean; procedure SetUserAgent; procedure RemoveUserAgent; procedure GetPrintValues; procedure Hook; procedure UnHook; procedure FormWndProc(var AMsg: TMessage); procedure DDEWndProc(var AMsg: TMessage); procedure WBWndProc(var Message: TMessage); procedure SetDownloadOptions(const Value: TDownloadControlOptions); procedure SetUserInterfaceOptions(const Value: TUserInterfaceOptions); procedure SetfpExceptions(const Value: Boolean); procedure UpdateDownloadControlValue; procedure UpdateUserInterfaceValue; protected function DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL; function DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT; function DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT; function GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; stdcall; {$IFDEF USE_IOLECOMMANDTARGET} function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HResult; stdcall; function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; var vaOut: OleVariant): HResult; stdcall; {$ENDIF} function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall; function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall; function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall; function HideUI: HRESULT; stdcall; function UpdateUI: HRESULT; stdcall; function EnableModeless(const fEnable: BOOL): 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 TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; stdcall; function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall; function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall; function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall; function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall; function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall; function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall; function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT; stdcall; function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; {$IFDEF VER120} procedure IEMessageHandler(var Msg: TMsg; var Handled: Boolean); {$ENDIF} function QueryService(const rsid, iid: TGuid; out Obj): HResult; stdcall; function OpenClient(Client: string): Boolean; function PrintMarginStr(M: Real): PChar; public SecurityManager: IInternetSecurityManager; ZoneManager: IInternetZoneManager; function ShowMailClient: Boolean; function ShowNewsClient: Boolean; function ShowAddressBook: Boolean; function ShowCalendar: Boolean; function ShowInternetCall: Boolean; procedure AssignDocument; procedure SetFocusToDoc; procedure InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant); procedure Go(Url: string); procedure Print; procedure OpenDialog; procedure SaveDialog; procedure PrintSetup; procedure PageSetup(UsePrintOptions: Boolean); procedure ViewSource; procedure Properties; procedure Options; procedure Find; {$IFDEF VER120} procedure EnableMessagehandler; procedure DisableMessagehandler; {$ENDIF} procedure Copy; procedure SelectAll; procedure Zoom(ZoomValue: Integer); function ZoomRangeHigh: Integer; function ZoomRangeLow: Integer; function ZoomValue: Integer; procedure NavigatePidl(pidl: PItemIdlist); procedure NavigateFolder(CSIDL: Integer); procedure SetGlobalOffline(Value: Boolean); function IsGlobalOffline: boolean; // function LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult; // function LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT; // function SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT; // function SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT; // function SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT; function LoadFromStream(const AStream: TStream): HRESULT; function LoadFromStrings(const AStrings: TStrings): HRESULT; function SaveToStrings(AStrings: TStrings): HRESULT; function SaveToStream(AStream: TStream): HRESULT; function SaveToFile(const Fname: string): HRESULT; constructor Create(Owner: TComponent); override; procedure Loaded; override; destructor Destroy; override; procedure PrintPreView; procedure PrintWithOptions; // function GetFrame(FrameNo: Integer): IWebbrowser2; // function FrameCount: LongInt; procedure GetThumbnail(var Image: TImage); procedure ClearHistory; procedure ClearCache; published property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions write SetDownloadOptions; property UserInterfaceOptions: TUserInterfaceOptions read FUserInterfaceOptions write SetUserInterfaceOptions; {$IFDEF USE_IOLECOMMANDTARGET} property OnRefresh: TRefreshEvent read FOnRefresh write FOnRefresh; property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError; property OnUnload: TUnloadEvent read FOnUnload write FOnUnload; {$ENDIF} property OnGetOverrideKeyPath: TGetOVerrideKeypathEvent read FOnGetOverrideKeyPath write FOnGetOverrideKeyPath; property OnShowContextMenu: TShowContextMenuEvent read FOnShowContextmenu write FOnShowContextmenu; property OnGetHostInfo: TGetHostInfoEvent read FOnGethostinfo write fongethostinfo; property OnShowUI: TShowUIEvent read FOnShowUI write FOnShowUI; property OnHideUI: THideUIEvent read FOnHideUI write FOnHideUI; property OnUpdateUI: TUpdateUIEvent read FOnUpdateUI write FOnUpdateUI; property OnEnableModeless: TEnableModelessEvent read FOnEnableModeless write FOnEnableModeless; property OnOnDocWindowActivate: TOnDocWindowActivateEvent read FOnOnDocWindowActivate write FOnOnDocWindowActivate; property OnOnFrameWindowActivate: TOnFrameWindowActivateEvent read FOnOnFrameWindowActivate write FOnOnFrameWindowActivate; property OnResizeBorder: TResizeBorderEvent read FOnResizeBorder write FOnResizeBorder; property OnTranslateAccelerator: TTranslateAcceleratorEvent read FOnTranslateAccelerator write FOnTranslateAccelerator; property OnGetOptionKeyPath: TGetOptionKeyPathEvent read FOnGetOptionKeyPath write FOnGetOptionKeyPath; property OnGetDropTarget: TGetDropTargetEvent read FOnGetDropTarget write FOnGetDropTarget; property OnGetExternal: TGetExternalEvent read FOnGetExternal write FOnGetExternal; property OnTranslateUrl: TTranslateUrlEvent read FOnTranslateUrL write FOnTranslateUrL; property OnFilterDataObject: TFilterDataObjectEvent read FOnFilterDataObject write FOnFilterDataObject; property HelpFile: string read FHelpFile write FHelpFile; property OnShowMessage: TShowMessageEvent read FOnShowMessage write FOnShowMessage; property OnShowHelp: TShowHelpEvent read FOnShowHelp write FOnShowHelp; property OnGetTypeInfoCount: TGetTypeInfoCountEvent read FonGetTypeInfoCount write FOnGetTypeInfoCount; property OnGetTypeInfo: TGetTypeInfoEvent read FonGetTypeInfo write FOnGetTypeInfo; property OnGetIDsOfNames: TGetIDsOfNamesEvent read FOnGetIDsOfNames write FOnGetIdsOfNames; property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke; property OnQueryService: TQueryServiceEvent read FOnQueryService write FOnQueryService; property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery; property OnShowDialog: TShowDialogEvent read FOnShowDialog write FOnShowDialog; property PrintOptions: TPrintOptions read FPrintOptions write FPrintOptions; property UserAgent: string read FUserAgent write FUserAgent; property ReplaceCaption: Boolean read FReplaceCaption write FReplaceCaption; property EnableDDE: Boolean read FEnableDDE write FEnableDDE; property fpExceptions: Boolean read FfpExceptions write SetfpExceptions; end; function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT; function UnregisterMIMEFilter(MIME: PWideChar): HRESULT; function RegisterNameSpace(clsid: TGUID): HRESULT; function UnregisterNameSpace: HRESULT; procedure Register; implementation uses comobj; var Saved8087CW: Word; PrintingWithOptions: Boolean; InvokingPagesetup: Boolean; MimeFactory, NSFactory: IClassFactory; MimeInternetSession, NSInternetSession: IInternetSession; DontRespond: Boolean; OpenFolder, ExploreFolder: string; FoldersApp, FoldersTopic: string; FindFolder: string; HtmlFileApp, HtmlFileTopic: string; fHtmlCommand: Boolean; {$IFDEF VER120} bMsgHandler: Boolean; {$ENDIF} procedure TEmbeddedWB.GetThumbnail(var Image: TImage); var DrawRect: TRect; begin if Image = nil then exit; DrawRect := Rect(0, 0, Image.Height, Image.width); Image.Picture.Bitmap.Height := image.height; Image.Picture.Bitmap.Width := image.Width; ({$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IviewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0, image.Canvas.Handle, @DrawRect, nil, nil, 0); Image.Refresh; end; procedure TEmbeddedWB.SetfpExceptions(const Value: Boolean); begin if not Value then begin Set8087CW($133F); FfpExceptions := False; end else begin Set8087CW(Saved8087CW); FfpExceptions := True; end; end; { function TEmbeddedwb.GetFrame(FrameNo: Integer): IWebbrowser2; var OleContainer: IOleContainer; enum: IEnumUnknown; unk: IUnknown; Fetched: PLongint; begin while ReadyState <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages; if Assigned(document) then begin Fetched := nil; OleContainer := Document as IOleContainer; OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum); Enum.Skip(FrameNo); Enum.Next(1, Unk, Fetched); Result := Unk as IWebbrowser2; end else Result := nil; end; } { Ver. 1.16: Thanks to Brian Lowe for Fixing OLE-problem in function FrameCount: http://groups.yahoo.com/group/delphi-webbrowser/message/4194 } { function TEmbeddedWB.FrameCount: LongInt; var OleContainer: IOleContainer; enum: IEnumUnknown; unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;" EnumResult: HRESULT; begin while ReadyState <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages; if Assigned(document) then begin OleContainer := Document as IOleContainer; EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum); if EnumResult = S_OK then // Added per OLE help Enum.Next(100, Unk, @Result) else // Added per OLE help Enum := nil; end else Result := 0; end; } procedure TEmbeddedWB.SetUserAgent; var reg: TRegistry; begin Reg := TRegistry.Create; try Reg.RootKey := HKEY_CURRENT_USER; if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings\User Agent\Post Platform', True) then Reg.WriteString(FUserAgent, ''); finally Reg.CloseKey; Reg.Free; end; end; procedure TEmbeddedWB.RemoveUserAgent; var reg: TRegistry; begin Reg := TRegistry.Create; try Reg.RootKey := HKEY_CURRENT_USER; if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings\User Agent\Post Platform', FALSE) then reg.DeleteValue(FUseragent); finally Reg.CloseKey; Reg.Free; end; end; function GetDDEVariables: Boolean; var s: string; Reg: TRegistry; begin Reg := Tregistry.Create; with Reg do try RootKey := HKEY_CLASSES_ROOT; OpenKey('htmlfile\shell\open\ddeexec\application', False); HtmlFileApp := Readstring(''); CloseKey; OpenKey('htmlfile\shell\open\ddeexec\topic', FALSE); HtmlFileTopic := ReadString(''); CloseKey; OpenKey('Folder\shell\open\ddeexec\application', False); FoldersApp := Readstring(''); CloseKey; OpenKey('Folder\shell\open\ddeexec\topic', FALSE); FoldersTopic := ReadString(''); CloseKey; OpenKey('Folder\shell\open\ddeexec', False); s := readString(''); CloseKey; S := Copy(S, Pos('[', S) + 1, length(S)); OpenFolder := Copy(s, 1, Pos('(', S) - 1); OpenKey('Folder\shell\explore\ddeexec', False); s := readString(''); CloseKey; S := Copy(S, Pos('[', S) + 1, length(S)); ExploreFolder := Copy(s, 1, Pos('(', S) - 1); OpenKey('Directory\shell\find\ddeexec', False); s := readString(''); CloseKey; S := Copy(S, Pos('[', S) + 1, length(S)); FindFolder := Copy(s, 1, Pos('(', S) - 1); Result := True; except Result := False; end; Reg.Free; end; function GetCommandTypeFromDDEString(szCommand: string): UINT; begin szCommand := Copy(szCommand, Pos('[', szCommand) + 1, length(szCommand)); szCommand := Copy(szCommand, 1, Pos('(', szCommand) - 1); if szCommand = Openfolder then Result := VIEW_COMMAND else if szCommand = Explorefolder then Result := EXPLORE_COMMAND else if szCommand = Findfolder then Result := FIND_COMMAND else Result := NO_COMMAND; end; function GetPathFromDDEString(szCommand: string; var szFolder: string): Boolean; begin szCommand := Copy(szCommand, Pos('"', szCommand) + 1, length(szCommand)); szFolder := Copy(szCommand, 1, Pos('"', szCommand) - 1); Result := (szFolder <> ''); end; function GetPidlFromDDEString(szCommand: string): PItemIDList; var pidlShared, pidlGlobal: PItemIDList; dwProcessID: Integer; hShared: THandle; s: string; ProcessID: string; i: Integer; begin s := Copy(szCommand, Pos(',', szCommand) + 1, length(szCommand)); i := 1; while not (s[i] in IsDigit) and (i <= Length(s)) do Inc(i); processID := Copy(s, i, Length(S)); s := copy(S, i, length(s) - 1); i := 1; while (s[i] in IsDigit) and (i <= Length(s)) do Inc(i); s := copy(S, 1, i - 1); while not ((ProcessID[i] = ':') or (ProcessID[i] = ',')) and (i <= Length(processID)) do Inc(i); if ProcessID[i] = ':' then begin ProcessID := Copy(ProcessID, i, Length(ProcessID)); i := 1; while not (ProcessID[i] in IsDigit) and (i <= Length(ProcessID)) do Inc(i); ProcessID := Copy(ProcessID, i, Length(ProcessID)); i := 1; while (ProcessID[i] in IsDigit) and (i <= Length(ProcessID)) do Inc(i); if not (ProcessID[i] in IsDigit) then ProcessID := Copy(ProcessID, 1, i - 1); end else ProcessID := '0'; dwProcessID := StrToInt(ProcessID); if dwProcessID <> 0 then begin hShared := StrToInt(s); pidlShared := ShLockShared(hShared, dwProcessId); if PidlShared <> nil then begin Result := CopyPidl(PidlShared); ShUnlockShared(pidlShared); end else Result := nil; ShFreeShared(hShared, dwProcessID); end else begin pidlGlobal := PItemIDList(StrToInt(s)); Result := CopyPidl(pidlGlobal); _Free(pidlGlobal); end; end; function GetShowCmdFromDDEString(szCommand: string): Integer; var i: Integer; begin i := 1; while szCommand[i] <> ',' do Inc(i); Inc(i); while szCommand[i] <> ',' do Inc(i); szCommand := Copy(szCommand, i, Length(szCommand)); i := 0; repeat inc(i) until (i > Length(szCommand)) or (szCommand[i] in IsDigit); if i <= length(szCommand) then result := StrtoInt(szCommand[i]) else result := 1; end; function ParseDDECommand(szCommand: string; var szFolder: string; var pidl: PItemIDList; var show: Integer): UINT; begin Result := GetCommandTypeFromDDEString(szCommand); if Result <> NO_COMMAND then begin GetPathFromDDEString(szCommand, szFolder); pidl := GetPidlFromDDEString(szCommand); Show := GetShowCmdFromDDEString(szCommand); end; end; function TEmbeddedwb.DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL; begin Result := PostMessage(THandle(iwParam), WM_DDE_TERMINATE, handle, 0); end; function TEmbeddedWB.DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT; var dwThreadID: DWORD; dwProcessID: DWORD; hwndClient: Integer; aInApp, aInTopic, aOutApp, aOutTopic: ATOM; szInAppName, szInAppTopic: array[0..255] of Char; begin FillChar(szInAppName, SizeOf(szInAppName), 0); FillChar(szInAppTopic, SizeOf(szInAppTopic), 0); if DontRespond then begin result := 0; exit; end; hwndClient := THandle(iwParam); dwThreadID := GetWindowThreadProcessId(hwndClient, @dwProcessID); if (GetCurrentProcessId() <> dwProcessID) or (GetCurrentThreadID() <> dwThreadID) then begin result := 0; exit; end; aInApp := LOWORD(ilParam); aInTopic := HIWORD(ilParam); GlobalGetAtomName(aInApp, szInAppName, SizeOf(szInAppName)); GlobalGetAtomName(aInTopic, szInAppTopic, SizeOf(szInAppTopic)); if szInAppName = HtmlFileApp then begin fHtmlCommand := True; aOutApp := GlobalAddAtom(PChar(HtmlFileApp)); aOutTopic := GlobalAddAtom(PChar(HtmlFileTopic)); if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then SendMessage(hwndClient, WM_DDE_ACK, WPARAM(handle), MAKELPARAM(aOutApp, aOutTopic)); if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp); if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic); end else begin fHtmlCommand := False; aOutApp := GlobalAddAtom(PChar(FoldersApp)); aOutTopic := GlobalAddAtom(PChar(FoldersTopic)); if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then SendMessage(HWNDClient, WM_DDE_ACK, WPARAM(Handle), MAKELPARAM(aOutApp, aOutTopic)); if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp); if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic); end; result := 0; end; function TEmbeddedwb.DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT; var szFolder: string; szCommand: LPTSTR; uLo: PUINT; hgMem: HGLOBAL; ack: DDEACK; lpTemp: PUINT; uCommand: Cardinal; show: Integer; pidl: PITEMIDLIST; sei: TShellExecuteInfo; szTmp: string; begin ulo := nil; if UnpackDDElParam(WM_DDE_EXECUTE, ilParam, uLo, @hgMem) then begin szCommand := GlobalLock(hgmem); ZeroMemory(@Ack, sizeof(ddeAck)); if (szCommand <> nil) then begin if fHtmlCommand then begin szTmp := szCommand; if Pos('"', szTmp) = 1 then begin Delete(szTmp, 1, 1); szTmp := System.Copy(szTmp, 1, Pos('"', szTmp) - 1); end; Go(szTmp); Ack.flags := 1; end else begin uCommand := ParseDDECommand(szCommand, szFolder, pidl, Show); case uCommand of VIEW_COMMAND: begin if (szFolder <> '') then Go(szFolder) else if (pidl <> nil) then NavigatePidl(pidl); DisposePidl(pidl); Ack.flags := 1; end; EXPLORE_COMMAND: begin DontRespond := TRUE; ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO)); sei.cbSize := sizeof(SHELLEXECUTEINFO); if szFolder <> '' then begin sei.fMask := SEE_MASK_CLASSNAME; sei.lpFile := Pchar(szFolder); end else begin sei.fMask := SEE_MASK_IDLIST or SEE_MASK_CLASSNAME; sei.lpIDList := pidl; end; sei.lpClass := 'folder'; sei.Wnd := 0; sei.nShow := Show; sei.lpVerb := 'explore'; ShellExecuteEx(@sei); DontRespond := FALSE; DisposePidl(pidl); Ack.flags := 1; end; FIND_COMMAND: begin DontRespond := TRUE; ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO)); sei.cbSize := sizeof(SHELLEXECUTEINFO); if (szFolder <> '') then begin sei.fMask := 0; sei.lpFile := PChar(szFolder); end else begin sei.fMask := SEE_MASK_IDLIST; sei.lpIDList := pidl; end; sei.wnd := 0; sei.nShow := Show; sei.lpVerb := 'find'; ShellExecuteEx(@sei); DontRespond := FALSE; DisposePidl(pidl); Ack.flags := 1; end; end; end; GlobalUnlock(hgMem); lpTemp := @Ack; PostMessage(Thandle(iwParam), WM_DDE_ACK, WPARAM(handle), ReuseDDElParam(ilParam, WM_DDE_EXECUTE, WM_DDE_ACK, lpTemp^, hgMem)); end; end; Result := 0; end; procedure TEmbeddedwb.PrintWithOptions; begin PrintingWithOptions := True; Pagesetup(TRUE); Print; end; procedure TembeddedWB.GetPrintValues; var S: string; regWinRegistry: TRegistry; function ReadMargin(key: string): Real; begin S := RegwinRegistry.ReadString(key); S := Stringreplace(S, ' ', '', [rfReplaceAll]); if DecimalSeparator <> '.' then S := Stringreplace(S, '.', DecimalSeparator, []); if Printoptions.Measure = mMetric then result := StrtoFloatDef(S, 0.75) * InchToMetric else result := StrtoFloatDef(S, 0.75); end; begin regWinRegistry := TRegistry.Create; try with regWinRegistry do begin RootKey := HKEY_CURRENT_USER; if OpenKey('Software\Microsoft\Internet Explorer\PageSetup', False) then begin PrintOptions.Header := Readstring('header'); PrintOptions.Footer := ReadString('footer'); PrintOptions.Margins.left := ReadMargin('margin_left'); PrintOptions.Margins.right := ReadMargin('margin_right'); PrintOptions.Margins.top := ReadMargin('margin_top'); PrintOptions.Margins.bottom := ReadMargin('margin_bottom'); end; end; finally regWinRegistry.Free; end; end; procedure TEmbeddedWB.Loaded; begin inherited Loaded; CoInternetCreateSecuritymanager(self, SecurityManager, 0); CoInternetCreateZoneManager(self, ZoneManager, 0); UpdateDownloadControlValue; UpdateUserInterfaceValue; hook; if not (csDesigning in ComponentState) then begin OldWBWndProc := WindowProc; WindowProc := WBWndProc; SetUserAgent; end else begin PrintOptions.FMeasure := RunTimeMeasure; GetPrintValues; end; end; function TEmbeddedWB.PrintMarginStr(M: Real): PChar; var S: string; begin if printOptions.Measure <> RuntimeMeasure then begin if RuntimeMeasure = mMetric then s := FloatToStr(M * InchToMetric) else s := FloatToStr(M / InchToMetric); if s = '' then s := '1.00'; Result := PChar(S); end else Result := PChar(FloatToStr(M)); end; constructor TEmbeddedWb.Create(Owner: TComponent); var Buf: array[1..10] of Char; begin FfpExceptions := True; inherited; {$IFDEF VER120} enablemessagehandler; {$ENDIF} GetDDEVariables; DDEHWnd := AllocateHWnd(DDEWndProc); FPrintOptions := TPrintOptions.Create; FPrintOptions.Margins := TMargins.Create; FPrintOptions.FHTMLHeader := TStringlist.Create; FPrintOptions.FHTMLHeader.Add(''); FillChar(Buf, SizeOf(Buf), 0); GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, @Buf[1], SizeOf(Buf)); if Buf[1] = '1' then RunTimeMeasure := mUS else RunTimeMeasure := mMetric; DownloadOptions := [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS]; UserInterfaceOptions := []; FEnableDDE := False; end; destructor TEmbeddedWb.Destroy; begin DeAllocateHWnd(DDEHwnd); FPrintOptions.HTMLHeader.Free; FPrintoptions.Margins.Free; FPrintoptions.Free; unhook; RemoveUserAgent; {$IFDEF VER120} disablemessagehandler; {$ENDIF} inherited; end; function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT; begin CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory); CoInternetGetSession(0, MimeInternetSession, 0); Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME); end; function UnregisterMIMEFilter(MIME: PWideChar): HRESULT; begin Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME); end; function RegisterNameSpace(clsid: TGUID): HRESULT; begin CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory); CoInternetGetSession(0, NSInternetSession, 0); Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0); end; function UnregisterNameSpace: HRESULT; begin Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http'); end; procedure TEmbeddedWB.Hook; begin if (csDesigning in ComponentState) then exit; FParentform := TForm(Owner); if (FParentForm <> nil) and (FParentForm.HandleAllocated) then begin FOldWindowProc := FParentForm.WindowProc; FParentForm.WindowProc := FormWndProc; end; end; procedure TEmbeddedWB.UnHook; begin if (csDesigning in ComponentState) then exit; if (FParentForm <> nil) and (FParentForm.HandleAllocated) then FParentForm.WindowProc := FOldWindowProc; // FOldWindowProc := nil; FParentform := nil; end; procedure TEmbeddedWB.DDEWndProc(var AMsg: TMessage); begin with AMsg do if (Msg = WM_DDE_INITIATE) and FEnableDDE then DDEInitiate(wparam, lparam) else Result := DefWindowProc(DDEHWND, msg, wParam, lParam); end; procedure TEmbeddedWB.FormWndProc(var AMsg: TMessage); var i: Integer; wnd: Integer; S: string; Msg: TWmActivate; begin if AMsg.Msg = WM_ACTIVATE then begin Msg := TWmActivate(AMsg); if Msg.Active = 0 then begin wnd := Msg.ActiveWindow; SetLength(S, 80); SetLength(S, GetClassName(Wnd, PChar(S), Length(S))); if (S = '#32770') then begin if ReplaceCaption then begin SendMessage(wnd, WM_SETICON, ICON_SMALL, Forms.Application.Icon.Handle); I := GetWindowTextLength(wnd); SetLength(S, I + 1); GetWindowText(Wnd, PChar(S), I + 1); S := StringReplace(S, 'Microsoft ', '', []); S := StringReplace(S, 'Internet Explorer', Forms.Application.Title, []); SetWindowText(Wnd, Pchar(S)); end; if InvokingPageSetup then begin InvokingPagesetup := False; if PrintingWithOptions then begin SetWindowPos(Wnd, 0, -600, 0, 0, 0, 0); PrintingWithOptions := False; end; if PrintOptions.Orientation = poPortrait then SendDlgItemMessage(Wnd, $0420, BM_CLICK, 0, 0) else SendDlgItemMessage(Wnd, $0421, BM_CLICK, 0, 0); SetDlgItemText(wnd, $1FD3, PChar(PrintOptions.Header)); SetDlgItemText(wnd, $1FD5, PChar(PrintOptions.Footer)); SetDlgItemText(wnd, $0483, PrintMarginStr(PrintOptions.Margins.Left)); SetDlgItemText(wnd, $0484, PrintMarginStr(PrintOptions.Margins.top)); SetDlgItemText(wnd, $0485, PrintMarginStr(PrintOptions.Margins.Right)); SetDlgItemText(wnd, $0486, PrintMarginStr(PrintOptions.Margins.Bottom)); if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4) then PostMessage(FindWindowEx(wnd, 0, Pchar('Button'), nil), BM_CLICK, 0, 0) //Win2000 else SendDlgItemMessage(Wnd, 1, BM_CLICK, 0, 0); end; end; if not PrintingWithOptions and (wnd <> 0) and Assigned(FOnShowDialog) then FOnShowDialog(self, Wnd); end; end; FOldWindowProc(AMsg); end; function TEmbeddedWB.QueryService(const rsid, iid: TGuid; out Obj): HResult; begin if Assigned(FOnQueryService) then Result := FOnQueryService(rsid, iid, IUnknown(obj)) else Result := E_NOINTERFACE; end; function TEmbeddedWB.ShowMailClient: Boolean; begin result := OpenClient('Mail'); end; function TEmbeddedWB.ShowNewsClient: Boolean; begin result := OpenClient('News'); end; function TEmbeddedWB.ShowAddressBook: Boolean; begin result := OpenClient('Contacts'); end; function TEmbeddedWB.ShowCalendar: Boolean; begin result := OpenClient('Calendar'); end; function TEmbeddedWB.ShowInternetCall: Boolean; begin result := OpenClient('Internet Call'); end; function TEmbeddedWB.OpenClient(Client: string): Boolean; var s, params, Exec: string; begin Result := FALSE; with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; OpenKey('Software\Clients\' + Client, FALSE); S := ReadString(''); CloseKey; OpenKey('Software\Clients\' + Client + '\' + S + '\shell\open\command', FALSE); S := ReadString(''); CloseKey; if S <> '' then begin if Pos('/', S) > 0 then begin Exec := system.Copy(S, 1, Pos('/', S) - 2); Params := system.Copy(s, Length(exec) + 1, length(S)); end else begin Exec := S; Params := ''; end; Result := TRUE; shellExecute(handle, 'open', Pchar(Exec), pChar(Params), '', SW_SHOW); end; finally Free; end; end; procedure TEmbeddedWB.PrintPreView; // IE 5.5 only var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.SetDownloadOptions(const Value: TDownloadControlOptions); begin FDownloadControlOptions := Value; UpdateDownloadControlValue; {$IFDEF VER120} (Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); {$ELSE} (Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); {$ENDIF} end; procedure TEmbeddedWB.SetUserInterfaceOptions(const Value: TUserInterfaceOptions); begin FUserInterfaceOptions := Value; UpdateUserInterfaceValue; {$IFDEF VER120} (Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); {$ELSE} (Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); {$ENDIF} end; procedure TEmbeddedWB.UpdateDownloadControlValue; 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 i: TDownloadControlOption; begin FDownloadOptionValue := 0; if (FDownloadControlOptions <> []) then for i := Low(TDownloadControlOption) to High(TDownloadControlOption) do if (i in FDownloadControlOptions) then Inc(FDownloadOptionValue, acardDownloadControlValues[i]); end; procedure TEmbeddedWB.UpdateUserInterfaceValue; 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); var i: TUserInterfaceOption; begin FUserInterfaceValue := 0; if (FUserInterfaceOptions <> []) then for i := Low(TUserInterfaceOption) to High(TUserInterfaceOption) do if (i in FUserInterfaceOptions) then Inc(FUserInterfaceValue, acardUserInterfaceValues[i]); end; function TEmbeddedWB.IsGlobalOffline: boolean; var dwState: DWORD; dwSize: DWORD; begin dwState := 0; dwSize := SizeOf(dwState); result := false; if (InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwState, dwSize)) then if ((dwState and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0) then result := true; end; procedure TEmbeddedWB.SetGlobalOffline(Value: Boolean); const INTERNET_STATE_DISCONNECTED_BY_USER = $10; ISO_FORCE_DISCONNECTED = $1; INTERNET_STATE_CONNECTED = $1; var ci: TInternetConnectedInfo; dwSize: DWORD; begin dwSize := SizeOf(ci); if (Value) then begin ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER; ci.dwFlags := ISO_FORCE_DISCONNECTED; end else begin ci.dwFlags := 0; ci.dwConnectedState := INTERNET_STATE_CONNECTED; end; InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, dwSize); end; function SaveDocToStream(Doc: IDispatch; var AStream: TStream): HResult; var IpStream: IPersistStreamInit; begin if Doc <> nil then begin IpStream := Doc as IPersistStreamInit; Result := IpStream.save(TStreamAdapter.Create(AStream), TRUE); end else Result := S_FALSE; end; function TEmbeddedWB.SaveToStream(AStream: TStream): HRESULT; begin while ReadyState <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages; if Assigned(Document) then Result := SaveDocToStream(Document, AStream) else Result := S_FALSE; end; function SaveDocToStrings(Doc: IDispatch; var AStrings: TStrings): HResult; var IpStream: IPersistStreamInit; AStream: TMemoryStream; begin AStream := TMemoryStream.Create; try IpStream := doc as IPersistStreamInit; if not Assigned(IpStream) then Result := S_FALSE else if Succeeded(IpStream.save(TStreamadapter.Create(AStream), TRUE)) then begin AStream.Seek(0, 0); AStrings.LoadFromStream(AStream); Result := S_OK; end else Result := S_FALSE; except Result := S_FALSE; end; AStream.Free; end; { function TEmbeddedwb.SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT; var iw: IWebbrowser2; begin Result := S_FALSE; iw := Getframe(frameNo); if (iw <> nil) and assigned(iw.Document) then Result := SaveDocToStream(iw.Document, AStream) end; function TEmbeddedwb.SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT; var iw: Iwebbrowser2; begin Result := S_FALSE; iw := Getframe(frameNo); if (iw <> nil) and assigned(iw.Document) then Result := SaveDocToStrings(iw.Document, AStrings); end; function TEmbeddedwb.SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT; var Iw: IWebbrowser2; PFile: IPersistFile; begin iw := Getframe(frameNo); if (iw <> nil) and assigned(iw.Document) then begin PFile := iw.Document as IPersistFile; Result := PFile.Save(StringToOleStr(FName), False); end else Result := S_FALSE; end; } function SaveDocToFile(Doc: IDispatch; const Fname: string): HResult; var PFile: IPersistFile; begin PFile := Doc as IPersistFile; Result := PFile.Save(StringToOleStr(FName), False); end; function TEmbeddedWB.SaveToFile(const Fname: string): HRESULT; begin while ReadyState <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages; if Assigned(Document) then begin Result := SaveDocToFile(Document, FName); end else Result := S_FALSE; end; function TEmbeddedWB.SaveToStrings(AStrings: TStrings): HRESULT; begin while ReadyState <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages; if Assigned(document) then Result := SaveDocToStrings(Document, AStrings) else Result := S_FALSE; end; { function TEmbeddedWb.LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult; var iw: IWebbrowser2; M: TMemoryStream; begin Result := S_FALSE; iw := GetFrame(Frameno); if (iw <> nil) and assigned(iw.document) then begin M := TMemoryStream.Create; try AStrings.SaveToStream(M); M.seek(0, 0); Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(M)); except Result := S_FALSE; end; M.free; end; end; } function TEmbeddedWb.LoadFromStrings(const AStrings: TStrings): HResult; var M: TMemoryStream; begin if not Assigned(document) then AssignDocument; M := TMemoryStream.Create; try AStrings.SaveToStream(M); Result := LoadFromStream(M); except Result := S_FALSE; end; M.free; end; { function TEmbeddedWb.LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT; var iw: IWebbrowser2; begin Result := S_FALSE; iw := Getframe(frameNo); if (iw <> nil) then if Assigned(iw.Document) then begin AStream.seek(0, 0); Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream)); end; end; } function TEmbeddedWb.LoadFromStream(const AStream: TStream): HRESULT; begin if not Assigned(Document) then AssignDocument; AStream.seek(0, 0); Result := (Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream)); end; procedure TEmbeddedWb.AssignDocument; begin Go('about:blank'); while readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages; end; procedure TEmbeddedWb.SetFocusToDoc; begin if Document <> nil then with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IOleobject do DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0, Handle, GetClientRect); end; {$IFDEF VER120} procedure TEmbeddedWb.EnableMessagehandler; begin if not bMsgHandler then begin SaveMessage := Forms.Application.OnMessage; Forms.Application.OnMessage := IeMessagehandler; bMsgHandler := True; end; end; procedure TEmbeddedWB.DisableMessageHandler; begin if bMsgHandler then begin Forms.Application.onMessage := Savemessage; bMsgHandler := False; end; end; {$ENDIF} ///BEGIN >>>>> Messagehandler by Mathias Walter - walter@coint.de >>>>>/// procedure TEmbeddedWB.WBWndProc(var Message: TMessage); const StdKeys = [VK_RETURN, VK_BACK]; { standard keys } ExtKeys = [VK_LEFT, VK_RIGHT]; { extended keys } fExtended = $01000000; { extended key flag } var bClose: Boolean; {$IFNDEF VER120} WinMsg: TMsg; {$ENDIF} begin with Message do begin {$IFNDEF VER120} if (Msg >= (CN_BASE + WM_KEYFIRST)) and (Msg <= (CN_BASE + WM_DEADCHAR)) then begin WinMsg.hwnd := Handle; WinMsg.message := Msg - CN_BASE; WinMsg.wParam := wParam; WinMsg.lParam := lParam; WinMsg.time := GetMessageTime; WinMsg.pt.x := $115DE1F1; WinMsg.pt.y := $115DE1F1; if not ((wParam in StdKeys) or (wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then with Application as IOleInPlaceActiveObject do Result := Integer(TranslateAccelerator(WinMsg) = S_OK); end else {$ENDIF} case Msg of WM_CLOSE: begin bClose := True; if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, bClose); if bClose then OldWBWndProc(Message); end; WM_DDE_EXECUTE: DDEExecute(wparam, lparam); WM_DDE_TERMINATE: DDETerminate(wparam, lparam); else OldWBWndProc(Message); end; end; end; {$IFDEF VER120} procedure TEmbeddedWB.IEMessageHandler(var Msg: TMsg; var Handled: Boolean); { fixes the malfunction of some keys within webbrowser control } const StdKeys = [VK_TAB, VK_RETURN]; { standard keys } ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys } fExtended = $01000000; { extended key flag } begin Handled := False; with Msg do if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and ((wParam in StdKeys) or (GetKeyState(VK_CONTROL) < 0) or (wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then try if IsChild(Handle, hWnd) then { handles all browser related messages } begin with Application_ as IOleInPlaceActiveObject do Handled := TranslateAccelerator(Msg) = S_OK; if not Handled then begin Handled := True; TranslateMessage(Msg); DispatchMessage(Msg); end; end; except end; end; // IEMessageHandler {$ENDIF} ///END <<<<<< Messagehandler by Mathias Walter - walter@coint.de <<<< nil) then begin CopyMemory(psa.pvData, pidl, cbData); VariantInit(vaPidl); TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1; TVariantArg(vaPidl).parray := psa; Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty); VariantClear(vaPidl); end; end; procedure TEmbeddedWB.Go(Url: string); var _URL, Flags, TargetFrameName, PostData, Headers: Olevariant; begin _URL := Url; Flags := 0; TargetFrameName := 0; Postdata := 0; Headers := 0; Navigate2(_URL, Flags, TargetFrameName, PostData, Headers); end; procedure TEmbeddedWB.InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant); var CmdTarget: IOleCommandTarget; PtrGUID: PGUID; begin New(PtrGUID); if InvokeIE then PtrGUID^ := CLSID_WebBrowser else PtrGuid := PGUID(nil); if Document <> nil then try Document.QueryInterface(IOleCommandTarget, CmdTarget); if CmdTarget <> nil then try CmdTarget.Exec(PtrGuid, Value1, Value2, vaIn, vaOut); finally CmdTarget._Release; end; except end; Dispose(PtrGUID); end; procedure TEmbeddedWB.Print; var vaIn, vaOut: Olevariant; HtmlText: string; Stream: IStream; Dummy: Int64; Psa: PSafeArray; begin HtmlText := PrintOptions.HtmlHeader.Text; CreateStreamOnHGlobal(0, TRUE, Stream); Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy); Stream.Seek(0, STREAM_SEEK_SET, Dummy); SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa); TVarData(VaIn).VType := varArray or varByRef; SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray)); InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); end; procedure TEmbeddedWB.PrintSetup; var vaIn, vaOut: Olevariant; HtmlText: string; Stream: IStream; Dummy: Int64; Psa: PSafeArray; begin HtmlText := PrintOptions.HtmlHeader.Text; CreateStreamOnHGlobal(0, TRUE, Stream); Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy); Stream.Seek(0, STREAM_SEEK_SET, Dummy); SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa); TVarData(VaIn).VType := varArray or varByRef; SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray)); InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut); end; procedure TEmbeddedWB.PageSetup(UsePrintOptions: Boolean); var vaIn, vaOut: Olevariant; begin if UsePrintOptions then InvokingPageSetup := True; InvokeCmd(FALSE, OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.OpenDialog; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.SaveDialog; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.ViewSource; var vaIn, vaOut: Olevariant; begin InvokeCmd(TRUE, HTMLID_VIEWSOURCE, 0, vaIn, vaOut); end; procedure TEmbeddedWB.Options; var vaIn, vaOut: Olevariant; begin InvokeCmd(TRUE, HTMLID_OPTIONS, 0, vaIn, vaOut); end; procedure TEmbeddedWB.Properties; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.Find; var vaIn, vaOut: Olevariant; begin InvokeCmd(TRUE, HTMLID_FIND, 0, vaIn, vaOut); end; procedure TEmbeddedWB.Copy; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.SelectAll; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut); end; procedure TEmbeddedWB.Zoom(ZoomValue: Integer); var vaIn, vaOut: Olevariant; begin if ZoomValue < ZoomRangeLow then vaIn := ZoomRangeLow else if ZoomValue > ZoomRangeHigh then vaIn := ZoomRangeHigh else vaIn := ZoomValue; InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); end; function TEmbeddedWB.ZoomRangeLow: Integer; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); result := LoWord(Dword(vaOut)); end; function TEmbeddedWB.ZoomRangeHigh: Integer; var vaIn, vaOut: Olevariant; begin InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); result := HiWord(Dword(vaOut)); end; function TEmbeddedWB.ZoomValue: Integer; var vaIn, vaOut: Olevariant; begin vaIn := null; InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); result := vaOut; end; // IDOCHOSTUIHANDLER function TEmbeddedWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; begin if Assigned(FOnShowContextmenu) then RESULT := FOnSHowContextmenu(dwID, ppt, pcmdtreserved, pdispreserved) else RESULT := S_FALSE; end; function TEmbeddedWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; begin pInfo.cbSize := SizeOf(pInfo); pInfo.dwFlags := FUserInterfaceValue; pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT; if Assigned(FOnGetHostInfo) then Result := FOnGetHostInfo(pInfo) else Result := S_OK; end; function TEmbeddedWB.ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT; begin if Assigned(FOnShowUI) then Result := FOnShowUI(dwID, pActiveObject, pCommandTarget, pFrame, pDoc) else Result := S_FALSE; end; function TEmbeddedWB.HideUI: HRESULT; begin if Assigned(FOnHideUI) then Result := FOnHideUI else Result := S_FALSE; end; function TEmbeddedWB.UpdateUI: HRESULT; begin if Assigned(FOnUpdateUI) then Result := FOnUpdateUI else Result := S_FALSE; end; function TEmbeddedWB.EnableModeless(const fEnable: BOOL): HRESULT; begin if Assigned(FOnEnableModeless) then Result := FOnEnableModeless(fEnable) else Result := S_FALSE; end; function TEmbeddedWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT; begin if Assigned(FOnOnDocWindowActivate) then Result := FOnOnDocWindowActivate(fActivate) else Result := S_FALSE; end; function TEmbeddedWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT; begin if Assigned(FOnOnFrameWindowActivate) then Result := FOnOnFrameWindowActivate(fActivate) else Result := S_FALSE; end; function TEmbeddedWB.ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT; begin if Assigned(FOnResizeBorder) then Result := FOnResizeBorder(prcBorder, pUIWindow, fRameWindow) else Result := S_FALSE; end; function TEmbeddedWB.TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT; begin if Assigned(FOnTranslateAccelerator) then Result := FOnTranslateAccelerator(lpMsg, pguidCmdGroup, nCmdID) else Result := S_FALSE; end; function TEmbeddedWB.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; begin if Assigned(FOnGetOptionKeyPath) then Result := FOnGetOptionKeyPath(pchKey, dw) else Result := S_FALSE; end; function TEmbeddedWB.GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; begin if Assigned(FOnGetDropTarget) then Result := FOnGetDropTarget(pDropTarget, ppDropTarget) else Result := S_OK; end; function TEmbeddedWB.GetExternal(out ppDispatch: IDispatch): HRESULT; begin if Assigned(FOnGetExternal) then Result := FOnGetExternal(ppDispatch) else Result := S_FALSE; end; function TEmbeddedWB.TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; begin if Assigned(FOnTranslateUrl) then Result := FOnTranslateUrl(dwTranslate, pchUrlIn, ppchUrlOut) else Result := S_FALSE; end; function TEmbeddedWB.FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; begin if Assigned(FOnFilterDataObject) then Result := FOnFilterDataObject(pDO, ppDORet) else Result := S_FALSE; end; // IDOCHOSTSHOWUI function TEmbeddedWB.ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR; dwHelpContext: longint; var plResult: LRESULT): HRESULT; begin if Assigned(FOnShowMessage) then Result := FOnShowMessage(hwnd, lpstrText, lpStrCaption, dwType, lpStrHelpFile, dwHelpContext, plResult) else Result := S_FALSE; end; function TEmbeddedWB.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer; dwData: longint; ptMouse: TPoint; var pDispatchObjectHit: IDispatch): HRESULT; begin Result := S_OK; if Assigned(FOnShowHelp) then Result := FOnShowHelp(hwnd, pszHelpFile, uCommand, dwData, ptMouse, pDispatchObjectHit) else if FHelpFile <> '' then HtmlHelp(hwnd, Pchar(FHelpFile), ucommand, dwData) else Result := S_FALSE; end; // IDISPATCH methods function TEmbeddedWB.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin if Assigned(FOnGetIdsofNames) then Result := FOnGetIdsofNames(IID, Names, NameCount, LocaleID, DispIds) else result := E_NotImpl; end; function TEmbeddedWB.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin if Assigned(FOnGetTypeInfo) then Result := FOnGetTypeInfo(Index, LocaleID, ITypeInfo(TypeInfo)) else begin Result := E_NOTIMPL; pointer(TypeInfo) := nil; end; end; function TEmbeddedWB.GetTypeInfoCount(out Count: Integer): HResult; begin if Assigned(FOnGetTypeInfoCount) then Result := FOnGetTypeInfoCount(Count) else begin Result := E_NOTIMPL; Count := 0; end; end; function TEmbeddedWB.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; begin Result := S_OK; if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) and (DispId = DISPID_AMBIENT_DLCONTROL) then PVariant(VarResult)^ := FDownloadOptionValue else if Assigned(FOnInvoke) then Result := FOnInvoke(DispId, IID, LocaleID, Flags, TagDispParams(Params), VarResult, ExcepInfo, ArgErr) else Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); end; procedure Register; begin RegisterComponents({$IFDEF VER120} 'ActiveX'{$ELSE} 'Internet'{$ENDIF}, [TEmbeddedWB]); end; { TPrintOptions } procedure TPrintOptions.SetHTMLHeader(const Value: Tstrings); begin FHTMLHeader.Assign(Value); end; function DeleteFirstCacheEntry(var H: THandle): DWORD; var T: PInternetCacheEntryInfo; D: DWord; begin Result := S_OK; H := 0; D := 0; FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, nil, @D, nil, nil, nil); GetMem(T, D); try H := FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, T, @D, nil, nil, nil); if (H = 0) then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname); finally FreeMem(T, D) end; end; function DeleteNextCacheEntry(H: THandle): DWORD; var T: PInternetCacheEntryInfo; D: DWORD; begin Result := S_OK; D := 0; FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil); GetMem(T, D); try if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil) then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname); finally FreeMem(T, D) end; end; procedure TEmbeddedWB.ClearCache; var H: THandle; begin if DeleteFirstCacheEntry(H) = S_OK then repeat until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS; FindCloseUrlCache(H) end; procedure TEmbeddedWB.ClearHistory; var HistoryStg: IUrlHistoryStg2; begin HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2; HistoryStg.ClearHistory; end; function TEmbeddedWB.GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; begin if Assigned(FOnGetOverrideKeyPath) then RESULT := FOnGetOverrideKeyPath(pchkey, dw) else Result := S_OK; end; {$IFDEF USE_IOLECOMMANDTARGET} function TEmbeddedWB.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD; const vaIn: OleVariant; var vaOut: OleVariant): HResult; var FCancel, FContinueScript, FShowDialog: Boolean; pEventObj: IHTMLEventObj; 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 := pEventObj.GetIDsOfNames(GUID_NULL, @PPropname, 1, LOCALE_SYSTEM_DEFAULT, @Disp); if Status = 0 then begin Status := pEventObj.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'' not supported.', [PropName]) else OleCheck(Status); end; begin if (CmdGroup = nil) then begin Result := OLECMDERR_E_UNKNOWNGROUP; exit; end; Result := OLECMDERR_E_NOTSUPPORTED; if (ncmdID = OLECMDID_ONUNLOAD) and IsEqualGuid(cmdGroup^, CGID_EXPLORER) and Assigned(FOnUnload) then FOnUnload(Self); if IsEqualGuid(cmdGroup^, CGID_DocHostCommandHandler) then begin if Assigned(FOnRefresh) and ((nCmdID = 6041 {F5}) or (nCmdID = 6042 {ContextMenu}) or (nCmdID = 2300)) then begin FCancel := False; FOnRefresh(self, nCmdID, FCancel); if FCancel then Result := S_OK; end else case nCmdID of OLECMDID_SHOWSCRIPTERROR: if Assigned(FOnScriptError) then begin pEventObj := (Document as IHTMLDocument2).parentWindow.event; if pEventObj <> nil then begin FContinueScript := True; FShowDialog := True; FOnScriptError(self, GetProperty('errorline'), GetProperty('errorCharacter'), GetProperty('errorCode'), GetProperty('errorMessage'), GetProperty('errorUrl'), FContinueScript, FShowDialog); TVariantArg(vaOut).vt := VT_BOOL; TVariantArg(vaOut).vbool := FContinueScript; if not FShowDialog then Result := S_OK; end; end; end; end; end; function TEmbeddedWB.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd; CmdText: POleCmdText): HResult; begin result := S_OK; end; {$ENDIF} initialization Saved8087CW := Default8087CW; {$IFDEF VER120} bMsgHandler := False; {$ENDIF} OleInitialize(nil); finalization Set8087CW(Saved8087CW); try OleUninitialize; except end; end.