{This version is compatible with KOL 3.00+ -- VK} unit ActiveKOL; interface uses windows, messages, KOL, ActiveX, KOLComObj, err; {$I KOLDEF.INC} {$IFDEF _D6orHigher} //{$WARN SYMBOL_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} {$IFDEF _D7orHigher} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CAST OFF} {$WARN UNSAFE_CODE OFF} {$ENDIF} {$ENDIF} {$IFNDEF _D5orHigher} const sNoRunningObject = 'Unable to retrieve a pointer to a running object registered with OLE for %s/%s'; {$ENDIF} type POleCtl = ^TOleCtl; TEventDispatch = class(TObject, IUnknown, IDispatch) private FControl: POleCtl; protected { IUnknown } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; { IDispatch } 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; property Control: POleCtl read FControl; public constructor Create(Control: POleCtl); end; {$IFNDEF _D5orHigher} TOleEnum = type Integer; //{$NODEFINE TOleEnum} {$ENDIF} TGetStrProc = procedure(const S: string) of object; TEnumValue = record Value: Longint; Ident: string; end; PEnumValueList = ^TEnumValueList; TEnumValueList = array[0..32767] of TEnumValue; PEnumPropDesc = ^TEnumPropDesc; TEnumPropDesc = object(TObj) private FDispID: Integer; FValueCount: Integer; FValues: PEnumValueList; public constructor Create(DispID, ValueCount: Integer; const TypeInfo: ITypeInfo); destructor Destroy; virtual; procedure GetStrings(Proc: TGetStrProc); function StringToValue(const S: string): Integer; function ValueToString(V: Integer): string; end; PControlData = ^TControlData; TControlData = record ClassID: TGUID; EventIID: TGUID; EventCount: Longint; EventDispIDs: Pointer; LicenseKey: Pointer; Flags: DWORD; Version: Integer; FontCount: Integer; FontIDs: PDispIDList; PictureCount: Integer; PictureIDs: PDispIDList; Reserved: Integer; InstanceCount: Integer; EnumPropDescs: PList; end; PControlData2 = ^TControlData2; TControlData2 = record ClassID: TGUID; EventIID: TGUID; EventCount: Longint; EventDispIDs: Pointer; LicenseKey: Pointer; Flags: DWORD; Version: Integer; FontCount: Integer; FontIDs: PDispIDList; PictureCount: Integer; PictureIDs: PDispIDList; Reserved: Integer; InstanceCount: Integer; EnumPropDescs: PList; FirstEventOfs: Cardinal; end; TOleCtlIntfClass = class of TOleCtlIntf; TOleCtlIntf = class( TObject, IUnknown, IOleClientSite, IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch, IPropertyNotifySink, ISimpleFrameSite) private FRefCount: Integer; fOleCtl: POleCtl; procedure GetEventMethod(DispID: TDispID; var Method: TMethod); protected { IUnknown } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; { IOleClientSite } function SaveObject: HResult; stdcall; function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; out mk: IMoniker): HResult; stdcall; function GetContainer(out container: IOleContainer): HResult; stdcall; 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 IOleControlSite.TranslateAccelerator = OleControlSite_TranslateAccelerator; function OleControlSite_TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult; stdcall; function OnFocus(fGotFocus: BOOL): HResult; stdcall; function ShowPropertyFrame: HResult; stdcall; { IOleWindow } function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; { IOleInPlaceSite } function IOleInPlaceSite.GetWindow = OleInPlaceSite_GetWindow; function OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; stdcall; function CanInPlaceActivate: HResult; stdcall; function OnInPlaceActivate: HResult; stdcall; function OnUIActivate: HResult; stdcall; function GetWindowContext(out frame: IOleInPlaceFrame; out doc: IOleInPlaceUIWindow; out rcPosRect: TRect; out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult; stdcall; function Scroll(scrollExtent: TPoint): HResult; stdcall; function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall; function OnInPlaceDeactivate: HResult; stdcall; function DiscardUndoState: HResult; stdcall; function DeactivateAndUndo: HResult; stdcall; function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall; { IOleInPlaceUIWindow } function GetBorder(out rectBorder: TRect): HResult; stdcall; function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall; function SetBorderSpace(pborderwidths: PRect): HResult; stdcall; function SetActiveObject(const activeObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult; stdcall; { IOleInPlaceFrame } function IOleInPlaceFrame.GetWindow = OleInPlaceFrame_GetWindow; function OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; stdcall; 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 IOleInPlaceFrame.TranslateAccelerator = OleInPlaceFrame_TranslateAccelerator; function OleInPlaceFrame_TranslateAccelerator(var msg: Windows.TMsg; wID: Word): HResult; stdcall; { IDispatch } 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; { ISimpleFrameSite } 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; { IPropertyNotifySink } function OnChanged(dispid: TDispID): HResult; virtual; stdcall; function OnRequestEdit(dispid: TDispID): HResult; virtual; stdcall; public property OleCtl: POleCtl read fOleCtl; constructor Create; virtual; end; TOnGetIntfClass = function(): TOleCtlIntfClass of object; TOleCtl = object( TControl ) private FOnGetIntfClass: TOnGetIntfClass; function GetOleObject: Variant; procedure CreateInstance; function GetOnLeave: TOnEvent; procedure SetOnLeave(const Value: TOnEvent); procedure HookControlWndProc; procedure SetUIActive(Active: Boolean); procedure CreateControl; procedure DestroyStorage; procedure DestroyControl; procedure StandardEvent(DispID: TDispID; var Params: TDispParams); //procedure SetMouseDblClk(const Value: TOnMouse); procedure SetOnChar(const Value: TOnChar); protected //{$IFDEF DELPHI_CODECOMPLETION_BUG} fNotAvailable: Boolean; //{$ENDIF} {$IFNDEF USE_NAMES} fName: String; {$ENDIF} FControlData: PControlData; FOleObject: IOleObject; FMiscStatus: Longint; FFonts: PList; FPictures: PList; FEventDispatch: TEventDispatch; fOleCtlIntf: TOleCtlIntf; FPersistStream: IPersistStreamInit; FOleInPlaceObject: IOleInPlaceObject; FOleInPlaceActiveObject: IOleInPlaceActiveObject; FOleControl: IOleControl; FUpdatingColor: Boolean; FUpdatingFont: Boolean; FUpdatingEnabled: Boolean; FObjectData: HGlobal; FControlDispatch: IDispatch; FPropBrowsing: IPerPropertyBrowsing; FPropConnection: Longint; FEventsConnection: Longint; fCreatingWnd: Boolean; procedure Init; virtual; procedure InitControlData; virtual; procedure InitControlInterface(const Obj: IUnknown); virtual; property ControlData: PControlData read FControlData write FControlData; function GetMainMenu: HMenu; procedure InvokeEvent(DispID: TDispID; var Params: TDispParams); procedure D2InvokeEvent(DispID: TDispID; var Params: TDispParams); procedure DoHandleException; procedure CreateEnumPropDescs; procedure DestroyEnumPropDescs; property OnGetIntfClass: TOnGetIntfClass read FOnGetIntfClass write FOnGetIntfClass; public function GetByteProp(Index: Integer): Byte; function GetColorProp(Index: Integer): TColor; function GetTColorProp(Index: Integer): TColor; function GetCompProp(Index: Integer): Comp; function GetCurrencyProp(Index: Integer): Currency; function GetDoubleProp(Index: Integer): Double; function GetIDispatchProp(Index: Integer): IDispatch; function GetIntegerProp(Index: Integer): Integer; function GetIUnknownProp(Index: Integer): IUnknown; function GetWordBoolProp(Index: Integer): WordBool; function GetTDateTimeProp(Index: Integer): TDateTime; function GetTFontProp(Index: Integer): PGraphicTool; function GetOleBoolProp(Index: Integer): TOleBool; function GetOleDateProp(Index: Integer): TOleDate; function GetOleEnumProp(Index: Integer): TOleEnum; function GetTOleEnumProp(Index: Integer): TOleEnum; function GetOleVariantProp(Index: Integer): OleVariant; //function GetTPictureProp(Index: Integer): TPicture; procedure GetProperty(Index: Integer; var Value: TVarData); function GetShortIntProp(Index: Integer): ShortInt; function GetSingleProp(Index: Integer): Single; function GetSmallintProp(Index: Integer): Smallint; function GetStringProp(Index: Integer): string; function GetVariantProp(Index: Integer): Variant; function GetWideStringProp(Index: Integer): WideString; function GetWordProp(Index: Integer): Word; procedure SetByteProp(Index: Integer; Value: Byte); procedure SetColorProp(Index: Integer; Value: TColor); procedure SetTColorProp(Index: Integer; Value: TColor); procedure SetCompProp(Index: Integer; const Value: Comp); procedure SetCurrencyProp(Index: Integer; const Value: Currency); procedure SetDoubleProp(Index: Integer; const Value: Double); procedure SetIDispatchProp(Index: Integer; const Value: IDispatch); procedure SetIntegerProp(Index: Integer; Value: Integer); procedure SetIUnknownProp(Index: Integer; const Value: IUnknown); procedure SetName(const Value: String); virtual; procedure SetWordBoolProp(Index: Integer; Value: WordBool); procedure SetTDateTimeProp(Index: Integer; const Value: TDateTime); procedure SetTFontProp(Index: Integer; Value:PGraphicTool); procedure SetOleBoolProp(Index: Integer; Value: TOleBool); procedure SetOleDateProp(Index: Integer; const Value: TOleDate); procedure SetOleEnumProp(Index: Integer; Value: TOleEnum); procedure SetTOleEnumProp(Index: Integer; Value: TOleEnum); procedure SetOleVariantProp(Index: Integer; const Value: OleVariant); procedure SetParent(AParent: PControl); virtual; //procedure SetTPictureProp(Index: Integer; Value: TPicture); procedure SetProperty(Index: Integer; const Value: TVarData); procedure SetShortIntProp(Index: Integer; Value: Shortint); procedure SetSingleProp(Index: Integer; const Value: Single); procedure SetSmallintProp(Index: Integer; Value: Smallint); procedure SetStringProp(Index: Integer; const Value: string); procedure SetVariantProp(Index: Integer; const Value: Variant); procedure SetWideStringProp(Index: Integer; const Value: WideString); procedure SetWordProp(Index: Integer; Value: Word); function GetEnumPropDesc(DispID: Integer): PEnumPropDesc; property DragCursor: Boolean read fNotAvailable; property DragMode : Boolean read fNotAvailable; property ParentShowHint: Boolean read fNotAvailable; property PopupMenu: Boolean read fNotAvailable; property ShowHint: Boolean read fNotAvailable; property OnDragDrop: Boolean read fNotAvailable; property OnDragOver: Boolean read fNotAvailable; property OnEndDrag: Boolean read fNotAvailable; property OnStartDrag: Boolean read fNotAvailable; property OnExit: TOnEvent read GetOnLeave write SetOnLeave; property OleObject: Variant read GetOleObject; property Name: String read fName write fName; function CreateWindow: Boolean; virtual; procedure DblClk; procedure KeyDown(var Key: Longint; AShift: DWORD); procedure KeyUp(var Key: Longint; AShift: DWORD); procedure KeyPress(var Key: KOLChar); procedure MouseDown(Button: TMouseButton; AShift: DWORD; X, Y: Integer); procedure MouseMove(AShift: DWORD; X, Y: Integer); procedure MouseUp(Button: TMouseButton; AShift: DWORD; X, Y: Integer); property OnKeyPress: TOnChar read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF} write SetOnChar; property OnDblClick: TOnMouse index idx_fOnMouseDblClk read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDblClk {$ENDIF} write SetOnMouseEvent; // SetMouseDblClk; destructor Destroy; virtual; end; {$IFNDEF _D2orD3} type TVariantArray = Array of OleVariant; TOleServer = class; TConnectKind = (ckRunningOrNew, // Attach to a running or create a new instance of the server ckNewInstance, // Create a new instance of the server ckRunningInstance, // Attach to a running instance of the server ckRemote, // Bind to a remote instance of the server ckAttachToInterface); // Don't bind to server, user will provide interface via 'CpnnectTo' TServerEventDispatch = class(TObject, IUnknown, IDispatch) private FServer: TOleServer; InternalRefCount : Integer; protected { IUnknown } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; { IDispatch } 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; property Server: TOleServer read FServer; function ServerDisconnect :Boolean; public constructor Create(Server: TOleServer); end; PServerData = ^TServerData; TServerData = record ClassID: TGUID; // CLSID of CoClass IntfIID: TGUID; // IID of default interface EventIID: TGUID; // IID of default source interface LicenseKey: Pointer; // Pointer to license string (not implemented) Version: Integer; // Version of this structure InstanceCount: Integer; // Instance of the Server running end; TOleServer = class(TObject, IUnknown) private FServerData: PServerData; FRefCount: Longint; FEventDispatch: TServerEventDispatch; FEventsConnection: Longint; FAutoConnect: Boolean; FRemoteMachineName: string; FConnectKind: TConnectKind; protected { IUnknown } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; procedure Loaded; //override; procedure InitServerData; virtual; abstract; function GetServer: IUnknown; virtual; procedure ConnectEvents(const Obj: IUnknown); procedure DisconnectEvents(const Obj: Iunknown); procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); virtual; function GetConnectKind: TConnectKind; procedure SetConnectKind(ck: TConnectKind); function GetAutoConnect: Boolean; procedure SetAutoConnect(flag: Boolean); property ServerData: PServerData read FServerData write FServerData; property EventDispatch: TServerEventDispatch read FEventDispatch write FEventDispatch; public constructor Create; //(AOwner: TComponent); override; destructor Destroy; override; // NOTE: If derived class is generated by TLIBIMP or ImportTypeLibraryCodeGenerator, // the derived class will also expose a 'ConnectTo(interface)' function. // You must invoke that method if you're using 'ckAttachToInterface' connection // kind. procedure Connect; virtual; abstract; procedure Disconnect; virtual; abstract; published property AutoConnect: Boolean read GetAutoConnect write SetAutoConnect; property ConnectKind: TConnectKind read GetConnectKind write SetConnectKind; property RemoteMachineName: string read FRemoteMachineName write FRemoteMachineName; end; {$ENDIF} var EmptyParam: OleVariant; { "Empty parameter" standard constant which can be passed as an optional parameter on a dual interface. } implementation uses OleConst; const // The following flags may be or'd into the TControlData.Reserved field to override // default behaviors. // cdForceSetClientSite: // Call SetClientSite early (in constructor) regardless of misc status flags cdForceSetClientSite = 1; // cdDeferSetClientSite: // Don't call SetClientSite early. Takes precedence over cdForceSetClientSite and misc status flags cdDeferSetClientSite = 2; const cfBackColor = $00000001; cfForeColor = $00000002; cfFont = $00000004; cfEnabled = $00000008; cfCaption = $00000010; cfText = $00000020; const MaxDispArgs = 32; type PDispInfo = ^TDispInfo; TDispInfo = packed record DispID: TDispID; ResType: Byte; CallDesc: TCallDesc; end; TArgKind = (akDWord, akSingle, akDouble); PEventArg = ^TEventArg; TEventArg = record Kind: TArgKind; Data: array[0..1] of Integer; end; TEventInfo = record Method: TMethod; Sender: TObject; ArgCount: Integer; Args: array[0..MaxDispArgs - 1] of TEventArg; end; function StringToVarOleStr(const S: string): Variant; begin VarClear(Result); TVarData(Result).VOleStr := StringToOleStr(S); TVarData(Result).VType := varOleStr; end; { TEnumPropDesc } constructor TEnumPropDesc.Create(DispID, ValueCount: Integer; const TypeInfo: ITypeInfo); var I: Integer; VarDesc: PVarDesc; XName: WideString; begin FDispID := DispID; FValueCount := ValueCount; FValues := AllocMem(ValueCount * SizeOf(TEnumValue)); for I := 0 to ValueCount - 1 do begin OleCheck(TypeInfo.GetVarDesc(I, VarDesc)); try OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @XName, nil, nil, nil)); with FValues^[I] do begin Value := TVarData(VarDesc^.lpVarValue^).VInteger; Ident := XName; while (Length(Ident) > 1) and (Ident[1] = '_') do Delete(Ident, 1, 1); end; finally TypeInfo.ReleaseVarDesc(VarDesc); end; end; end; destructor TEnumPropDesc.Destroy; begin if FValues <> nil then begin Finalize(FValues^[0], FValueCount); FreeMem(FValues, FValueCount * SizeOf(TEnumValue)); end; inherited; end; procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc); var I: Integer; begin for I := 0 to FValueCount - 1 do with FValues^[I] do Proc(Format('%d - %s', [Value, Ident])); end; function TEnumPropDesc.StringToValue(const S: string): Integer; var I: Integer; begin I := 1; while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I); if I > 1 then begin Result := Str2Int(Copy(S, 1, I - 1)); for I := 0 to FValueCount - 1 do if Result = FValues^[I].Value then Exit; end else for I := 0 to FValueCount - 1 do with FValues^[I] do if AnsiCompareText(S, Ident) = 0 then begin Result := Value; Exit; end; raise EOleError.CreateResFmt(e_Ole, Integer( @SBadPropValue ), [S]); end; function TEnumPropDesc.ValueToString(V: Integer): string; var I: Integer; begin for I := 0 to FValueCount - 1 do with FValues^[I] do if V = Value then begin Result := Format('%d - %s', [Value, Ident]); Exit; end; Result := Int2Str(V); end; { TOleCtl } procedure TOleCtl.CreateControl; var Stream: IStream; CS: IOleClientSite; X: Integer; begin if FOleControl = nil then try try // work around ATL bug X := FOleObject.GetClientSite(CS); except X := -1; end; if (X <> 0) or (CS = nil) then OleCheck(FOleObject.SetClientSite(fOleCtlIntf)); if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else begin OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream)); OleCheck(FPersistStream.Load(Stream)); DestroyStorage; end; OleCheck(FOleObject.QueryInterface(IOleControl, FOleControl)); OleCheck(FOleObject.QueryInterface(IDispatch, FControlDispatch)); FOleObject.QueryInterface(IPerPropertyBrowsing, FPropBrowsing); InterfaceConnect(FOleObject, IPropertyNotifySink, fOleCtlIntf, FPropConnection); InterfaceConnect(FOleObject, FControlData^.EventIID, FEventDispatch, FEventsConnection); if FControlData^.Flags and cfBackColor <> 0 then fOleCtlIntf.OnChanged(DISPID_BACKCOLOR); if FControlData^.Flags and cfEnabled <> 0 then fOleCtlIntf.OnChanged(DISPID_ENABLED); if FControlData^.Flags and cfFont <> 0 then fOleCtlIntf.OnChanged(DISPID_FONT); if FControlData^.Flags and cfForeColor <> 0 then fOleCtlIntf.OnChanged(DISPID_FORECOLOR); FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN); fOleCtlIntf.RequestNewObjectLayout; except DestroyControl; raise; end; end; procedure TOleCtl.CreateEnumPropDescs; function FindMember(DispId: Integer): Boolean; begin Result := GetEnumPropDesc(DispId) <> nil; end; {var I: Integer; begin for I := 0 to FControlData^.EnumPropDescs.Count - 1 do if TEnumPropDesc(FControlData^.EnumPropDescs).FDispID = DispID then begin Result := True; Exit; end; Result := False; end;} procedure CreateEnum(TypeDesc: TTypeDesc; const TypeInfo: ITypeInfo; DispId: Integer); var RefInfo: ITypeInfo; RefAttr: PTypeAttr; epd: PEnumPropDesc; begin if TypeDesc.vt <> VT_USERDEFINED then Exit; OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo)); OleCheck(RefInfo.GetTypeAttr(RefAttr)); try if RefAttr^.typekind = TKIND_ENUM then begin new( epd, Create(Dispid, RefAttr^.cVars, RefInfo) ); FControlData^.EnumPropDescs.Add( epd ); end; finally RefInfo.ReleaseTypeAttr(RefAttr); end; end; procedure ProcessTypeInfo(const TypeInfo: ITypeInfo); var I: Integer; RefInfo: ITypeInfo; TypeAttr: PTypeAttr; VarDesc: PVarDesc; FuncDesc: PFuncDesc; RefType: HRefType; begin OleCheck(TypeInfo.GetTypeAttr(TypeAttr)); try if IsEqualGUID(TypeAttr^.guid, IDispatch) then Exit; if ((TypeAttr.typekind = TKIND_INTERFACE) or (TypeAttr.wTypeFlags and TYPEFLAG_FDUAL <> 0)) and (TypeAttr.wTypeFlags and TYPEFLAG_FNONEXTENSIBLE <> 0) then begin OleCheck(TypeInfo.GetRefTypeOfImplType(0, RefType)); OleCheck(TypeInfo.GetRefTypeInfo(RefType, RefInfo)); ProcessTypeInfo(RefInfo); end; for I := 0 to TypeAttr^.cVars - 1 do begin OleCheck(TypeInfo.GetVarDesc(I, VarDesc)); try CreateEnum(VarDesc^.elemdescVar.tdesc, TypeInfo, VarDesc^.memid); finally TypeInfo.ReleaseVarDesc(VarDesc); end; end; for I := 0 to TypeAttr^.cFuncs - 1 do begin OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc)); try if not FindMember(FuncDesc^.memid) then case FuncDesc^.invkind of INVOKE_PROPERTYGET: CreateEnum(FuncDesc^.elemdescFunc.tdesc, TypeInfo, FuncDesc^.memid); INVOKE_PROPERTYPUT: CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc, TypeInfo, FuncDesc^.memid); INVOKE_PROPERTYPUTREF: if FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.vt = VT_PTR then CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.ptdesc^, TypeInfo, FuncDesc^.memid); end; finally TypeInfo.ReleaseFuncDesc(FuncDesc); end; end; finally TypeInfo.ReleaseTypeAttr(TypeAttr); end; end; var TypeInfo: ITypeInfo; begin CreateControl; FControlData^.EnumPropDescs := NewList; try OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo)); ProcessTypeInfo(TypeInfo); except DestroyEnumPropDescs; raise; end; end; procedure TOleCtl.CreateInstance; var ClassFactory2: IClassFactory2; LicKeyStr: WideString; procedure LicenseCheck(Status: HResult; const Ident: string); begin if Status = CLASS_E_NOTLICENSED then raise EOleError.CreateFmt(e_Ole, Ident, [SubClassName]); OleCheck(Status); end; begin if (FControlData^.LicenseKey <> nil) then begin OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, nil, IClassFactory2, ClassFactory2)); LicKeyStr := PWideChar(FControlData^.LicenseKey); LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IOleObject, LicKeyStr, FOleObject), SInvalidLicense); end else LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject, FOleObject), SNotLicensed); end; procedure CallEventMethod(const EventInfo: TEventInfo); asm PUSH EBX PUSH ESI PUSH EBP MOV EBP,ESP MOV EBX,EAX MOV EDX,[EBX].TEventInfo.ArgCount TEST EDX,EDX JE @@5 XOR EAX,EAX LEA ESI,[EBX].TEventInfo.Args @@1: MOV AL,[ESI].TEventArg.Kind CMP AL,1 JA @@2 JE @@3 TEST AH,AH JNE @@3 MOV ECX,[ESI].Integer[4] MOV AH,1 JMP @@4 @@2: PUSH [ESI].Integer[8] @@3: PUSH [ESI].Integer[4] @@4: ADD ESI,12 DEC EDX JNE @@1 @@5: MOV EDX,[EBX].TEventInfo.Sender MOV EAX,[EBX].TEventInfo.Method.Data CALL [EBX].TEventInfo.Method.Code MOV ESP,EBP POP EBP POP ESI POP EBX end; type PVarArg = ^TVarArg; TVarArg = array[0..3] of DWORD; function TOleCtl.CreateWindow: Boolean; begin Result := FALSE; if fHandle <> 0 then begin Result := TRUE; Exit; end; if fCreatingWnd then Exit; fCreatingWnd := TRUE; try CreateControl; if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then begin FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, fOleCtlIntf, 0, ParentWindow, BoundsRect); if FOleInPlaceObject = nil then raise EOleError.CreateResFmt(e_Ole, Integer( @SCannotActivate ), [nil]); HookControlWndProc; if {$IFDEF USE_FLAGS} not(F3_Visible in fStyle.f3_Style) {$ELSE} not fVisible {$ENDIF} and IsWindowVisible(fHandle) then ShowWindow(fHandle, SW_HIDE); Result := TRUE; end else Result := inherited CreateWindow; finally fCreatingWnd := FALSE; end; end; procedure TOleCtl.D2InvokeEvent(DispID: TDispID; var Params: TDispParams); type TStringDesc = record PStr: Pointer; BStr: PBStr; end; var I, J, K, ArgType, ArgCount, StrCount: Integer; ArgPtr: PEventArg; ParamPtr: PVarArg; Strings: array[0..MaxDispArgs - 1] of TStringDesc; EventInfo: TEventInfo; begin fOleCtlIntf.GetEventMethod(DispID, EventInfo.Method); if Integer(EventInfo.Method.Code) >= $10000 then begin StrCount := 0; try ArgCount := Params.cArgs; EventInfo.Sender := fOleCtlIntf; EventInfo.ArgCount := ArgCount; if ArgCount <> 0 then begin ParamPtr := @Params.rgvarg^[EventInfo.ArgCount]; ArgPtr := @EventInfo.Args; I := 0; repeat Dec(Integer(ParamPtr), SizeOf(TVarArg)); ArgType := ParamPtr^[0] and $0000FFFF; if ArgType and varTypeMask = varOleStr then begin ArgPtr^.Kind := akDWord; with Strings[StrCount] do begin PStr := nil; if ArgType and varByRef <> 0 then begin OleStrToStrVar(PBStr(ParamPtr^[2])^, string(PStr)); BStr := PBStr(ParamPtr^[2]); ArgPtr^.Data[0] := Integer(@PStr); end else begin OleStrToStrVar(TBStr(ParamPtr^[2]), string(PStr)); BStr := nil; ArgPtr^.Data[0] := Integer(PStr); end; end; Inc(StrCount); end else begin case ArgType of varSingle: begin ArgPtr^.Kind := akSingle; ArgPtr^.Data[0] := ParamPtr^[2]; end; varDouble..varDate: begin ArgPtr^.Kind := akDouble; ArgPtr^.Data[0] := ParamPtr^[2]; ArgPtr^.Data[1] := ParamPtr^[3]; end; varDispatch: begin ArgPtr^.Kind := akDWord; ArgPtr^.Data[0] := Integer(ParamPtr) end; else ArgPtr^.Kind := akDWord; if (ArgType and varArray) <> 0 then ArgPtr^.Data[0] := Integer(ParamPtr) else ArgPtr^.Data[0] := ParamPtr^[2]; end; end; Inc(Integer(ArgPtr), SizeOf(TEventArg)); Inc(I); until I = EventInfo.ArgCount; end; CallEventMethod(EventInfo); J := StrCount; while J <> 0 do begin Dec(J); with Strings[J] do if BStr <> nil then BStr^ := StringToOleStr(string(PStr)); end; except DoHandleException; end; K := StrCount; while K <> 0 do begin Dec(K); string(Strings[K].PStr) := ''; end; end; end; procedure TOleCtl.DblClk; var MouseData: TMouseEventData; P: TPoint; begin {$IFDEF NIL_EVENTS} if Assigned(EV.fOnMouseDblClk) then {$ENDIF} begin MouseData.Button := mbLeft; MouseData.Shift := 0; GetCursorPos( P ); P := Screen2Client( P ); MouseData.X := P.x; MouseData.Y := P.y; EV.fOnMouseDblClk(@Self, MouseData); end; end; destructor TOleCtl.Destroy; procedure FreeList(var L: PList); begin if L = nil then Exit; L.Release; L := nil; end; begin SetUIActive(False); if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE); DestroyControl; DestroyStorage; FPersistStream := nil; if FOleObject <> nil then FOleObject.SetClientSite(nil); FOleObject := nil; FEventDispatch.Free; FreeList(FFonts); FreeList(FPictures); Dec(FControlData^.InstanceCount); if FControlData^.InstanceCount = 0 then DestroyEnumPropDescs; fOleCtlIntf.Free; inherited Destroy; end; procedure TOleCtl.DestroyControl; begin InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection); InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection); FPropBrowsing := nil; FControlDispatch := nil; FOleControl := nil; end; procedure TOleCtl.DestroyEnumPropDescs; var I: Integer; begin with FControlData^ do if EnumPropDescs <> nil then begin for I := 0 to EnumPropDescs.Count - 1 do PEnumPropDesc(EnumPropDescs.Items[I]).Free; EnumPropDescs.Free; EnumPropDescs := nil; end; end; procedure TOleCtl.DestroyStorage; begin if FObjectData <> 0 then begin GlobalFree(FObjectData); FObjectData := 0; end; end; procedure TOleCtl.DoHandleException; begin //Application.HandleException(Self); //TODO: replace Application.HandleException with something end; function TOleCtl.GetByteProp(Index: Integer): Byte; begin Result := GetIntegerProp(Index); end; function TOleCtl.GetColorProp(Index: Integer): TColor; begin Result := GetIntegerProp(Index); end; function TOleCtl.GetCompProp(Index: Integer): Comp; begin Result := GetDoubleProp(Index); end; function TOleCtl.GetCurrencyProp(Index: Integer): Currency; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VCurrency; end; function TOleCtl.GetDoubleProp(Index: Integer): Double; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VDouble; end; procedure TOleCtlIntf.GetEventMethod(DispID: TDispID; var Method: TMethod); {begin // test for D4 - it works... Method.Code := nil; Method.Data := nil; end;} const szOleCtl = sizeof( TOleCtl ); asm PUSH EBX PUSH ESI PUSH EDI PUSH ECX MOV EBX,EAX MOV ECX,[EBX].fOleCtl ///////////////////////// fix of events handling MOV EBX, ECX // by Alexey Izyumov ///////////////////////// Octouber, 2001 MOV ECX,[ECX].TOleCtl.FControlData MOV EDI,[ECX].TControlData.EventCount MOV ESI,[ECX].TControlData.EventDispIDs XOR EAX,EAX JMP @@1 @@0: CMP EDX,[ESI].Integer[EAX*4] JE @@2 INC EAX @@1: CMP EAX,EDI JNE @@0 XOR EAX,EAX XOR EDX,EDX JMP @@3 @@2: PUSH EAX CMP [ECX].TControlData.Version, 401 JB @@2a MOV EAX, [ECX].TControlData2.FirstEventOfs TEST EAX, EAX JNE @@2b @@2a: {MOV EAX, [EBX] CALL TObject.ClassParent CALL TObject.InstanceSize} MOV EAX, szOleCtl ADD EAX, 7 AND EAX, not 7 // 8 byte alignment @@2b: ADD EBX, EAX POP EAX MOV EDX,[EBX][EAX*8].TMethod.Data MOV EAX,[EBX][EAX*8].TMethod.Code @@3: POP ECX MOV [ECX].TMethod.Code,EAX MOV [ECX].TMethod.Data,EDX POP EDI POP ESI POP EBX end; function TOleCtl.GetEnumPropDesc(DispID: Integer): PEnumPropDesc; var I: Integer; begin with FControlData^ do begin if EnumPropDescs = nil then CreateEnumPropDescs; for I := 0 to EnumPropDescs.Count - 1 do begin Result := EnumPropDescs.Items[I]; if Result.FDispID = DispID then Exit; end; Result := nil; end; end; function TOleCtl.GetIDispatchProp(Index: Integer): IDispatch; var Temp: TVarData; begin GetProperty(Index, Temp); Result := IDispatch(Temp.VDispatch); end; function TOleCtl.GetIntegerProp(Index: Integer): Integer; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VInteger; end; function TOleCtl.GetIUnknownProp(Index: Integer): IUnknown; var Temp: TVarData; begin GetProperty(Index, Temp); Result := IUnknown(Temp.VUnknown); end; function TOleCtl.GetMainMenu: HMenu; var Form: PControl; begin Result := 0; Form := ParentForm; if Form <> nil then //if Form.FormStyle <> fsMDIChild then Result := Form.Menu {else if Application.MainForm <> nil then Result := Application.MainForm.Menu}; end; function TOleCtl.GetOleBoolProp(Index: Integer): TOleBool; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VBoolean; end; function TOleCtl.GetOleDateProp(Index: Integer): TOleDate; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VDate; end; function TOleCtl.GetOleEnumProp(Index: Integer): TOleEnum; begin Result := GetIntegerProp(Index); end; function TOleCtl.GetOleObject: Variant; begin CreateControl; Result := Variant(FOleObject as IDispatch); end; function TOleCtl.GetOleVariantProp(Index: Integer): OleVariant; begin VarClear(Result); GetProperty(Index, TVarData(Result)); end; function TOleCtl.GetOnLeave: TOnEvent; begin Result := OnExit; end; var // init to zero, never written to DispParams: TDispParams = (); procedure TOleCtl.GetProperty(Index: Integer; var Value: TVarData); var Status: HResult; ExcepInfo: TExcepInfo; begin CreateControl; Value.VType := varEmpty; Status := FControlDispatch.Invoke(Index, GUID_NULL, 0, DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil); if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); end; function TOleCtl.GetShortIntProp(Index: Integer): ShortInt; begin Result := GetIntegerProp(Index); end; function TOleCtl.GetSingleProp(Index: Integer): Single; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VSingle; end; function TOleCtl.GetSmallintProp(Index: Integer): Smallint; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VSmallint; end; function TOleCtl.GetStringProp(Index: Integer): string; begin Result := GetVariantProp(Index); end; function TOleCtl.GetTColorProp(Index: Integer): TColor; begin Result := GetIntegerProp(Index); end; function TOleCtl.GetTDateTimeProp(Index: Integer): TDateTime; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VDate; end; function TOleCtl.GetTFontProp(Index: Integer): PGraphicTool; {var I: Integer;} begin Result := nil; {for I := 0 to FFonts.Count-1 do if FControlData^.FontIDs^[I] = Index then begin Result := TFont(FFonts[I]); if Result.FontAdapter = nil then SetOleFont(Result, GetIDispatchProp(Index) as IFontDisp); end;} //TODO: implement TFont later end; function TOleCtl.GetTOleEnumProp(Index: Integer): TOleEnum; begin Result := GetIntegerProp(Index); end; function TOleCtl.GetVariantProp(Index: Integer): Variant; begin Result := GetOleVariantProp(Index); end; function TOleCtl.GetWideStringProp(Index: Integer): WideString; var Temp: TVarData; begin Result := ''; GetProperty(Index, Temp); Pointer(Result) := Temp.VOleStr; end; function TOleCtl.GetWordBoolProp(Index: Integer): WordBool; var Temp: TVarData; begin GetProperty(Index, Temp); Result := Temp.VBoolean; end; function TOleCtl.GetWordProp(Index: Integer): Word; begin Result := GetIntegerProp(Index); end; procedure TOleCtl.HookControlWndProc; var WndHandle: HWnd; begin if (FOleInPlaceObject <> nil) and (fHandle = 0) then begin WndHandle := 0; FOleInPlaceObject.GetWindow(WndHandle); if WndHandle = 0 then raise EOleError.CreateResFmt(e_Ole, Integer(@SNoWindowHandle), [nil]); fHandle := WndHandle; fDefWndProc := Pointer(GetWindowLong(fHandle, GWL_WNDPROC)); CreatingWindow := @Self; SetWindowLong(fHandle, GWL_WNDPROC, Longint(@WndFunc)); SendMessage(fHandle, WM_NULL, 0, 0); end; end; procedure TOleCtl.Init; var I: Integer; intfClass: TOleCtlIntfClass; begin OleInit; inherited; // overriding this method, we allow for constructor to initialize // the object. fControlClassName := 'OleCtl'; // ClassName {$IFDEF USE_FLAGS} include( fFlagsG3, G3_IsControl ); {$ELSE} fIsControl := TRUE; {$ENDIF} fStyle.Value := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_CHILD; // or WS_BORDER or WS_THICKFRAME; //AttachProc( WndProcCtrl ); for test only // The rest of initialization -- moved from OleCtrls InitControlData; Inc(FControlData^.InstanceCount); if FControlData^.FontCount > 0 then begin FFonts := NewList; //FFonts.Count := FControlData^.FontCount; for I := 0 to FControlData^.FontCount-1 do FFonts.Add( NewFont ); end; {if FControlData^.PictureCount > 0 then begin FPictures := NewList; //FPictures.Count := FControlData^.PictureCount; for I := 0 to FControlData^.PictureCount-1 do begin FPictures.Add( NewPicture ); TPicture(FPictures[I]).OnChange := PictureChanged; end; end;} FEventDispatch := TEventDispatch.Create(@Self); CreateInstance; InitControlInterface(FOleObject); OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus)); if (Assigned(OnGetIntfClass)) then intfClass := OnGetIntfClass() else intfClass := TOleCtlIntf; fOleCtlIntf := intfClass.Create; fOleCtlIntf.fOleCtl := @Self; if (FControlData^.Reserved and cdDeferSetClientSite) = 0 then if ((FMiscStatus and OLEMISC_SETCLIENTSITEFIRST) <> 0) or ((FControlData^.Reserved and cdForceSetClientSite) <> 0) then OleCheck(FOleObject.SetClientSite(fOleCtlIntf)); OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream)); if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then {$IFDEF USE_FLAGS} exclude( fStyle.f3_Style, F3_Visible ); {$ELSE} fVisible := False; {$ENDIF} {if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else ControlStyle := [csDoubleClicks, csNoStdEvents];} if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then fExStyle := 0; // clear WS_EX_CONTROLPARENT TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or OLEMISC_NOUIACTIVATE) = 0; OleCheck(fOleCtlIntf.RequestNewObjectLayout); end; procedure TOleCtl.InitControlData; begin // nothing here. Originally, this method was abstract. // Since TOleControl class became TOleCtl object, abstract methods // are not available. So, make this method empty to override it // in descendant objects, which represent Active-X controls. end; procedure TOleCtl.InitControlInterface(const Obj: IUnknown); begin // This method is to override it in derived Active-X control holder. end; procedure TOleCtl.InvokeEvent(DispID: TDispID; var Params: TDispParams); var EventMethod: TMethod; begin if ControlData.Version < 300 then D2InvokeEvent(DispID, Params) else begin fOleCtlIntf.GetEventMethod(DispID, EventMethod); if Integer(EventMethod.Code) < $10000 then Exit; try asm PUSH EBX PUSH ESI MOV ESI, Params MOV EBX, [ESI].TDispParams.cArgs TEST EBX, EBX JZ @@7 MOV ESI, [ESI].TDispParams.rgvarg MOV EAX, EBX SHL EAX, 4 // count * sizeof(TVarArg) XOR EDX, EDX ADD ESI, EAX // EDI = Params.rgvarg^[ArgCount] @@1: SUB ESI, 16 // Sizeof(TVarArg) MOV EAX, dword ptr [ESI] CMP AX, varSingle JA @@3 JE @@4 @@2: TEST DL,DL JNE @@2a MOV ECX, ESI INC DL TEST EAX, varArray JNZ @@6 MOV ECX, dword ptr [ESI+8] JMP @@6 @@2a: TEST EAX, varArray JZ @@5 PUSH ESI JMP @@6 @@3: CMP AX, varDate JA @@2 @@4: PUSH dword ptr [ESI+12] @@5: PUSH dword ptr [ESI+8] @@6: DEC EBX JNE @@1 @@7: MOV EDX, Self MOV EAX, EventMethod.Data CALL EventMethod.Code POP ESI POP EBX end; except DoHandleException; end; end; end; procedure TOleCtl.KeyDown(var Key: Longint; AShift: DWORD); begin if Assigned(EV.fOnKeyDown) then EV.fOnKeyDown(@Self, Key, AShift); end; procedure TOleCtl.KeyPress(var Key: KOLChar); begin if Assigned(EV.fOnChar) then EV.fOnChar(@Self, Key, 0); end; procedure TOleCtl.KeyUp(var Key: Longint; AShift: DWORD); begin if Assigned(EV.fOnKeyUp) then EV.fOnKeyUp(@Self, Key, AShift); end; procedure TOleCtl.MouseDown(Button: TMouseButton; AShift: DWORD; X, Y: Integer); begin //TODO: mouse end; procedure TOleCtl.MouseMove(AShift: DWORD; X, Y: Integer); begin //TODO: mouse end; procedure TOleCtl.MouseUp(Button: TMouseButton; AShift: DWORD; X, Y: Integer); begin //TODO: mouse end; procedure TOleCtl.SetByteProp(Index: Integer; Value: Byte); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.SetColorProp(Index: Integer; Value: TColor); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.SetCompProp(Index: Integer; const Value: Comp); var Temp: TVarData; begin Temp.VType := VT_I8; Temp.VDouble := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetCurrencyProp(Index: Integer; const Value: Currency); var Temp: TVarData; begin Temp.VType := varCurrency; Temp.VCurrency := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetDoubleProp(Index: Integer; const Value: Double); var Temp: TVarData; begin Temp.VType := varDouble; Temp.VDouble := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetIDispatchProp(Index: Integer; const Value: IDispatch); var Temp: TVarData; begin Temp.VType := varDispatch; Temp.VDispatch := Pointer(Value); SetProperty(Index, Temp); end; procedure TOleCtl.SetIntegerProp(Index, Value: Integer); var Temp: TVarData; begin Temp.VType := varInteger; Temp.VInteger := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetIUnknownProp(Index: Integer; const Value: IUnknown); var Temp: TVarData; begin Temp.VType := VT_UNKNOWN; Temp.VUnknown := Pointer(Value); SetProperty(Index, Temp); end; (*procedure TOleCtl.SetMouseDblClk(const Value: TOnMouse); begin {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} .fOnMouseDblClk := Value; end;*) procedure TOleCtl.SetName(const Value: String); var OldName: string; DispID: Integer; begin OldName := Name; Name := Value; //inherited SetName(Value); if FOleControl <> nil then begin FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME); if FControlData^.Flags and (cfCaption or cfText) <> 0 then begin if FControlData^.Flags and cfCaption <> 0 then DispID := DISPID_CAPTION else DispID := DISPID_TEXT; if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value); end; end; end; procedure TOleCtl.SetOleBoolProp(Index: Integer; Value: TOleBool); var Temp: TVarData; begin Temp.VType := varBoolean; if Value then Temp.VBoolean := WordBool(-1) else Temp.VBoolean := WordBool(0); SetProperty(Index, Temp); end; procedure TOleCtl.SetOleDateProp(Index: Integer; const Value: TOleDate); var Temp: TVarData; begin Temp.VType := varDate; Temp.VDate := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetOleEnumProp(Index: Integer; Value: TOleEnum); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.SetOleVariantProp(Index: Integer; const Value: OleVariant); begin SetProperty(Index, TVarData(Value)); end; procedure TOleCtl.SetOnChar(const Value: TOnChar); begin {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} .fOnChar := Value; end; procedure TOleCtl.SetOnLeave(const Value: TOnEvent); begin OnExit := Value; end; procedure TOleCtl.SetParent(AParent: PControl); var CS: IOleClientSite; X: Integer; begin inherited Parent := AParent; if (AParent <> nil) then begin try // work around ATL bug X := FOleObject.GetClientSite(CS); except X := -1; end; if (X <> 0) or (CS = nil) then OleCheck(FOleObject.SetClientSite(fOleCtlIntf)); if FOleControl <> nil then FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN); end; end; procedure TOleCtl.SetProperty(Index: Integer; const Value: TVarData); const DispIDArgs: Longint = DISPID_PROPERTYPUT; var Status, InvKind: Integer; DispParams: TDispParams; ExcepInfo: TExcepInfo; begin CreateControl; DispParams.rgvarg := @Value; DispParams.rgdispidNamedArgs := @DispIDArgs; DispParams.cArgs := 1; DispParams.cNamedArgs := 1; if Value.VType <> varDispatch then InvKind := DISPATCH_PROPERTYPUT else InvKind := DISPATCH_PROPERTYPUTREF; Status := FControlDispatch.Invoke(Index, GUID_NULL, 0, InvKind, DispParams, nil, @ExcepInfo, nil); if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); end; procedure TOleCtl.SetShortIntProp(Index: Integer; Value: Shortint); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.SetSingleProp(Index: Integer; const Value: Single); var Temp: TVarData; begin Temp.VType := varSingle; Temp.VSingle := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetSmallintProp(Index: Integer; Value: Smallint); var Temp: TVarData; begin Temp.VType := varSmallint; Temp.VSmallint := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetStringProp(Index: Integer; const Value: string); var Temp: TVarData; begin Temp.VType := varOleStr; Temp.VOleStr := StringToOleStr(Value); try SetProperty(Index, Temp); finally SysFreeString(Temp.VOleStr); end; end; procedure TOleCtl.SetTColorProp(Index: Integer; Value: TColor); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.SetTDateTimeProp(Index: Integer; const Value: TDateTime); var Temp: TVarData; begin Temp.VType := varDate; Temp.VDate := Value; SetProperty(Index, Temp); end; procedure TOleCtl.SetTFontProp(Index: Integer; Value: PGraphicTool); {var I: Integer; F: TFont; Temp: IFontDisp;} begin {for I := 0 to FFonts.Count-1 do if FControlData^.FontIDs^[I] = Index then begin F := TFont(FFonts[I]); F.Assign(Value); if F.FontAdapter = nil then begin GetOleFont(F, Temp); SetIDispatchProp(Index, Temp); end; end;} //TODO: implement TFont property later end; procedure TOleCtl.SetTOleEnumProp(Index: Integer; Value: TOleEnum); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.SetUIActive(Active: Boolean); var Form: POleCtl; // declare it as POleCtl, though it is only PControl // - to access its protected fields begin Form := POleCtl( ParentForm ); if Form <> nil then if Active then begin {if (Form.ActiveOleControl <> nil) and (Form.ActiveOleControl <> Self) then Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0); Form.ActiveOleControl := Self;} if (Form.DF.fCurrentControl <> nil) and (Form.DF.fCurrentControl <> @Self) then Form.DF.fCurrentControl.Perform(CM_UIDEACTIVATE, 0, 0); Form.DF.fCurrentControl := @Self; end else if Form.DF.fCurrentControl = @Self then Form.DF.fCurrentControl := nil; end; procedure TOleCtl.SetVariantProp(Index: Integer; const Value: Variant); begin SetOleVariantProp(Index, Value); end; procedure TOleCtl.SetWideStringProp(Index: Integer; const Value: WideString); var Temp: TVarData; begin Temp.VType := varOleStr; if Value <> '' then Temp.VOleStr := PWideChar(Value) else Temp.VOleStr := nil; SetProperty(Index, Temp); end; procedure TOleCtl.SetWordBoolProp(Index: Integer; Value: WordBool); var Temp: TVarData; begin Temp.VType := varBoolean; if Value then Temp.VBoolean := WordBool(-1) else Temp.VBoolean := WordBool(0); SetProperty(Index, Temp); end; procedure TOleCtl.SetWordProp(Index: Integer; Value: Word); begin SetIntegerProp(Index, Value); end; procedure TOleCtl.StandardEvent(DispID: TDispID; var Params: TDispParams); type PVarDataList = ^TVarDataList; TVarDataList = array[0..3] of TVarData; const {ShiftMap: array[0..7] of TShiftState = ( [], [ssShift], [ssCtrl], [ssShift, ssCtrl], [ssAlt], [ssShift, ssAlt], [ssCtrl, ssAlt], [ssShift, ssCtrl, ssAlt]); MouseMap: array[0..7] of TShiftState = ( [], [ssLeft], [ssRight], [ssLeft, ssRight], [ssMiddle], [ssLeft, ssMiddle], [ssRight, ssMiddle], [ssLeft, ssRight, ssMiddle]);} ShiftMap: array[0..7] of DWord = ( 0, MK_SHIFT, MK_CONTROL, MK_SHIFT or MK_CONTROL, MK_ALT, MK_SHIFT or MK_ALT, MK_CONTROL or MK_ALT, MK_SHIFT or MK_CONTROL or MK_ALT); MouseMap: array[0..7] of DWORD = ( 0, MK_LBUTTON, MK_RBUTTON, MK_LBUTTON or MK_RBUTTON, MK_MBUTTON, MK_LBUTTON or MK_MBUTTON, MK_RBUTTON or MK_MBUTTON, MK_LBUTTON or MK_RBUTTON or MK_MBUTTON); ButtonMap: array[0..7] of TMouseButton = ( mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft); var Args: PVarDataList; AShift: DWORD; Button: TMouseButton; X, Y: Integer; Key: Longint; Ch: KOLChar; begin Args := PVarDataList(Params.rgvarg); try case DispID of DISPID_CLICK: Click; DISPID_DBLCLICK: DblClk; DISPID_KEYDOWN, DISPID_KEYUP: if Params.cArgs >= 2 then begin Key := Variant(Args^[1]); X := Variant(Args^[0]); case DispID of DISPID_KEYDOWN: KeyDown(Key, X); DISPID_KEYUP: KeyUp(Key, X); end; if ((Args^[1].vType and varByRef) <> 0) then Word(Args^[1].VPointer^) := Key; end; DISPID_KEYPRESS: if Params.cArgs > 0 then begin Ch := KOLChar(Integer(Variant(Args^[0]))); KeyPress(Ch); if ((Args^[0].vType and varByRef) <> 0) then KOLChar(Args^[0].VPointer^) := Ch; end; {DISPID_KEYPRESS: if Params.cArgs > 0 then begin Ch := KOLChar(Integer(Variant(Args^[0]))); KeyPress(Ch); if ((Args^[0].vType and varByRef) <> 0) then KOLChar(Args^[0].VPointer^) := Ch; end;} DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP: if Params.cArgs >= 4 then begin X := Integer(Variant(Args^[3])) and 7; Y := Integer(Variant(Args^[2])) and 7; Button := ButtonMap[X]; AShift := ShiftMap[Y] + MouseMap[X]; X := Variant(Args^[1]); Y := Variant(Args^[0]); case DispID of DISPID_MOUSEDOWN: MouseDown(Button, AShift, X, Y); DISPID_MOUSEMOVE: MouseMove(AShift, X, Y); DISPID_MOUSEUP: MouseUp(Button, AShift, X, Y); end; end; end; except DoHandleException; end; end; {$IFNDEF _D2orD3} { TServerEventDispatch } constructor TServerEventDispatch.Create(Server: TOleServer); begin FServer := Server; InternalRefCount := 1; end; { TServerEventDispatch.IUnknown } function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then begin Result := S_OK; Exit; end; if IsEqualIID(IID, FServer.FServerData^.EventIID) then begin GetInterface(IDispatch, Obj); Result := S_OK; Exit; end; Result := E_NOINTERFACE; end; function TServerEventDispatch._AddRef: Integer; begin if FServer <> nil then FServer._AddRef; InternalRefCount := InternalRefCount + 1; Result := InternalRefCount; end; function TServerEventDispatch._Release: Integer; begin if FServer <> nil then FServer._Release; InternalRefCount := InternalRefCount -1; Result := InternalRefCount; end; { TServerEventDispatch.IDispatch } function TServerEventDispatch.GetTypeInfoCount(out Count: Integer): HResult; begin Count := 0; Result:= S_OK; end; function TServerEventDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Pointer(TypeInfo) := nil; Result := E_NOTIMPL; end; function TServerEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin Result := E_NOTIMPL; end; function TServerEventDispatch.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; var ParamCount, I: integer; VarArray : TVariantArray; begin // Get parameter count ParamCount := TDispParams(Params).cArgs; // Set our array to appropriate length SetLength(VarArray, ParamCount); // Copy over data for I := Low(VarArray) to High(VarArray) do VarArray[High(VarArray)-I] := OleVariant(TDispParams(Params).rgvarg^[I]); // Invoke Server proxy class if FServer <> nil then FServer.InvokeEvent(DispID, VarArray); // Clean array SetLength(VarArray, 0); // Pascal Events return 'void' - so assume success! Result := S_OK; end; function TServerEventDispatch.ServerDisconnect : Boolean; begin FServer := nil; if FServer <> nil then Result := false else Result := true; end; {TOleServer} constructor TOleServer.Create; //(AOwner: TComponent); begin inherited; // Create(AOwner); // Allow derived class to initialize ServerData structure pointer InitServerData; // Make sure derived class set ServerData pointer to some valid structure Assert(FServerData <> nil); // Increment instance count (not used currently) Inc(FServerData^.InstanceCount); // Create Event Dispatch Handler FEventDispatch := TServerEventDispatch.Create(Self); end; destructor TOleServer.Destroy; begin // Disconnect from the Server (NOTE: Disconnect must handle case when we're no longer connected) Disconnect; // Free Events dispatcher FEventDispatch.ServerDisconnect; if (FEventDispatch._Release = 0) then FEventDispatch.Free; // Decrement refcount Dec(FServerData^.InstanceCount); inherited Destroy; end; procedure TOleServer.Loaded; begin {inherited Loaded;} // Load Server if user requested 'AutoConnect' and we're not in Design mode {if not (csDesigning in ComponentState) then} if AutoConnect then Connect; end; procedure TOleServer.InvokeEvent(DispID: TDispID; var Params: TVariantArray); begin // To be overriden in derived classes to do dispatching end; function TOleServer.GetServer: IUnknown; var HR: HResult; ErrorStr: string; begin case ConnectKind of ckNewInstance: Result := CreateComObject(FServerData^.ClassId); ckRunningInstance: begin HR := GetActiveObject(FServerData^.ClassId, nil, Result); if not Succeeded(HR) then begin ErrorStr := Format(sNoRunningObject, [ClassIDToProgID(FServerData^.ClassId), GuidToString(FServerData^.ClassId)]); raise EOleSysError.Create( e_Ole, ErrorStr {, HR, 0} ); end; end; ckRunningOrNew: if not Succeeded(GetActiveObject(FServerData^.ClassId, nil, Result)) then Result := CreateComObject(FServerData^.ClassId); ckRemote: {Highly inefficient: requires at least two round trips - GetClassObject + QI} Result := CreateRemoteComObject(RemoteMachineName, FServerData^.ClassID); end; end; procedure TOleServer.ConnectEvents(const Obj: IUnknown); begin KOLComObj.InterfaceConnect(Obj, FServerData^.EventIID, FEventDispatch, FEventsConnection); end; procedure TOleServer.DisconnectEvents(const Obj: Iunknown); begin KOLComObj.InterfaceDisconnect(Obj, FServerData^.EventIID, FEventsConnection); end; function TOleServer.GetConnectKind: TConnectKind; begin // Should the setting of a RemoteMachine name override the Connection Kind ?? if RemoteMachineName <> '' then Result := ckRemote else Result := FConnectKind; end; procedure TOleServer.SetConnectKind(cK: TConnectKind); begin // Should we validate that we have a RemoteMachineName for ckRemote ?? FConnectKind := cK; end; function TOleServer.GetAutoConnect: Boolean; begin // If user wants to provide the interface to connect to, then we won't // 'automatically' connect to a server. if ConnectKind = ckAttachToInterface then Result := False else Result := FAutoConnect; end; procedure TOleServer.SetAutoConnect(flag: Boolean); begin FAutoConnect := flag; end; { TOleServer.IUnknown } function TOleServer.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; function TOleServer._AddRef: Integer; begin Inc(FRefCount); Result := FRefCount; end; function TOleServer._Release: Integer; begin Dec(FRefCount); Result := FRefCount; end; {$ENDIF _D2orD3} { TEventDispatch } constructor TEventDispatch.Create(Control: POleCtl); begin FControl := Control; end; { TEventDispatch.IUnknown } function TEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then begin Result := S_OK; Exit; end; if IsEqualIID(IID, FControl.FControlData^.EventIID) then begin GetInterface(IDispatch, Obj); Result := S_OK; Exit; end; Result := E_NOINTERFACE; end; function TEventDispatch._AddRef: Integer; begin Result := FControl.fOleCtlIntf._AddRef; end; function TEventDispatch._Release: Integer; begin Result := FControl.fOleCtlIntf._Release; end; { TEventDispatch.IDispatch } function TEventDispatch.GetTypeInfoCount(out Count: Integer): HResult; begin Count := 0; Result := S_OK; end; function TEventDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Pointer(TypeInfo) := nil; Result := E_NOTIMPL; end; function TEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin Result := E_NOTIMPL; end; function TEventDispatch.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; begin if (DispID >= DISPID_MOUSEUP) and (DispID <= DISPID_CLICK) then FControl.StandardEvent(DispID, TDispParams(Params)) else FControl.InvokeEvent(DispID, TDispParams(Params)); Result := S_OK; end; { TOleCtlIntf } function TOleCtlIntf._AddRef: Integer; begin //{$IFDEF _D2orD3} //Result := inherited _AddRef; //{$ELSE} Inc(FRefCount); Result := FRefCount; //{$ENDIF} end; function TOleCtlIntf._Release: Integer; begin //{$IFDEF _D2orD3} //Result := inherited _Release; //{$ELSE} Dec(FRefCount); Result := FRefCount; //{$ENDIF} end; function TOleCtlIntf.CanInPlaceActivate: HResult; begin Result := S_OK; end; function TOleCtlIntf.ContextSensitiveHelp(fEnterMode: BOOL): HResult; begin Result := S_OK; end; function TOleCtlIntf.DeactivateAndUndo: HResult; begin fOleCtl.FOleInPlaceObject.UIDeactivate; Result := S_OK; end; function TOleCtlIntf.DiscardUndoState: HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.EnableModeless(fEnable: BOOL): HResult; begin Result := S_OK; end; function TOleCtlIntf.GetBorder(out rectBorder: TRect): HResult; begin Result := INPLACE_E_NOTOOLSPACE; end; function TOleCtlIntf.GetContainer(out container: IOleContainer): HResult; begin Result := E_NOINTERFACE; end; function TOleCtlIntf.GetExtendedControl(out disp: IDispatch): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.GetMoniker(dwAssign, dwWhichMoniker: Integer; out mk: IMoniker): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Pointer(TypeInfo) := nil; Result := E_NOTIMPL; end; function TOleCtlIntf.GetTypeInfoCount(out Count: Integer): HResult; begin Count := 0; Result := S_OK; end; function TOleCtlIntf.GetWindowContext(out frame: IOleInPlaceFrame; out doc: IOleInPlaceUIWindow; out rcPosRect, rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult; begin frame := Self; doc := nil; rcPosRect := fOleCtl.BoundsRect; rcClipRect := MakeRect( 0, 0, 32767, 32767 ); with frameInfo do begin fMDIApp := False; hWndFrame := fOleCtl.ParentForm.GetWindowHandle; //GetTopParentHandle; // now it is not possible to make alien window to be parent for KOL window hAccel := 0; cAccelEntries := 0; end; Result := S_OK; end; function TOleCtlIntf.InsertMenus(hmenuShared: HMenu; var menuWidths: TOleMenuGroupWidths): HResult; {var Menu: TMainMenu;} begin {Menu := GetMainMenu; if Menu <> nil then Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);} //TODO: implement menu populate Result := S_OK; end; function TOleCtlIntf.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; {var F: PGraphicTool;} begin if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then begin Result := S_OK; case DispID of DISPID_AMBIENT_BACKCOLOR: PVariant(VarResult)^ := fOleCtl.Color; DISPID_AMBIENT_DISPLAYNAME: PVariant(VarResult)^ := StringToVarOleStr( fOleCtl.Name ); DISPID_AMBIENT_FONT: begin {if (fOleCtl.Parent <> nil) and fOleCtl.ParentFont then F := Parent.Font // TOleControl(Parent).Font else F := Font; PVariant(VarResult)^ := FontToOleFont(F);} //TODO: implement Font later end; DISPID_AMBIENT_FORECOLOR: PVariant(VarResult)^ := fOleCtl.fTextColor; // Font.Color; DISPID_AMBIENT_LOCALEID: PVariant(VarResult)^ := Integer(GetUserDefaultLCID); DISPID_AMBIENT_MESSAGEREFLECT: PVariant(VarResult)^ := True; DISPID_AMBIENT_USERMODE: PVariant(VarResult)^ := TRUE; // not (csDesigning in ComponentState); DISPID_AMBIENT_UIDEAD: PVariant(VarResult)^ := FALSE; // 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; function TOleCtlIntf.LockInPlaceActive(fLock: BOOL): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.OleControlSite_TranslateAccelerator(msg: PMsg; grfModifiers: Integer): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; begin wnd := fOleCtl.ParentForm.GetWindowHandle; // GetTopParentHandle; Result := S_OK; end; function TOleCtlIntf.OleInPlaceFrame_TranslateAccelerator(var msg: Windows.TMsg; wID: Word): HResult; begin Result := S_FALSE; end; function TOleCtlIntf.OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; begin Result := S_OK; wnd := fOleCtl.ParentWindow; if wnd = 0 then Result := E_FAIL; end; function TOleCtlIntf.OnChanged(dispid: TDispID): HResult; begin try case dispid of DISPID_BACKCOLOR: if not fOleCtl.FUpdatingColor then begin fOleCtl.FUpdatingColor := True; try fOleCtl.fColor := fOleCtl.GetIntegerProp(DISPID_BACKCOLOR); finally fOleCtl.FUpdatingColor := False; end; end; DISPID_ENABLED: if not fOleCtl.FUpdatingEnabled then begin fOleCtl.FUpdatingEnabled := True; try fOleCtl.Enabled := fOleCtl.GetWordBoolProp(DISPID_ENABLED); finally fOleCtl.FUpdatingEnabled := False; end; end; DISPID_FONT: if not fOleCtl.FUpdatingFont then begin fOleCtl.FUpdatingFont := True; try //OleFontToFont(GetVariantProp(DISPID_FONT), Font); // font - implement later finally fOleCtl.FUpdatingFont := False; end; end; DISPID_FORECOLOR: if not fOleCtl.FUpdatingFont then begin fOleCtl.FUpdatingFont := True; try fOleCtl.fTextColor := fOleCtl.GetIntegerProp(DISPID_FORECOLOR); //Font.Color := GetIntegerProp(DISPID_FORECOLOR); finally fOleCtl.FUpdatingFont := False; end; end; end; except // control sent us a notification for a dispid it doesn't have. //on EOleError do ; end; Result := S_OK; end; function TOleCtlIntf.OnControlInfoChanged: HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.OnFocus(fGotFocus: BOOL): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.OnInPlaceActivate: HResult; begin fOleCtl.FOleObject.QueryInterface( IOleInPlaceObject, fOleCtl.FOleInPlaceObject); fOleCtl.FOleObject.QueryInterface( IOleInPlaceActiveObject, fOleCtl.FOleInPlaceActiveObject); Result := S_OK; end; function TOleCtlIntf.OnInPlaceDeactivate: HResult; begin fOleCtl.FOleInPlaceActiveObject := nil; fOleCtl.FOleInPlaceObject := nil; Result := S_OK; end; function TOleCtlIntf.OnPosRectChange(const rcPosRect: TRect): HResult; begin fOleCtl.FOleInPlaceObject.SetObjectRects(rcPosRect, MakeRect(0, 0, 32767, 32767)); Result := S_OK; end; function TOleCtlIntf.OnRequestEdit(dispid: TDispID): HResult; begin Result := S_OK; end; function TOleCtlIntf.OnShowWindow(fShow: BOOL): HResult; begin Result := S_OK; end; function TOleCtlIntf.OnUIActivate: HResult; begin fOleCtl.SetUIActive(True); Result := S_OK; end; function TOleCtlIntf.OnUIDeactivate(fUndoable: BOOL): HResult; begin SetMenu(0, 0, 0); fOleCtl.SetUIActive(False); Result := S_OK; end; function TOleCtlIntf.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer; out res: Integer; Cookie: Integer): HResult; begin Result := S_OK; end; function TOleCtlIntf.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer; out res, Cookie: Integer): HResult; begin Result := S_OK; end; function TOleCtlIntf.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; function TOleCtlIntf.RemoveMenus(hmenuShared: HMenu): HResult; begin while GetMenuItemCount(hmenuShared) > 0 do RemoveMenu(hmenuShared, 0, MF_BYPOSITION); Result := S_OK; end; function TOleCtlIntf.RequestBorderSpace( const borderwidths: TRect): HResult; begin Result := INPLACE_E_NOTOOLSPACE; end; function TOleCtlIntf.RequestNewObjectLayout: HResult; var Extent: TPoint; W, H: Integer; DC: HDC; PixelsPerInch: Integer; begin Result := fOleCtl.FOleObject.GetExtent(DVASPECT_CONTENT, Extent); if Result <> S_OK then Exit; W := fOleCtl.Width; H := fOleCtl.Height; if (W = 0) or (H = 0) then begin DC := GetDC(0); PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY); ReleaseDC(0, DC); W := MulDiv(Extent.X, PixelsPerInch, 2540); H := MulDiv(Extent.Y, PixelsPerInch, 2540); if (fOleCtl.FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) and (fOleCtl.FOleControl = nil) then begin if W > 32 then W := 32; if H > 32 then H := 32; end; end; fOleCtl.SetBoundsRect( MakeRect( fOleCtl.Left, fOleCtl.Top, fOleCtl.Left + W, fOleCtl.Top + H ) ); end; function TOleCtlIntf.SaveObject: HResult; begin Result := S_OK; end; function TOleCtlIntf.Scroll(scrollExtent: TPoint): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.SetActiveObject( const activeObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult; begin Result := S_OK; end; function TOleCtlIntf.SetBorderSpace(pborderwidths: PRect): HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.SetMenu(hmenuShared, holemenu: HMenu; hwndActiveObject: HWnd): HResult; var Menu: HMenu; begin Menu := fOleCtl.GetMainMenu; Result := S_OK; if Menu <> 0 then begin //Menu.SetOle2MenuHandle(hmenuShared); Result := OleSetMenuDescriptor( holemenu, fOleCtl.ParentForm.GetWindowHandle, hwndActiveObject, nil, nil); end; end; function TOleCtlIntf.SetStatusText(pszStatusText: POleStr): HResult; begin Result := S_OK; end; function TOleCtlIntf.ShowObject: HResult; begin fOleCtl.HookControlWndProc; Result := S_OK; end; function TOleCtlIntf.ShowPropertyFrame: HResult; begin Result := E_NOTIMPL; end; function TOleCtlIntf.TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF; flags: Integer): HResult; var DC: HDC; PixelsPerInch: Integer; begin DC := GetDC(0); PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY); ReleaseDC(0, DC); if flags and XFORMCOORDS_HIMETRICTOCONTAINER <> 0 then begin ptfContainer.X := MulDiv(ptlHimetric.X, PixelsPerInch, 2540); ptfContainer.Y := MulDiv(ptlHimetric.Y, PixelsPerInch, 2540); end else begin ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / PixelsPerInch)); ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / PixelsPerInch)); end; Result := S_OK; end; constructor TOleCtlIntf.Create; begin inherited; end; end.