unit activexcontainer; {$mode delphi}{$H+} { Visual ActiveX container. Copyright (C) 2011 Ludo Brands This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version with the following modification: As a special exception, the copyright holders of this library give you permission to link this library with independent modules to produce an executable, regardless of the license terms of these independent modules,and to copy and distribute the resulting executable under terms of your choice, provided that you also meet, for each linked independent module, the terms and conditions of the license of that module. An independent module is a module which is not derived from or based on this library. If you modify this library, you may extend this exception to your version of the library, but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. } interface uses Classes, SysUtils,Controls,windows, ActiveX, ComObj,forms,graphics; type //from OCIDL.h PPointF = ^TPointF; tagPOINTF = record x: Single; y: Single; end; TPointF = tagPOINTF; POINTF = TPointF; IOleControlSite = interface ['{B196B289-BAB4-101A-B69C-00AA00341D07}'] function OnControlInfoChanged: HResult; stdcall; function LockInPlaceActive(fLock: BOOL): HResult; stdcall; function GetExtendedControl(out disp: IDispatch): HResult; stdcall; function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF; flags: Longint): HResult; stdcall; function TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult; stdcall; function OnFocus(fGotFocus: BOOL): HResult; stdcall; function ShowPropertyFrame: HResult; stdcall; end; IPropertyNotifySink = interface ['{9BFBBC02-EFF1-101A-84ED-00AA00341D07}'] function OnChanged(dispid: TDispID): HResult; stdcall; function OnRequestEdit(dispid: TDispID): HResult; stdcall; end; ISimpleFrameSite = interface ['{742B0E01-14E6-101B-914E-00AA00300CAB}'] function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer; out res: Integer; out Cookie: Longint): HResult; stdcall; function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer; out res: Integer; Cookie: Longint): HResult; stdcall; end; TStatusTextEvent = procedure(Sender: TObject; Status:string) of object; { TActiveXContainer } TActiveXContainer = class(TWinControl, IUnknown, IOleClientSite, IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch) private FActive: boolean; FAttached: boolean; FClassName: string; FOleObject: IDispatch; FOnStatusText: TStatusTextEvent; FPrevWndProc:windows.WNDPROC; Function GetvObject:variant; //IOleClientSite Function SaveObject: HResult;StdCall; Function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;OUT mk: IMoniker):HResult;StdCall; Function GetContainer(OUT container: IOleContainer):HResult;StdCall; procedure SetActive(AValue: boolean); procedure SetClassName(AValue: string); procedure SetOleObject(AValue: IDispatch); Function ShowObject:HResult;StdCall; Function OnShowWindow(fShow: BOOL):HResult;StdCall; Function RequestNewObjectLayout:HResult;StdCall; //IOleControlSite function OnControlInfoChanged: HResult; stdcall; function LockInPlaceActive(fLock: BOOL): HResult; stdcall; function GetExtendedControl(out disp: IDispatch): HResult; stdcall; function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF; flags: Longint): HResult; stdcall; function TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;overload; stdcall; function OnFocus(fGotFocus: BOOL): HResult; stdcall; function ShowPropertyFrame: HResult; stdcall; //IOleInPlaceSite function CanInPlaceActivate : HResult;stdcall; function OnInPlaceActivate : HResult;stdcall; function OnUIActivate : HResult;stdcall; function GetWindowContext(out ppframe:IOleInPlaceFrame;out ppdoc:IOleInPlaceUIWindow;lprcposrect:LPRECT;lprccliprect:LPRECT;lpframeinfo:LPOLEINPLACEFRAMEINFO):hresult; stdcall; function Scroll(scrollExtant:TSIZE):hresult; stdcall; function OnUIDeactivate(fUndoable:BOOL):hresult; stdcall; function OnInPlaceDeactivate :hresult; stdcall; function DiscardUndoState :hresult; stdcall; function DeactivateAndUndo :hresult; stdcall; function OnPosRectChange(lprcPosRect:LPRect):hresult; stdcall; //IOleWindow function GetWindow(out wnd: HWnd): HResult; stdcall; function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; //IOleInPlaceFrame function InsertMenus(hmenuShared: HMenu; var menuWidths: TOleMenuGroupWidths): HResult;StdCall; function SetMenu(hmenuShared: HMenu; holemenu: HMenu; hwndActiveObject: HWnd): HResult;StdCall; function RemoveMenus(hmenuShared: HMenu): HResult;StdCall; function SetStatusText(pszStatusText: POleStr): HResult;StdCall; function EnableModeless(fEnable: BOOL): HResult;StdCall; function TranslateAccelerator(var msg: TMsg; wID: Word): HResult;StdCall;overload; //IOleInPlaceUIWindow function GetBorder(out rectBorder: TRect):HResult;StdCall; function RequestBorderSpace(const borderwidths: TRect):HResult;StdCall; function SetBorderSpace(const borderwidths: TRect):HResult;StdCall; function SetActiveObject(const activeObject: IOleInPlaceActiveObject;pszObjName: POleStr):HResult;StdCall; //IDispatch function GetTypeInfoCount(out count : longint) : HResult;stdcall; function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall; function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall; function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall; //internal procedure Attach; procedure Detach; public constructor Create(TheOwner: TComponent); override; destructor Destroy; override; //VT_DISPATCH variant used for late binding property vObject:Variant read GetvObject; published property Align; property Anchors; property AutoSize; property BorderSpacing; property ChildSizing; //ActiveX object is automatically created from classname and destroyed when set property OleClassName:string read FClassName write SetClassName; property ClientHeight; property ClientWidth; property Constraints; property DockSite; property DragCursor; property DragKind; property DragMode; property Enabled; {IDispatch interface for ActiveX object. Overrides classname. Set ComServer when you create and destroy the object yourself, fe. using CoClass. When Active, returns the IDispatch for the object. } property ComServer:IDispatch read FOleObject write SetOleObject; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property UseDockManager default True; property Visible; property OnDockDrop; property OnDockOver; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnGetSiteInfo; property OnGetDockCaption; property OnResize; property OnStartDock; property OnStartDrag; property OnStatusText:TStatusTextEvent read FOnStatusText write FOnStatusText; property OnUnDock; {When set, binds ActiveX component to control. When cleared, detaches the component from the control If Classname is provided the ActiveX component will also be created and destroyed automatically.} property Active:boolean read FActive write SetActive; end; implementation {$ifdef wince} const GWLP_USERDATA=GWL_USERDATA; function GetWindowLongPtrW(hWnd:HWND; nIndex:longint):LONG; begin result:=GetWindowLongW(hWnd, nIndex); end; function SetWindowLongPtrW(hWnd:HWND; nIndex:longint; dwNewLong:LONG):LONG; begin result:=SetWindowLongW(hWnd, nIndex, dwNewLong); end; function SetWindowLongPtr(hWnd:HWND; nIndex:longint; dwNewLong:LONG):LONG; begin result:=SetWindowLongW(hWnd, nIndex, dwNewLong); end; {$endif wince} function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam): LRESULT; stdcall; var bounds:TRect; DC: HDC; PS: TPaintStruct; size:TPOINT; AXC:TActiveXContainer; begin AXC:=TActiveXContainer(GetWindowLongPtrW( Ahwnd, GWLP_USERDATA)); case uMsg of WM_DESTROY:AXC.Detach; WM_SIZE: begin size.x:=(LOWORD(lparam)*2540) div Screen.PixelsPerInch; size.y:=(HIWORD(lparam)*2540) div Screen.PixelsPerInch; AXC.Width:=LOWORD(lparam); AXC.Height:=LOWORD(lparam); olecheck((AXC.ComServer as IOleObject).SetExtent(DVASPECT_CONTENT,size)); bounds:=AXC.BoundsRect; olecheck((AXC.ComServer as IOleInPlaceObject).SetObjectRects(@bounds,@bounds)); end; WM_PAINT: begin DC:=GetDC(AXC.handle); bounds:=AXC.BoundsRect; olecheck((AXC.ComServer as IViewObject).Draw(DVASPECT_CONTENT,0,nil,nil,0,DC,@bounds,@bounds,nil,0)); ReleaseDC(AXC.handle,DC); end; end; result:=CallWindowProc(AXC.FPrevWndProc,Ahwnd, uMsg, WParam, LParam); end; { TActiveXContainer } function TActiveXContainer.GetvObject: variant; begin result:=FOleObject; end; function TActiveXContainer.SaveObject: HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; out mk: IMoniker): HResult; StdCall; begin mk := nil; Result := E_NOTIMPL; end; function TActiveXContainer.GetContainer(out container: IOleContainer): HResult; StdCall; begin container := nil; Result := E_NOINTERFACE; end; procedure TActiveXContainer.SetActive(AValue: boolean); begin if FActive=AValue then Exit; if AValue then begin if (FClassName='') and not assigned(ComServer) then raise exception.Create('OleClassName and ComServer not assigned.'); if not assigned(FOleObject) then FOleObject:=CreateOleObject(FClassName); Attach; end else begin Detach; if FClassName<>'' then //destroy com object FOleObject:=nil; end; FActive:=AValue; end; procedure TActiveXContainer.SetClassName(AValue: string); begin if (FClassName=AValue) or FActive then Exit; FClassName:=AValue; end; procedure TActiveXContainer.SetOleObject(AValue: IDispatch); begin if (FOleObject=AValue) or FActive then Exit; FOleObject:=AValue; end; function TActiveXContainer.ShowObject: HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.OnShowWindow(fShow: BOOL): HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.RequestNewObjectLayout: HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.OnControlInfoChanged: HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.LockInPlaceActive(fLock: BOOL): HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.GetExtendedControl(out disp: IDispatch): HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF; flags: Longint): HResult; stdcall; begin if flags and 4 <> 0 then //XFORMCOORDS_HIMETRICTOCONTAINER=4 begin ptfContainer.X := (ptlHimetric.X * Screen.PixelsPerInch) div 2540; ptfContainer.Y := (ptlHimetric.Y * Screen.PixelsPerInch) div 2540; end else if assigned(@ptlHimetric) and (flags and 8 <> 0) then //XFORMCOORDS_CONTAINERTOHIMETRIC = 8 begin ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / Screen.PixelsPerInch)); ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / Screen.PixelsPerInch)); end; Result := S_OK; end; function TActiveXContainer.TranslateAccelerator(msg: PMsg; grfModifiers: Longint ): HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.OnFocus(fGotFocus: BOOL): HResult; stdcall; begin Result := S_OK; end; function TActiveXContainer.ShowPropertyFrame: HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.CanInPlaceActivate: HResult;stdcall; begin Result := S_OK; end; function TActiveXContainer.OnInPlaceActivate: HResult;stdcall; begin Result := S_OK; end; function TActiveXContainer.OnUIActivate: HResult; stdcall; begin Result := S_OK; end; function TActiveXContainer.GetWindowContext(out ppframe: IOleInPlaceFrame; out ppdoc: IOleInPlaceUIWindow; lprcposrect: LPRECT; lprccliprect: LPRECT; lpframeinfo: LPOLEINPLACEFRAMEINFO): hresult; stdcall; begin if assigned (ppframe) then ppframe := Self as IOleInPlaceFrame; if assigned(ppdoc) then ppdoc:= nil; if assigned(lpframeinfo) then begin lpframeinfo.fMDIApp := False; lpframeinfo.cAccelEntries := 0; lpframeinfo.haccel := 0; lpframeinfo.hwndFrame := Handle; end; if assigned (lprcPosRect) then lprcPosRect^:=GetClientRect; if assigned (lprcClipRect) then lprcClipRect^:=GetClientRect; Result := S_OK; end; function TActiveXContainer.Scroll(scrollExtant: TSIZE): hresult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.OnUIDeactivate(fUndoable: BOOL): hresult; stdcall; begin Result := S_OK; end; function TActiveXContainer.OnInPlaceDeactivate: hresult; stdcall; begin Result := S_OK; end; function TActiveXContainer.DiscardUndoState: hresult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.DeactivateAndUndo: hresult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.OnPosRectChange(lprcPosRect: LPRect): hresult; stdcall; begin Result := S_OK; end; function TActiveXContainer.GetWindow(out wnd: HWnd): HResult; stdcall; begin wnd:=Handle; Result := S_OK; end; function TActiveXContainer.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.InsertMenus(hmenuShared: HMenu; var menuWidths: TOleMenuGroupWidths): HResult; StdCall; begin Result := E_NOTIMPL; end; function TActiveXContainer.SetMenu(hmenuShared: HMenu; holemenu: HMenu; hwndActiveObject: HWnd): HResult; StdCall; begin Result := E_NOTIMPL; end; function TActiveXContainer.RemoveMenus(hmenuShared: HMenu): HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.SetStatusText(pszStatusText: POleStr): HResult; StdCall; begin if assigned(FOnStatusText) then FOnStatusText(Self,utf8encode(WideString(pszStatusText))); Result := S_OK; end; function TActiveXContainer.EnableModeless(fEnable: BOOL): HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.TranslateAccelerator(var msg: TMsg; wID: Word): HResult; StdCall; begin Result := E_NOTIMPL; end; function TActiveXContainer.GetBorder(out rectBorder: TRect): HResult; StdCall; begin Result := INPLACE_E_NOTOOLSPACE; end; function TActiveXContainer.RequestBorderSpace(const borderwidths: TRect): HResult; StdCall; begin Result := INPLACE_E_NOTOOLSPACE; end; function TActiveXContainer.SetBorderSpace(const borderwidths: TRect): HResult; StdCall; begin Result := E_NOTIMPL; end; function TActiveXContainer.SetActiveObject( const activeObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult; StdCall; begin Result := S_OK; end; function TActiveXContainer.GetTypeInfoCount(out count: longint): HResult; stdcall; begin Count := 0; Result := S_OK; end; function TActiveXContainer.GetTypeInfo(Index, LocaleID: longint; out TypeInfo ): HResult; stdcall; begin Pointer(TypeInfo) := nil; Result := E_NOTIMPL; end; function TActiveXContainer.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall; begin Result := E_NOTIMPL; end; function TActiveXContainer.Invoke(DispID: LongInt; const iid: TGUID; LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo, ArgErr: pointer): HResult; stdcall; var F: TFont; const DISPID_AMBIENT_BACKCOLOR = -701; DISPID_AMBIENT_DISPLAYNAME = -702; DISPID_AMBIENT_FONT = -703; DISPID_AMBIENT_FORECOLOR = -704; DISPID_AMBIENT_LOCALEID = -705; DISPID_AMBIENT_MESSAGEREFLECT = -706; DISPID_AMBIENT_USERMODE = -709; DISPID_AMBIENT_UIDEAD = -710; DISPID_AMBIENT_SHOWGRABHANDLES = -711; DISPID_AMBIENT_SHOWHATCHING = -712; DISPID_AMBIENT_SUPPORTSMNEMONICS = -714; DISPID_AMBIENT_AUTOCLIP = -715; begin if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then begin Result := S_OK; case DispID of DISPID_AMBIENT_BACKCOLOR: PVariant(VarResult)^ := Color; DISPID_AMBIENT_DISPLAYNAME: PVariant(VarResult)^ := OleVariant(Name); DISPID_AMBIENT_FONT: PVariant(VarResult)^ :=nil; DISPID_AMBIENT_FORECOLOR: PVariant(VarResult)^ := Font.Color; DISPID_AMBIENT_LOCALEID: PVariant(VarResult)^ := Integer(GetUserDefaultLCID); DISPID_AMBIENT_MESSAGEREFLECT: PVariant(VarResult)^ := False; DISPID_AMBIENT_USERMODE: PVariant(VarResult)^ := not (csDesigning in ComponentState); DISPID_AMBIENT_UIDEAD: PVariant(VarResult)^ := csDesigning in ComponentState; DISPID_AMBIENT_SHOWGRABHANDLES: PVariant(VarResult)^ := False; DISPID_AMBIENT_SHOWHATCHING: PVariant(VarResult)^ := False; DISPID_AMBIENT_SUPPORTSMNEMONICS: PVariant(VarResult)^ := True; DISPID_AMBIENT_AUTOCLIP: PVariant(VarResult)^ := True; else Result := DISP_E_MEMBERNOTFOUND; end; end else Result := DISP_E_MEMBERNOTFOUND; end; procedure TActiveXContainer.Attach; var size:TPOINT; begin SetWindowLongPtr(Handle,GWLP_USERDATA, PtrInt(Self)); FPrevWndProc:=Windows.WNDPROC(SetWindowLongPtr(Handle,GWL_WNDPROC,PtrInt(@WndCallback))); FAttached:=true; olecheck((FOleObject as IOleObject).SetClientSite(Self as IOleClientSite)); olecheck((FOleObject as IOleObject).SetHostNames(PWideChar(name),PWideChar(name))); size.x:=(Width*2540) div Screen.PixelsPerInch; size.y:=(Height*2540) div Screen.PixelsPerInch; olecheck((FOleObject as IOleObject).SetExtent(DVASPECT_CONTENT,size)); olecheck((FOleObject as IOleObject).DoVerb(OLEIVERB_INPLACEACTIVATE,nil,Self as IOleClientSite,0,Handle,BoundsRect)); end; procedure TActiveXContainer.Detach; const OLECLOSE_NOSAVE = 1; begin if FAttached then begin SetWindowLongPtr(Handle,GWL_WNDPROC,PtrInt(@FPrevWndProc)); SetWindowLongPtr(Handle,GWLP_USERDATA, 0); end; if assigned(FOleObject) then begin olecheck((FOleObject as IOleObject).SetClientSite(nil)); olecheck((FOleObject as IOleObject).Close(OLECLOSE_NOSAVE)); end; end; constructor TActiveXContainer.Create(TheOwner: TComponent); begin inherited Create(TheOwner); parent:=TWinControl(TheOwner); Width:=24; Height:=24; end; destructor TActiveXContainer.Destroy; begin Active:=false; //destroys com object if created by Self inherited Destroy; end; end.