mirror of
https://github.com/HeidiSQL/HeidiSQL.git
synced 2025-08-06 18:24:26 +08:00
751 lines
27 KiB
ObjectPascal
751 lines
27 KiB
ObjectPascal
//**************************************************************************************************
|
|
//
|
|
// Unit Vcl.Styles.WebBrowser
|
|
// unit for the VCL Styles Utils
|
|
// https://github.com/RRUZ/vcl-styles-utils/
|
|
//
|
|
// The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");
|
|
// you may not use this file except in compliance with the License. You may obtain a copy of the
|
|
// License at http://www.mozilla.org/MPL/
|
|
//
|
|
// Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
|
|
// ANY KIND, either express or implied. See the License for the specific language governing rights
|
|
// and limitations under the License.
|
|
//
|
|
// The Original Code is Vcl.Styles.WebBrowser.pas.
|
|
//
|
|
// The Initial Developer of the Original Code is Rodrigo Ruz V.
|
|
// Portions created by Rodrigo Ruz V. are Copyright (C) 2012-2015 Rodrigo Ruz V.
|
|
// All Rights Reserved.
|
|
//
|
|
//**************************************************************************************************
|
|
unit Vcl.Styles.WebBrowser;
|
|
|
|
interface
|
|
//Uncomment this option if you want which the TVclStylesWebBrowser class hook the dialogs messages directly.
|
|
{.$DEFINE HOOKDialogs}
|
|
uses
|
|
System.Classes,
|
|
WinApi.Windows,
|
|
WinApi.Messages,
|
|
WinApi.Activex,
|
|
Vcl.Forms,
|
|
Vcl.OleServer,
|
|
Vcl.Graphics,
|
|
Vcl.Controls,
|
|
Vcl.StdCtrls,
|
|
SHDocVw;
|
|
|
|
|
|
type
|
|
|
|
TDocHostUIInfo = record
|
|
cbSize: ULONG;
|
|
dwFlags: DWORD;
|
|
dwDoubleClick: DWORD;
|
|
pchHostCss: PWChar;
|
|
pchHostNS: PWChar;
|
|
end;
|
|
|
|
{$IFDEF HOOKDialogs}
|
|
//http://msdn.microsoft.com/en-us/library/aa753269%28v=vs.85%29.aspx
|
|
IDocHostShowUI = interface(IUnknown)
|
|
['{c4d244b0-d43e-11cf-893b-00aa00bdce1a}']
|
|
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 pDispachObjectHit: IDispatch): HRESULT; stdcall;
|
|
end; // IDocHostShowUI
|
|
{$ENDIF}
|
|
|
|
//http://msdn.microsoft.com/en-us/library/aa753260%28v=vs.85%29.aspx
|
|
IDocHostUIHandler = interface(IUnknown)
|
|
['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}']
|
|
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;
|
|
end;
|
|
|
|
|
|
TVclStylesWebBrowser = class(SHDocVw.TWebBrowser, IDocHostUIHandler{$IFDEF HOOKDialogs},IDocHostShowUI{$ENDIF}, IOleCommandTarget)
|
|
strict private
|
|
type
|
|
TWinContainer = class(TWinControl)
|
|
procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
|
|
end;
|
|
|
|
var
|
|
FLSM_CXHTHUMB : Integer;
|
|
FLSM_CYVTHUMB : Integer;
|
|
FVScrollBar : TScrollBar;
|
|
FHScrollBar : TScrollBar;
|
|
FVScrollBarContainer : TWinContainer;
|
|
FHScrollBarContainer : TWinContainer;
|
|
FScrollCornerContainer : TWinContainer;
|
|
procedure CMVisibleChanged(var MSg: TMessage); message CM_VISIBLECHANGED;
|
|
procedure ResizeScrollBars;
|
|
procedure VScrollChange(Sender: TObject);
|
|
procedure HScrollChange(Sender: TObject);
|
|
function GetIEHandle : HWND;
|
|
|
|
procedure DoDocumentComplete(Sender: TObject;const pDisp: IDispatch; const URL: OleVariant);
|
|
procedure DoNavigateComplete2(Sender: TObject;const pDisp: IDispatch;const URL: OleVariant);
|
|
procedure DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
|
|
procedure DoCommandStateChange(Sender: TObject; Command: Integer; Enable: WordBool);
|
|
procedure DoProgressChange(Sender: TObject; Progress, ProgressMax: Integer);
|
|
private
|
|
FCustomizeJSErrorDialog: Boolean;
|
|
FCustomizeStdDialogs: Boolean;
|
|
FUseVClStyleBackGroundColor: Boolean;
|
|
//IDocHostUIHandler
|
|
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;
|
|
{$IFDEF HOOKDialogs}
|
|
// IDocHostShowUI
|
|
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 pDispachObjectHit: IDispatch): HRESULT; stdcall;
|
|
//IOleCommandTarget
|
|
{$ENDIF}
|
|
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;
|
|
//procedure SetZOrder(TopMost: Boolean); override;
|
|
protected
|
|
procedure InvokeEvent(DispID: TDispID; var Params: TDispParams);override;
|
|
procedure SetParent(AParent: TWinControl); override;
|
|
procedure Loaded; override;
|
|
procedure WMSIZE(var Message: TWMSIZE); message WM_SIZE;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
property CustomizeStdDialogs : Boolean read FCustomizeStdDialogs write FCustomizeStdDialogs;
|
|
property CustomizeJSErrorDialog : Boolean read FCustomizeJSErrorDialog write FCustomizeJSErrorDialog;
|
|
property UseVClStyleBackGroundColor : Boolean read FUseVClStyleBackGroundColor write FUseVClStyleBackGroundColor;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
|
|
uses
|
|
MSHTML,
|
|
System.UITypes,
|
|
System.Sysutils,
|
|
System.Win.ComObj,
|
|
Vcl.Dialogs,
|
|
Vcl.Themes,
|
|
Vcl.Styles;
|
|
|
|
|
|
|
|
const
|
|
//About Scroll Bars
|
|
//http://msdn.microsoft.com/en-us/library/windows/desktop/bb787527%28v=vs.85%29.aspx
|
|
|
|
//MSDN WebBrowser Customization
|
|
//http://msdn.microsoft.com/en-us/library/aa770041%28v=vs.85%29.aspx
|
|
//MSDN WebBrowser Customization (Part 2)
|
|
//http://msdn.microsoft.com/en-us/library/aa770042%28v=vs.85%29.aspx
|
|
|
|
//How to customize the TWebBrowser user interface
|
|
//http://www.delphidabbler.com/articles?article=18&part=1
|
|
//TEmbeddedWB OnGetHostInfo
|
|
//http://www.bsalsa.com/ewb_on_get_host.html
|
|
|
|
|
|
|
|
//http://msdn.microsoft.com/en-us/library/aa753277%28v=vs.85%29.aspx
|
|
DOCHOSTUIFLAG_FLAT_SCROLLBAR = $00000080;
|
|
DOCHOSTUIFLAG_SCROLL_NO = $00000008;
|
|
DOCHOSTUIFLAG_NO3DBORDER = $00000004;
|
|
DOCHOSTUIFLAG_DIALOG = $00000001;
|
|
DOCHOSTUIFLAG_THEME = $00040000;
|
|
DOCHOSTUIFLAG_NOTHEME = $00080000;
|
|
|
|
//Set background to vcl styles windows color.
|
|
procedure TVclStylesWebBrowser.TWinContainer.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
|
|
var
|
|
Details: TThemedElementDetails;
|
|
LCanvas: TCanvas;
|
|
begin
|
|
LCanvas := TCanvas.Create;
|
|
try
|
|
LCanvas.Handle := Msg.DC;
|
|
Details.Element := teWindow;
|
|
Details.Part := 0;
|
|
StyleServices.DrawElement(LCanvas.Handle, Details, ClientRect);
|
|
finally
|
|
LCanvas.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
constructor TVclStylesWebBrowser.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FLSM_CXHTHUMB:=GetSystemMetrics(SM_CXHTHUMB);
|
|
FLSM_CYVTHUMB:=GetSystemMetrics(SM_CYVTHUMB);
|
|
|
|
FVScrollBarContainer := nil;
|
|
FHScrollBarContainer := nil;
|
|
|
|
FScrollCornerContainer := TWinContainer.Create(Self);
|
|
FScrollCornerContainer.Visible := False;
|
|
|
|
FVScrollBarContainer := TWinContainer.Create(Self);
|
|
FVScrollBarContainer.Visible := True;
|
|
FVScrollBar := TScrollBar.Create(Self);
|
|
FVScrollBar.Parent := FVScrollBarContainer;
|
|
FVScrollBar.Kind := sbVertical;
|
|
FVScrollBar.Visible := True;
|
|
FVScrollBar.Align := alClient;
|
|
FVScrollBar.OnChange := VScrollChange;
|
|
FVScrollBar.Enabled := False;
|
|
|
|
FHScrollBarContainer := TWinContainer.Create(Self);
|
|
FHScrollBarContainer.Visible := False;
|
|
FHScrollBar := TScrollBar.Create(Self);
|
|
FHScrollBar.Parent := FHScrollBarContainer;
|
|
FHScrollBar.Visible := True;
|
|
FHScrollBar.Align := alClient;
|
|
FHScrollBar.OnChange := HScrollChange;
|
|
|
|
FCustomizeJSErrorDialog :=True;
|
|
FCustomizeStdDialogs :=True;
|
|
FUseVClStyleBackGroundColor :=False;
|
|
end;
|
|
|
|
|
|
//check flicker issue;
|
|
procedure TVclStylesWebBrowser.WMSIZE(var Message: TWMSIZE);
|
|
begin
|
|
if Document <> nil then SendMessage(Handle, WM_SETREDRAW, 0, 0);
|
|
|
|
inherited;
|
|
ResizeScrollBars;
|
|
|
|
if Document <> nil then
|
|
begin
|
|
SendMessage(Handle, WM_SETREDRAW, 1, 0);
|
|
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE + RDW_ALLCHILDREN + RDW_UPDATENOW);
|
|
end;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT;
|
|
begin
|
|
Result := E_FAIL;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
|
|
begin
|
|
Result := S_FALSE;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
|
|
begin
|
|
Result := E_FAIL;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.EnableModeless(const fEnable: BOOL): HRESULT;
|
|
begin
|
|
Result := S_OK;
|
|
end;
|
|
|
|
|
|
function TVclStylesWebBrowser.FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT;
|
|
begin
|
|
ppDORet := nil;
|
|
Result := S_FALSE;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT;
|
|
begin
|
|
ppDropTarget := nil;
|
|
Result := E_FAIL;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT;
|
|
begin
|
|
ppDispatch := nil;
|
|
Result := E_FAIL;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.UpdateUI: HRESULT;
|
|
begin
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.HideUI: HRESULT;
|
|
begin
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
|
|
begin
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
|
|
begin
|
|
Result := S_OK;
|
|
end;
|
|
|
|
//How to handle script errors as a WebBrowser control host
|
|
//http://support.microsoft.com/kb/261003
|
|
function TVclStylesWebBrowser.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
|
|
const vaIn: OleVariant; var vaOut: OleVariant): HResult;
|
|
const
|
|
CGID_DocHostCommandHandler: TGUID = (D1: $F38BC242; D2: $B950; D3: $11D1; D4: ($89, $18, $00, $C0, $4F, $C2, $C8, $36));
|
|
var
|
|
LHTMLEventObj : IHTMLEventObj;
|
|
LHTMLWindow2 : IHTMLWindow2;
|
|
LHTMLDocument2: IHTMLDocument2;
|
|
LUnknown : IUnknown;
|
|
Msg : string;
|
|
|
|
function GetPropertyValue(const PropName: WideString): OleVariant;
|
|
var
|
|
LParams : TDispParams;
|
|
LDispIDs : Integer;
|
|
Status : Integer;
|
|
ExcepInfo : TExcepInfo;
|
|
LName : PWideChar;
|
|
begin
|
|
ZeroMemory(@LParams, SizeOf(LParams));
|
|
LName := PWideChar(PropName);
|
|
Status := LHTMLEventObj.GetIDsOfNames(GUID_NULL, @LName, 1, LOCALE_SYSTEM_DEFAULT, @LDispIDs);
|
|
if Status = 0 then
|
|
begin
|
|
Status := LHTMLEventObj.Invoke(LDispIDs, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, LParams, @Result, @ExcepInfo, nil);
|
|
if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
|
|
end
|
|
else
|
|
if Status = DISP_E_UNKNOWNNAME then raise EOleError.CreateFmt('Property "%s" is not supported.', [PropName])
|
|
else
|
|
OleCheck(Status);
|
|
end;
|
|
|
|
begin
|
|
Result:=S_OK;
|
|
{
|
|
//to do -> prompt box [000214D0-0000-0000-C000-000000000046] + OLECMDID_UPDATETRAVELENTRY_DATARECOVERY
|
|
}
|
|
if (CmdGroup <> nil) and IsEqualGuid(CmdGroup^, CGID_DocHostCommandHandler) then
|
|
case nCmdID of
|
|
OLECMDID_SHOWSCRIPTERROR:
|
|
begin
|
|
if not FCustomizeJSErrorDialog then exit;
|
|
LUnknown := IUnknown(TVarData(vaIn).VUnknown);
|
|
if Succeeded(LUnknown.QueryInterface(IID_IHTMLDocument2, LHTMLDocument2)) then
|
|
begin
|
|
LHTMLWindow2 := LHTMLDocument2.Get_parentWindow;
|
|
if LHTMLWindow2<>nil then
|
|
begin
|
|
LHTMLEventObj := LHTMLWindow2.Get_event;
|
|
if LHTMLEventObj <> nil then
|
|
begin
|
|
Msg:='An error has ocurred in the script in this page'+sLineBreak+
|
|
'Line %s'+sLineBreak+
|
|
'Char %s'+sLineBreak+
|
|
'Error %s'+sLineBreak+
|
|
'Code %s'+sLineBreak+
|
|
'URL %s'+sLineBreak+
|
|
'Do you want to continue running scripts on this page?';
|
|
Msg:=Format(Msg,[GetPropertyValue('errorline'), GetPropertyValue('errorCharacter'), GetPropertyValue('errorMessage'), GetPropertyValue('errorCode'), GetPropertyValue('errorUrl')]);
|
|
if MessageDlg(Msg,mtWarning,[mbYes, mbNo],0) =mrYes then
|
|
vaOut := True
|
|
else
|
|
vaOut := False;
|
|
|
|
Result:=S_OK;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
else
|
|
Result:=OLECMDERR_E_NOTSUPPORTED;
|
|
end
|
|
else
|
|
Result:=OLECMDERR_E_UNKNOWNGROUP;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
|
|
prgCmds: POleCmd; CmdText: POleCmdText): HResult;
|
|
begin
|
|
Result:=S_FALSE;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;
|
|
begin
|
|
Result := S_FALSE;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const pDoc: IOleInPlaceUIWindow): HRESULT;
|
|
begin
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT;
|
|
begin
|
|
Result:=S_FALSE;
|
|
end;
|
|
|
|
{$IFDEF HOOKDialogs}
|
|
function TVclStylesWebBrowser.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR;
|
|
uCommand, dwData: Integer; ptMouse: TPoint;
|
|
var pDispachObjectHit: IDispatch): HRESULT;
|
|
begin
|
|
Result := S_FALSE;
|
|
end;
|
|
|
|
//http://msdn.microsoft.com/en-us/library/aa753271%28v=vs.85%29.aspx
|
|
function TVclStylesWebBrowser.ShowMessage(hwnd: THandle; lpstrText,
|
|
lpstrCaption: POLESTR; dwType: Integer; lpstrHelpFile: POLESTR;
|
|
dwHelpContext: Integer; var plResult: LRESULT): HRESULT;
|
|
var
|
|
DlgType: TMsgDlgType;
|
|
Buttons: TMsgDlgButtons;
|
|
begin
|
|
Result := E_NOTIMPL;
|
|
if not FCustomizeStdDialogs then exit;
|
|
|
|
DlgType:=mtInformation;
|
|
if ((dwType and MB_ICONMASK)=MB_ICONHAND) or ((dwType and MB_ICONMASK)=MB_USERICON) then
|
|
DlgType:=mtCustom
|
|
else
|
|
if (dwType and MB_ICONMASK)=MB_ICONWARNING then
|
|
DlgType:=mtWarning
|
|
else
|
|
if (dwType and MB_ICONMASK)=MB_ICONQUESTION then
|
|
DlgType:=mtConfirmation
|
|
else
|
|
if (dwType and MB_ICONMASK)=MB_ICONEXCLAMATION then
|
|
DlgType:=mtInformation;
|
|
|
|
case dwType and MB_TYPEMASK of
|
|
MB_OK:Buttons:=[mbOK];
|
|
MB_OKCANCEL:Buttons:=[mbOK,mbCancel];
|
|
MB_ABORTRETRYIGNORE:Buttons:=[mbAbort,mbRetry,mbIgnore];
|
|
MB_YESNOCANCEL:Buttons:=[mbYes,mbNo,mbCancel];
|
|
MB_YESNO:Buttons:=[mbYes,mbNo];
|
|
MB_RETRYCANCEL:Buttons:=[mbRetry,mbCancel];
|
|
else
|
|
Buttons:=[mbOK];
|
|
end;
|
|
|
|
plResult:= MessageDlg(lpstrText, DlgType, Buttons, dwHelpContext);
|
|
Result := S_OK;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TVclStylesWebBrowser.GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT;
|
|
var
|
|
BodyCss : string;
|
|
ColorHtml : string;
|
|
LColor : TColor;
|
|
begin
|
|
LColor:=StyleServices.GetSystemColor(clWindow);
|
|
ColorHtml:= Format('#%.2x%.2x%.2x',[GetRValue(LColor), GetGValue(LColor), GetBValue(LColor)]) ;
|
|
BodyCss:=Format('BODY {background-color:%s}',[ColorHtml]);
|
|
|
|
pInfo.cbSize := SizeOf(pInfo);
|
|
pInfo.dwFlags := 0;
|
|
pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER;//disable 3d border
|
|
pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_THEME;
|
|
if FUseVClStyleBackGroundColor then
|
|
pInfo.pchHostCss :=PWideChar(BodyCss);
|
|
Result := S_OK;
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
function TVclStylesWebBrowser.GetIEHandle: HWND;
|
|
var
|
|
ChildHWND : WinApi.Windows.HWND;
|
|
TempHWND : WinApi.Windows.HWND;
|
|
lpClassName : Array [0..255] of Char;
|
|
begin
|
|
TempHWND := Self.Handle;
|
|
if TempHWND<>0 then
|
|
while true do
|
|
begin
|
|
ChildHWND := GetWindow(TempHWND, GW_CHILD);
|
|
if ChildHWND=0 then break;
|
|
GetClassName(ChildHWND, lpClassName, SizeOf(lpClassName));
|
|
if SameText(string(lpClassName), 'Internet Explorer_Server') then
|
|
begin
|
|
Result :=ChildHWND;
|
|
Exit;
|
|
end;
|
|
TempHWND := ChildHWND;
|
|
end;
|
|
Result := 0;
|
|
end;
|
|
|
|
|
|
procedure TVclStylesWebBrowser.SetParent(AParent: TWinControl);
|
|
begin
|
|
inherited;
|
|
if not (csDestroying in ComponentState) then
|
|
begin
|
|
FVScrollBarContainer.Parent := AParent;
|
|
FHScrollBarContainer.Parent := AParent;
|
|
FScrollCornerContainer.Parent := AParent;
|
|
ResizeScrollBars;
|
|
end;
|
|
end;
|
|
|
|
//procedure TVclStylesWebBrowser.SetZOrder(TopMost: Boolean);
|
|
//begin
|
|
// inherited;
|
|
// ResizeScrollBars;
|
|
//end;
|
|
|
|
procedure TVclStylesWebBrowser.ResizeScrollBars;
|
|
var
|
|
StateVisible : Boolean;
|
|
DocClientWidth : Integer;
|
|
ScrollWidth : Integer;
|
|
ScrollHeight : Integer;
|
|
HPageSize : Integer;
|
|
VPageSize : Integer;
|
|
LRect : TRect;
|
|
IEHWND : WinApi.Windows.HWND;
|
|
|
|
|
|
procedure UpdateContainers;
|
|
begin
|
|
if FVScrollBarContainer.Visible then
|
|
begin
|
|
LRect := BoundsRect;
|
|
//OutputDebugString(PChar(Format('Original VScrollBarContainer Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) ));
|
|
LRect.Left := LRect.Right - FLSM_CXHTHUMB;
|
|
if FHScrollBarContainer.Visible then
|
|
LRect.Bottom := LRect.Bottom - FLSM_CYVTHUMB;
|
|
|
|
//LRect.Width:=2;
|
|
FVScrollBarContainer.BoundsRect := LRect;
|
|
end;
|
|
|
|
if FHScrollBarContainer.Visible then
|
|
begin
|
|
LRect := BoundsRect;
|
|
//OutputDebugString(PChar(Format('Original HScrollBarContainer Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) ));
|
|
LRect.Top := LRect.Bottom - FLSM_CYVTHUMB;
|
|
if FVScrollBarContainer.Visible then
|
|
LRect.Right := LRect.Right - FLSM_CXHTHUMB;
|
|
|
|
//LRect.Height:=2;
|
|
FHScrollBarContainer.BoundsRect := LRect;
|
|
//OutputDebugString(PChar(Format('ScrollBar Left %d Top %d Width %d Height %d',[LRect.Left, LRect.Top, LRect.Width, LRect.Height]) ));
|
|
end;
|
|
|
|
StateVisible := FScrollCornerContainer.Visible;
|
|
FScrollCornerContainer.Visible := FHScrollBarContainer.Visible and FVScrollBarContainer.Visible;
|
|
|
|
if FScrollCornerContainer.Visible then
|
|
begin
|
|
LRect := BoundsRect;
|
|
LRect.Left := LRect.Right - FLSM_CXHTHUMB;
|
|
LRect.Top := LRect.Bottom - FLSM_CYVTHUMB;
|
|
FScrollCornerContainer.BoundsRect := LRect;
|
|
if not StateVisible then FScrollCornerContainer.BringToFront;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
IEHWND:=GetIEHandle;
|
|
|
|
if (IEHWND=0) or (FVScrollBarContainer = nil) or (FHScrollBarContainer = nil) then Exit;
|
|
|
|
FVScrollBarContainer.Visible := True;
|
|
|
|
if (Document <> nil) and (IHtmldocument2(Document).Body <> nil) then
|
|
begin
|
|
DocClientWidth := OleVariant(Document).documentElement.ClientWidth;
|
|
if (DocClientWidth > 0) then
|
|
begin
|
|
ScrollWidth:=OleVariant(Document).DocumentElement.scrollWidth;
|
|
//OutputDebugString(PChar(Format('ScrollWidth %s',[inttoStr(ScrollWidth)])));
|
|
|
|
if (FHScrollBar.Max<>ScrollWidth) and (ScrollWidth>=FHScrollBar.PageSize) and (ScrollWidth>=FHScrollBar.Min) then
|
|
FHScrollBar.Max := ScrollWidth;
|
|
|
|
ScrollHeight:=OleVariant(Document).DocumentElement.scrollHeight;
|
|
//OutputDebugString(PChar(Format('ScrollHeight %s',[inttoStr(ScrollHeight)])));
|
|
|
|
if (FVScrollBar.Max<>ScrollHeight) and (ScrollHeight>=FVScrollBar.PageSize) and (ScrollHeight>=FVScrollBar.Min) then
|
|
FVScrollBar.Max := ScrollHeight;
|
|
end
|
|
else
|
|
begin
|
|
ScrollWidth := IHtmldocument2(Document).Body.getAttribute('ScrollWidth', 0);
|
|
if (FHScrollBar.Max<>ScrollWidth) and (ScrollWidth>=FHScrollBar.PageSize) and (ScrollWidth>=FHScrollBar.Min) then
|
|
FHScrollBar.Max := ScrollWidth;
|
|
|
|
ScrollHeight:=IHtmldocument2(Document).Body.getAttribute('ScrollHeight', 0);
|
|
if (FVScrollBar.Max<>ScrollHeight) and (ScrollHeight>=FVScrollBar.PageSize) and (ScrollHeight>=FVScrollBar.Min) then
|
|
FVScrollBar.Max := ScrollHeight;
|
|
end;
|
|
|
|
if (FHScrollBar.Max > Self.Width - FLSM_CXHTHUMB) and(FHScrollBar.Max > 0) and (FHScrollBar.Max <> Self.Width) then
|
|
VPageSize := Self.Height - FLSM_CYVTHUMB
|
|
else
|
|
VPageSize := Self.Height;
|
|
|
|
FVScrollBar.PageSize:=VPageSize;
|
|
FVScrollBar.SetParams(FVScrollBar.Position, 0, FVScrollBar.Max);
|
|
FVScrollBar.LargeChange := FVScrollBar.PageSize;
|
|
|
|
HPageSize := Self.Width - FLSM_CXHTHUMB;
|
|
FHScrollBar.PageSize:=HPageSize;
|
|
FHScrollBar.SetParams(FHScrollBar.Position, 0, FHScrollBar.Max);
|
|
FHScrollBar.LargeChange := FHScrollBar.PageSize;
|
|
|
|
FVScrollBar.Enabled := (VPageSize < FVScrollBar.Max) and(FVScrollBar.PageSize > 0) and (FVScrollBar.Max > 0) and (FVScrollBar.Max <> Self.Height);
|
|
|
|
StateVisible := FHScrollBarContainer.Visible;
|
|
|
|
if IsWindow(FHScrollBarContainer.Handle) then
|
|
FHScrollBarContainer.Visible := (HPageSize < FHScrollBar.Max) and (FHScrollBar.PageSize < FHScrollBar.Max) and (FHScrollBar.Max > 0) and (FHScrollBar.Max <> Self.Width);
|
|
|
|
if not StateVisible and FHScrollBarContainer.Visible then
|
|
FHScrollBarContainer.BringToFront;
|
|
|
|
FVScrollBarContainer.BringToFront;
|
|
end;
|
|
|
|
UpdateContainers;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.DoProgressChange(Sender: TObject; Progress,ProgressMax: Integer);
|
|
begin
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.DoDocumentComplete(Sender: TObject;const pDisp: IDispatch; const URL: OleVariant);
|
|
begin
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.DoNavigateComplete2(Sender: TObject;const pDisp:IDispatch;const URL: OleVariant);
|
|
begin
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.DoCommandStateChange(Sender: TObject; Command: Integer; Enable: WordBool);
|
|
begin
|
|
if (Document <> nil) and (IHtmldocument2(Document).Body <> nil)
|
|
then
|
|
begin
|
|
if (OleVariant(Document).DocumentElement.scrollTop = 0) then
|
|
FVScrollBar.Position := IHtmldocument2(Document).Body.getAttribute('ScrollTop', 0)
|
|
else
|
|
FVScrollBar.Position := OleVariant(Document).DocumentElement.scrollTop;
|
|
|
|
if (OleVariant(Document).DocumentElement.scrollLeft = 0) then
|
|
FHScrollBar.Position := IHtmldocument2(Document).Body.getAttribute('ScrollLeft', 0)
|
|
else
|
|
FHScrollBar.Position := OleVariant(Document).DocumentElement.scrollLeft
|
|
end;
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
|
|
begin
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.VScrollChange(Sender: TObject);
|
|
begin
|
|
if (Document <> nil) and (IHTMLDocument2(Document).ParentWindow<>nil) then
|
|
IHTMLWindow2(IHTMLDocument2(Document).ParentWindow).Scroll(FHScrollBar.Position, FVScrollBar.Position);
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.HScrollChange(Sender: TObject);
|
|
begin
|
|
if (Document <> nil) and (IHTMLDocument2(Document).ParentWindow<>nil) then
|
|
IHTMLWindow2(IHTMLDocument2(Document).ParentWindow).Scroll(FHScrollBar.Position, FVScrollBar.Position);
|
|
end;
|
|
|
|
|
|
procedure TVclStylesWebBrowser.InvokeEvent(DispID: TDispID; var Params: TDispParams);
|
|
var
|
|
ArgCount : Integer;
|
|
LVarArray : Array of OleVariant;
|
|
LIndex : Integer;
|
|
begin
|
|
inherited;
|
|
ArgCount := Params.cArgs;
|
|
SetLength(LVarArray, ArgCount);
|
|
for LIndex := Low(LVarArray) to High(LVarArray) do
|
|
LVarArray[High(LVarArray)-LIndex] := OleVariant(TDispParams(Params).rgvarg^[LIndex]);
|
|
|
|
case DispID of
|
|
252: DoNavigateComplete2(Self,
|
|
LVarArray[0] {const IDispatch},
|
|
LVarArray[1] {const OleVariant});
|
|
|
|
259: DoDocumentComplete(Self,
|
|
LVarArray[0] {const IDispatch},
|
|
LVarArray[1] {const OleVariant});
|
|
|
|
250: DoBeforeNavigate2(Self,
|
|
LVarArray[0] {const IDispatch},
|
|
LVarArray[1] {const OleVariant},
|
|
LVarArray[2] {const OleVariant},
|
|
LVarArray[3] {const OleVariant},
|
|
LVarArray[4] {const OleVariant},
|
|
LVarArray[5] {const OleVariant},
|
|
WordBool((TVarData(LVarArray[6]).VPointer)^) {var WordBool});
|
|
|
|
105:DoCommandStateChange(Self,
|
|
LVarArray[0] {Integer},
|
|
LVarArray[1] {WordBool});
|
|
|
|
108:DoProgressChange(Self,
|
|
LVarArray[0] {Integer},
|
|
LVarArray[1] {Integer});
|
|
|
|
end;
|
|
|
|
SetLength(LVarArray, 0);
|
|
end;
|
|
|
|
|
|
procedure TVclStylesWebBrowser.CMVisibleChanged(var MSg: TMessage);
|
|
begin
|
|
inherited ;
|
|
FVScrollBarContainer.Visible := Self.Visible;
|
|
FHScrollBarContainer.Visible := Self.Visible;
|
|
FScrollCornerContainer.Visible := Self.Visible;
|
|
end;
|
|
|
|
procedure TVclStylesWebBrowser.Loaded;
|
|
begin
|
|
inherited;
|
|
ResizeScrollBars;
|
|
end;
|
|
|
|
end.
|