6bff0274cd
git-svn-id: https://svn.code.sf.net/p/kolmck/code@119 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2650 lines
76 KiB
ObjectPascal
2650 lines
76 KiB
ObjectPascal
{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.
|