units/activekol/ActiveKOL.pas

   1 unit ActiveKOL;
   2
   3 interface
   4
   5 uses
   6   windows, messages, KOL, ActiveX, KOLComObj, err;
   7
   8 {$I KOLDEF.INC}
   9 {$IFDEF _D6orHigher}
  10   //{$WARN SYMBOL_DEPRECATED OFF}
  11   {$WARN SYMBOL_PLATFORM OFF}
  12   {$WARN UNSAFE_TYPE OFF}
  13   {$WARN UNSAFE_CAST OFF}
  14   {$WARN UNSAFE_CODE OFF}
  15 {$ENDIF}
  16
  17 {$IFNDEF _D5orHigher}
  18 const
  19   sNoRunningObject = 'Unable to retrieve a pointer to a running object registered with OLE for %s/%s';
  20 {$ENDIF}
  21
  22 type
  23   POleCtl = ^TOleCtl;
  24
  25   TEventDispatch = class(TObject, IUnknown, IDispatch)
  26   private
  27     FControl: POleCtl;
  28   protected
  29     { IUnknown }
  30     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  31     function _AddRef: Integer; stdcall;
  32     function _Release: Integer; stdcall;
  33     { IDispatch }
  34     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  35     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  36     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  37       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  38     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  39       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  40     property Control: POleCtl read FControl;
  41   public
  42     constructor Create(Control: POleCtl);
  43   end;
  44
  45   {$IFNDEF _D5orHigher}
  46   TOleEnum = type Integer;
  47   //{$NODEFINE TOleEnum}
  48   {$ENDIF}
  49
  50   TGetStrProc = procedure(const S: string) of object;
  51
  52   TEnumValue = record
  53     Value: Longint;
  54     Ident: string;
  55   end;
  56
  57   PEnumValueList = ^TEnumValueList;
  58   TEnumValueList = array[0..32767] of TEnumValue;
  59
  60   PEnumPropDesc = ^TEnumPropDesc;
  61   TEnumPropDesc = object(TObj)
  62   private
  63     FDispID: Integer;
  64     FValueCount: Integer;
  65     FValues: PEnumValueList;
  66   public
  67     constructor Create(DispID, ValueCount: Integer;
  68       const TypeInfo: ITypeInfo);
  69     destructor Destroy; virtual;
  70     procedure GetStrings(Proc: TGetStrProc);
  71     function StringToValue(const S: string): Integer;
  72     function ValueToString(V: Integer): string;
  73   end;
  74
  75   PControlData = ^TControlData;
  76   TControlData = record
  77     ClassID: TGUID;
  78     EventIID: TGUID;
  79     EventCount: Longint;
  80     EventDispIDs: Pointer;
  81     LicenseKey: Pointer;
  82     Flags: DWORD;
  83     Version: Integer;
  84     FontCount: Integer;
  85     FontIDs: PDispIDList;
  86     PictureCount: Integer;
  87     PictureIDs: PDispIDList;
  88     Reserved: Integer;
  89     InstanceCount: Integer;
  90     EnumPropDescs: PList;
  91   end;
  92
  93   PControlData2 = ^TControlData2;
  94   TControlData2 = record
  95     ClassID: TGUID;
  96     EventIID: TGUID;
  97     EventCount: Longint;
  98     EventDispIDs: Pointer;
  99     LicenseKey: Pointer;
 100     Flags: DWORD;
 101     Version: Integer;
 102     FontCount: Integer;
 103     FontIDs: PDispIDList;
 104     PictureCount: Integer;
 105     PictureIDs: PDispIDList;
 106     Reserved: Integer;
 107     InstanceCount: Integer;
 108     EnumPropDescs: PList;
 109     FirstEventOfs: Cardinal;
 110   end;
 111
 112   TOleCtlIntf = class( TObject, IUnknown, IOleClientSite,
 113     IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch,
 114     IPropertyNotifySink, ISimpleFrameSite)
 115   private
 116     FRefCount: Integer;
 117     fOleCtl: POleCtl;
 118     procedure GetEventMethod(DispID: TDispID; var Method: TMethod);
 119   protected
 120     { IUnknown }
 121     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override;
 122     function _AddRef: Integer; stdcall;
 123     function _Release: Integer; stdcall;
 124     { IOleClientSite }
 125     function SaveObject: HResult; stdcall;
 126     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
 127       out mk: IMoniker): HResult; stdcall;
 128     function GetContainer(out container: IOleContainer): HResult; stdcall;
 129     function ShowObject: HResult; stdcall;
 130     function OnShowWindow(fShow: BOOL): HResult; stdcall;
 131     function RequestNewObjectLayout: HResult; stdcall;
 132     { IOleControlSite }
 133     function OnControlInfoChanged: HResult; stdcall;
 134     function LockInPlaceActive(fLock: BOOL): HResult; stdcall;
 135     function GetExtendedControl(out disp: IDispatch): HResult; stdcall;
 136     function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
 137       flags: Longint): HResult; stdcall;
 138     function IOleControlSite.TranslateAccelerator = OleControlSite_TranslateAccelerator;
 139     function OleControlSite_TranslateAccelerator(msg: PMsg;
 140       grfModifiers: Longint): HResult; stdcall;
 141     function OnFocus(fGotFocus: BOOL): HResult; stdcall;
 142     function ShowPropertyFrame: HResult; stdcall;
 143     { IOleWindow }
 144     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
 145     { IOleInPlaceSite }
 146     function IOleInPlaceSite.GetWindow = OleInPlaceSite_GetWindow;
 147     function OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; stdcall;
 148     function CanInPlaceActivate: HResult; stdcall;
 149     function OnInPlaceActivate: HResult; stdcall;
 150     function OnUIActivate: HResult; stdcall;
 151     function GetWindowContext(out frame: IOleInPlaceFrame;
 152       out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
 153       out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
 154       stdcall;
 155     function Scroll(scrollExtent: TPoint): HResult; stdcall;
 156     function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall;
 157     function OnInPlaceDeactivate: HResult; stdcall;
 158     function DiscardUndoState: HResult; stdcall;
 159     function DeactivateAndUndo: HResult; stdcall;
 160     function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall;
 161     { IOleInPlaceUIWindow }
 162     function GetBorder(out rectBorder: TRect): HResult; stdcall;
 163     function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
 164     function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
 165     function SetActiveObject(const activeObject: IOleInPlaceActiveObject;
 166       pszObjName: POleStr): HResult; stdcall;
 167     { IOleInPlaceFrame }
 168     function IOleInPlaceFrame.GetWindow = OleInPlaceFrame_GetWindow;
 169     function OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; stdcall;
 170     function InsertMenus(hmenuShared: HMenu;
 171       var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
 172     function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
 173       hwndActiveObject: HWnd): HResult; stdcall;
 174     function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
 175     function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
 176     function EnableModeless(fEnable: BOOL): HResult; stdcall;
 177     function IOleInPlaceFrame.TranslateAccelerator = OleInPlaceFrame_TranslateAccelerator;
 178     function OleInPlaceFrame_TranslateAccelerator(var msg: TMsg;
 179       wID: Word): HResult; stdcall;
 180     { IDispatch }
 181     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
 182     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
 183     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
 184       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
 185     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
 186       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
 187     { ISimpleFrameSite }
 188     function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
 189       out res: Integer; out Cookie: Longint): HResult; stdcall;
 190     function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
 191       out res: Integer; Cookie: Longint): HResult; stdcall;
 192     { IPropertyNotifySink }
 193     function OnChanged(dispid: TDispID): HResult; virtual; stdcall;
 194     function OnRequestEdit(dispid: TDispID): HResult; virtual; stdcall;
 195   public
 196   end;
 197
 198   TOleCtl = object( TControl )
 199   private
 200     function GetOleObject: Variant;
 201     procedure CreateInstance;
 202     function GetOnLeave: TOnEvent;
 203     procedure SetOnLeave(const Value: TOnEvent);
 204     procedure HookControlWndProc;
 205     procedure SetUIActive(Active: Boolean);
 206     procedure CreateControl;
 207     procedure DestroyStorage;
 208     procedure DestroyControl;
 209     procedure StandardEvent(DispID: TDispID; var Params: TDispParams);
 210     procedure SetMouseDblClk(const Value: TOnMouse);
 211     procedure SetOnChar(const Value: TOnChar);
 212   protected
 213     {$IFDEF DELPHI_CODECOMPLETION_BUG}
 214     fNotAvailable: Boolean;
 215     {$ENDIF}
 216     fName: String;
 217     FControlData: PControlData;
 218     FOleObject: IOleObject;
 219     FMiscStatus: Longint;
 220     FFonts: PList;
 221     FPictures: PList;
 222     FEventDispatch: TEventDispatch;
 223     fOleCtlIntf: TOleCtlIntf;
 224     FPersistStream: IPersistStreamInit;
 225     FOleInPlaceObject: IOleInPlaceObject;
 226     FOleInPlaceActiveObject: IOleInPlaceActiveObject;
 227     FOleControl: IOleControl;
 228     FUpdatingColor: Boolean;
 229     FUpdatingFont: Boolean;
 230     FUpdatingEnabled: Boolean;
 231     FObjectData: HGlobal;
 232     FControlDispatch: IDispatch;
 233     FPropBrowsing: IPerPropertyBrowsing;
 234     FPropConnection: Longint;
 235     FEventsConnection: Longint;
 236     fCreatingWnd: Boolean;
 237     procedure Init; virtual;
 238     procedure InitControlData; virtual;
 239     procedure InitControlInterface(const Obj: IUnknown); virtual;
 240     property ControlData: PControlData read FControlData write FControlData;
 241     function GetMainMenu: HMenu;
 242     procedure InvokeEvent(DispID: TDispID; var Params: TDispParams);
 243     procedure D2InvokeEvent(DispID: TDispID; var Params: TDispParams);
 244     procedure DoHandleException;
 245     procedure CreateEnumPropDescs;
 246     procedure DestroyEnumPropDescs;
 247   public
 248     function GetByteProp(Index: Integer): Byte;
 249     function GetColorProp(Index: Integer): TColor;
 250     function GetTColorProp(Index: Integer): TColor;
 251     function GetCompProp(Index: Integer): Comp;
 252     function GetCurrencyProp(Index: Integer): Currency;
 253     function GetDoubleProp(Index: Integer): Double;
 254     function GetIDispatchProp(Index: Integer): IDispatch;
 255     function GetIntegerProp(Index: Integer): Integer;
 256     function GetIUnknownProp(Index: Integer): IUnknown;
 257     function GetWordBoolProp(Index: Integer): WordBool;
 258     function GetTDateTimeProp(Index: Integer): TDateTime;
 259     function GetTFontProp(Index: Integer): PGraphicTool;
 260     function GetOleBoolProp(Index: Integer): TOleBool;
 261     function GetOleDateProp(Index: Integer): TOleDate;
 262     function GetOleEnumProp(Index: Integer): TOleEnum;
 263     function GetTOleEnumProp(Index: Integer): TOleEnum;
 264     function GetOleVariantProp(Index: Integer): OleVariant;
 265     //function GetTPictureProp(Index: Integer): TPicture;
 266     procedure GetProperty(Index: Integer; var Value: TVarData);
 267     function GetShortIntProp(Index: Integer): ShortInt;
 268     function GetSingleProp(Index: Integer): Single;
 269     function GetSmallintProp(Index: Integer): Smallint;
 270     function GetStringProp(Index: Integer): string;
 271     function GetVariantProp(Index: Integer): Variant;
 272     function GetWideStringProp(Index: Integer): WideString;
 273     function GetWordProp(Index: Integer): Word;
 274     procedure SetByteProp(Index: Integer; Value: Byte);
 275     procedure SetColorProp(Index: Integer; Value: TColor);
 276     procedure SetTColorProp(Index: Integer; Value: TColor);
 277     procedure SetCompProp(Index: Integer; const Value: Comp);
 278     procedure SetCurrencyProp(Index: Integer; const Value: Currency);
 279     procedure SetDoubleProp(Index: Integer; const Value: Double);
 280     procedure SetIDispatchProp(Index: Integer; const Value: IDispatch);
 281     procedure SetIntegerProp(Index: Integer; Value: Integer);
 282     procedure SetIUnknownProp(Index: Integer; const Value: IUnknown);
 283     procedure SetName(const Value: String); virtual;
 284     procedure SetWordBoolProp(Index: Integer; Value: WordBool);
 285     procedure SetTDateTimeProp(Index: Integer; const Value: TDateTime);
 286     procedure SetTFontProp(Index: Integer; Value:PGraphicTool);
 287     procedure SetOleBoolProp(Index: Integer; Value: TOleBool);
 288     procedure SetOleDateProp(Index: Integer; const Value: TOleDate);
 289     procedure SetOleEnumProp(Index: Integer; Value: TOleEnum);
 290     procedure SetTOleEnumProp(Index: Integer; Value: TOleEnum);
 291     procedure SetOleVariantProp(Index: Integer; const Value: OleVariant);
 292     procedure SetParent(AParent: PControl); virtual;
 293     //procedure SetTPictureProp(Index: Integer;  Value: TPicture);
 294     procedure SetProperty(Index: Integer; const Value: TVarData);
 295     procedure SetShortIntProp(Index: Integer; Value: Shortint);
 296     procedure SetSingleProp(Index: Integer; const Value: Single);
 297     procedure SetSmallintProp(Index: Integer; Value: Smallint);
 298     procedure SetStringProp(Index: Integer; const Value: string);
 299     procedure SetVariantProp(Index: Integer; const Value: Variant);
 300     procedure SetWideStringProp(Index: Integer; const Value: WideString);
 301     procedure SetWordProp(Index: Integer; Value: Word);
 302
 303     function GetEnumPropDesc(DispID: Integer): PEnumPropDesc;
 304
 305     property  DragCursor: Boolean read fNotAvailable;
 306     property  DragMode  : Boolean read fNotAvailable;
 307     property  ParentShowHint: Boolean read fNotAvailable;
 308     property  PopupMenu: Boolean read fNotAvailable;
 309     property  ShowHint: Boolean read fNotAvailable;
 310     property  OnDragDrop: Boolean read fNotAvailable;
 311     property  OnDragOver: Boolean read fNotAvailable;
 312     property  OnEndDrag: Boolean read fNotAvailable;
 313     property  OnStartDrag: Boolean read fNotAvailable;
 314
 315     property  OnExit: TOnEvent read GetOnLeave write SetOnLeave;
 316     property  OleObject: Variant read GetOleObject;
 317
 318     property  Name: String read fName write fName;
 319     function CreateWindow: Boolean; virtual;
 320     procedure DblClk;
 321     procedure KeyDown(var Key: Longint; AShift: DWORD);
 322     procedure KeyUp(var Key: Longint; AShift: DWORD);
 323     procedure KeyPress(var Key: Char);
 324     procedure MouseDown(Button: TMouseButton; AShift: DWORD;
 325       X, Y: Integer);
 326     procedure MouseMove(AShift: DWORD; X, Y: Integer);
 327     procedure MouseUp(Button: TMouseButton; AShift: DWORD;
 328       X, Y: Integer);
 329
 330     property OnKeyPress: TOnChar read fOnChar write SetOnChar;
 331     property OnDblClick: TOnMouse read fOnMouseDblClk write SetMouseDblClk;
 332
 333     destructor Destroy; virtual;
 334
 335   end;
 336
 337 {$IFNDEF _D2orD3}
 338 type
 339   TVariantArray = Array of OleVariant;
 340   TOleServer    = class;
 341   TConnectKind  = (ckRunningOrNew,          // Attach to a running or create a new instance of the server
 342                    ckNewInstance,           // Create a new instance of the server
 343                    ckRunningInstance,       // Attach to a running instance of the server
 344                    ckRemote,                // Bind to a remote instance of the server
 345                    ckAttachToInterface);    // Don't bind to server, user will provide interface via 'CpnnectTo'
 346
 347   TServerEventDispatch = class(TObject, IUnknown, IDispatch)
 348   private
 349     FServer: TOleServer;
 350     InternalRefCount : Integer;
 351   protected
 352     { IUnknown }
 353     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
 354     function _AddRef: Integer; stdcall;
 355     function _Release: Integer; stdcall;
 356     { IDispatch }
 357     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
 358     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
 359     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
 360       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
 361     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
 362       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
 363     property Server: TOleServer read FServer;
 364     function ServerDisconnect :Boolean;
 365   public
 366     constructor Create(Server: TOleServer);
 367   end;
 368
 369   PServerData = ^TServerData;
 370   TServerData = record
 371     ClassID: TGUID;                   // CLSID of CoClass
 372     IntfIID: TGUID;                   // IID of default interface
 373     EventIID: TGUID;                  // IID of default source interface
 374     LicenseKey: Pointer;              // Pointer to license string (not implemented)
 375     Version: Integer;                 // Version of this structure
 376     InstanceCount: Integer;           // Instance of the Server running
 377   end;
 378
 379   TOleServer = class(TObject, IUnknown)
 380   private
 381     FServerData:        PServerData;
 382     FRefCount:          Longint;
 383     FEventDispatch:     TServerEventDispatch;
 384     FEventsConnection:  Longint;
 385     FAutoConnect:       Boolean;
 386     FRemoteMachineName: string;
 387     FConnectKind:       TConnectKind;
 388
 389   protected
 390       { IUnknown }
 391     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override;
 392     function _AddRef: Integer; stdcall;
 393     function _Release: Integer; stdcall;
 394
 395     procedure Loaded; //override;
 396     procedure InitServerData; virtual; abstract;
 397
 398     function  GetServer: IUnknown; virtual;
 399
 400     procedure ConnectEvents(const Obj: IUnknown);
 401     procedure DisconnectEvents(const Obj: Iunknown);
 402     procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); virtual;
 403
 404     function  GetConnectKind: TConnectKind;
 405     procedure SetConnectKind(ck: TConnectKind);
 406
 407     function  GetAutoConnect: Boolean;
 408     procedure SetAutoConnect(flag: Boolean);
 409
 410     property  ServerData: PServerData read FServerData write FServerData;
 411     property  EventDispatch: TServerEventDispatch read FEventDispatch write FEventDispatch;
 412
 413   public
 414     constructor Create; //(AOwner: TComponent); override;
 415     destructor Destroy; override;
 416
 417     // NOTE: If derived class is generated by TLIBIMP or ImportTypeLibraryCodeGenerator,
 418     //       the derived class will also expose a 'ConnectTo(interface)' function.
 419     //       You must invoke that method if you're using 'ckAttachToInterface' connection
 420     //       kind.
 421     procedure Connect; virtual; abstract;
 422     procedure Disconnect; virtual; abstract;
 423
 424   published
 425     property AutoConnect: Boolean read GetAutoConnect write SetAutoConnect;
 426     property ConnectKind: TConnectKind read GetConnectKind write SetConnectKind;
 427     property RemoteMachineName: string read FRemoteMachineName write FRemoteMachineName;
 428   end;
 429 {$ENDIF}
 430
 431 var
 432   EmptyParam: OleVariant; { "Empty parameter" standard constant which can be
 433                             passed as an optional parameter on a dual interface. }
 434
 435
 436 implementation
 437
 438 uses
 439   OleConst;
 440
 441 const
 442   // The following flags may be or'd into the TControlData.Reserved field to override
 443   // default behaviors.
 444
 445   // cdForceSetClientSite:
 446   //   Call SetClientSite early (in constructor) regardless of misc status flags
 447   cdForceSetClientSite = 1;
 448
 449   // cdDeferSetClientSite:
 450   //   Don't call SetClientSite early.  Takes precedence over cdForceSetClientSite and misc status flags
 451   cdDeferSetClientSite = 2;
 452
 453 const
 454   cfBackColor = $00000001;
 455   cfForeColor = $00000002;
 456   cfFont      = $00000004;
 457   cfEnabled   = $00000008;
 458   cfCaption   = $00000010;
 459   cfText      = $00000020;
 460
 461 const
 462   MaxDispArgs = 32;
 463
 464 type
 465
 466   PDispInfo = ^TDispInfo;
 467   TDispInfo = packed record
 468     DispID: TDispID;
 469     ResType: Byte;
 470     CallDesc: TCallDesc;
 471   end;
 472
 473   TArgKind = (akDWord, akSingle, akDouble);
 474
 475   PEventArg = ^TEventArg;
 476   TEventArg = record
 477     Kind: TArgKind;
 478     Data: array[0..1] of Integer;
 479   end;
 480
 481   TEventInfo = record
 482     Method: TMethod;
 483     Sender: TObject;
 484     ArgCount: Integer;
 485     Args: array[0..MaxDispArgs - 1] of TEventArg;
 486   end;
 487
 488 function StringToVarOleStr(const S: string): Variant;
 489 begin
 490   VarClear(Result);
 491   TVarData(Result).VOleStr := StringToOleStr(S);
 492   TVarData(Result).VType := varOleStr;
 493 end;
 494
 495 { TEnumPropDesc }
 496
 497 constructor TEnumPropDesc.Create(DispID, ValueCount: Integer;
 498   const TypeInfo: ITypeInfo);
 499 var
 500   I: Integer;
 501   VarDesc: PVarDesc;
 502   Name: WideString;
 503 begin
 504   FDispID := DispID;
 505   FValueCount := ValueCount;
 506   FValues := AllocMem(ValueCount * SizeOf(TEnumValue));
 507   for I := 0 to ValueCount - 1 do
 508   begin
 509     OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
 510     try
 511       OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @Name,
 512         nil, nil, nil));
 513       with FValues^[I] do
 514       begin
 515         Value := TVarData(VarDesc^.lpVarValue^).VInteger;
 516         Ident := Name;
 517         while (Length(Ident) > 1) and (Ident[1] = '_') do
 518           Delete(Ident, 1, 1);
 519       end;
 520     finally
 521       TypeInfo.ReleaseVarDesc(VarDesc);
 522     end;
 523   end;
 524 end;
 525
 526 destructor TEnumPropDesc.Destroy;
 527 begin
 528   if FValues <> nil then
 529   begin
 530     Finalize(FValues^[0], FValueCount);
 531     FreeMem(FValues, FValueCount * SizeOf(TEnumValue));
 532   end;
 533   inherited;
 534 end;
 535
 536 procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc);
 537 var
 538   I: Integer;
 539 begin
 540   for I := 0 to FValueCount - 1 do
 541     with FValues^[I] do Proc(Format('%d - %s', [Value, Ident]));
 542 end;
 543
 544 function TEnumPropDesc.StringToValue(const S: string): Integer;
 545 var
 546   I: Integer;
 547 begin
 548   I := 1;
 549   while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I);
 550   if I > 1 then
 551   begin
 552     Result := Str2Int(Copy(S, 1, I - 1));
 553     for I := 0 to FValueCount - 1 do
 554       if Result = FValues^[I].Value then Exit;
 555   end else
 556     for I := 0 to FValueCount - 1 do
 557       with FValues^[I] do
 558         if AnsiCompareText(S, Ident) = 0 then
 559         begin
 560           Result := Value;
 561           Exit;
 562         end;
 563   raise EOleError.CreateResFmt(e_Ole, Integer( @SBadPropValue ), [S]);
 564 end;
 565
 566 function TEnumPropDesc.ValueToString(V: Integer): string;
 567 var
 568   I: Integer;
 569 begin
 570   for I := 0 to FValueCount - 1 do
 571     with FValues^[I] do
 572       if V = Value then
 573       begin
 574         Result := Format('%d - %s', [Value, Ident]);
 575         Exit;
 576       end;
 577   Result := Int2Str(V);
 578 end;
 579
 580 { TOleCtl }
 581
 582 procedure TOleCtl.CreateControl;
 583 var
 584   Stream: IStream;
 585   CS: IOleClientSite;
 586   X: Integer;
 587 begin
 588   if FOleControl = nil then
 589     try
 590       try  // work around ATL bug
 591         X := FOleObject.GetClientSite(CS);
 592       except
 593         X := -1;
 594       end;
 595       if (X <> 0) or (CS = nil) then
 596         OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
 597       if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else
 598       begin
 599         OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
 600         OleCheck(FPersistStream.Load(Stream));
 601         DestroyStorage;
 602       end;
 603       OleCheck(FOleObject.QueryInterface(IOleControl, FOleControl));
 604       OleCheck(FOleObject.QueryInterface(IDispatch, FControlDispatch));
 605       FOleObject.QueryInterface(IPerPropertyBrowsing, FPropBrowsing);
 606       InterfaceConnect(FOleObject, IPropertyNotifySink,
 607         fOleCtlIntf, FPropConnection);
 608       InterfaceConnect(FOleObject, FControlData^.EventIID,
 609         FEventDispatch, FEventsConnection);
 610       if FControlData^.Flags and cfBackColor <> 0 then
 611         fOleCtlIntf.OnChanged(DISPID_BACKCOLOR);
 612       if FControlData^.Flags and cfEnabled <> 0 then
 613         fOleCtlIntf.OnChanged(DISPID_ENABLED);
 614       if FControlData^.Flags and cfFont <> 0 then
 615         fOleCtlIntf.OnChanged(DISPID_FONT);
 616       if FControlData^.Flags and cfForeColor <> 0 then
 617         fOleCtlIntf.OnChanged(DISPID_FORECOLOR);
 618       FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN);
 619       fOleCtlIntf.RequestNewObjectLayout;
 620     except
 621       DestroyControl;
 622       raise;
 623     end;
 624 end;
 625
 626 procedure TOleCtl.CreateEnumPropDescs;
 627
 628   function FindMember(DispId: Integer): Boolean;
 629   begin
 630     Result := GetEnumPropDesc(DispId) <> nil;
 631   end;
 632   {var
 633     I: Integer;
 634   begin
 635     for I := 0 to FControlData^.EnumPropDescs.Count - 1 do
 636       if TEnumPropDesc(FControlData^.EnumPropDescs).FDispID = DispID then
 637       begin
 638         Result := True;
 639         Exit;
 640       end;
 641     Result := False;
 642   end;}
 643
 644   procedure CreateEnum(TypeDesc: TTypeDesc; const TypeInfo: ITypeInfo;
 645     DispId: Integer);
 646   var
 647     RefInfo: ITypeInfo;
 648     RefAttr: PTypeAttr;
 649     epd: PEnumPropDesc;
 650   begin
 651     if TypeDesc.vt <> VT_USERDEFINED then Exit;
 652     OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo));
 653     OleCheck(RefInfo.GetTypeAttr(RefAttr));
 654     try
 655       if RefAttr^.typekind = TKIND_ENUM then
 656       begin
 657         new( epd, Create(Dispid, RefAttr^.cVars, RefInfo) );
 658         FControlData^.EnumPropDescs.Add( epd );
 659       end;
 660     finally
 661       RefInfo.ReleaseTypeAttr(RefAttr);
 662     end;
 663   end;
 664
 665   procedure ProcessTypeInfo(const TypeInfo: ITypeInfo);
 666   var
 667     I: Integer;
 668     RefInfo: ITypeInfo;
 669     TypeAttr: PTypeAttr;
 670     VarDesc: PVarDesc;
 671     FuncDesc: PFuncDesc;
 672     RefType: HRefType;
 673   begin
 674     OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
 675     try
 676       if IsEqualGUID(TypeAttr^.guid, IDispatch) then Exit;
 677       if ((TypeAttr.typekind = TKIND_INTERFACE) or
 678         (TypeAttr.wTypeFlags and TYPEFLAG_FDUAL <> 0)) and
 679         (TypeAttr.wTypeFlags and TYPEFLAG_FNONEXTENSIBLE <> 0) then
 680       begin
 681         OleCheck(TypeInfo.GetRefTypeOfImplType(0, RefType));
 682         OleCheck(TypeInfo.GetRefTypeInfo(RefType, RefInfo));
 683         ProcessTypeInfo(RefInfo);
 684       end;
 685       for I := 0 to TypeAttr^.cVars - 1 do
 686       begin
 687         OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
 688         try
 689           CreateEnum(VarDesc^.elemdescVar.tdesc, TypeInfo, VarDesc^.memid);
 690         finally
 691           TypeInfo.ReleaseVarDesc(VarDesc);
 692         end;
 693       end;
 694       for I := 0 to TypeAttr^.cFuncs - 1 do
 695       begin
 696         OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
 697         try
 698           if not FindMember(FuncDesc^.memid) then
 699             case FuncDesc^.invkind of
 700               INVOKE_PROPERTYGET:
 701                 CreateEnum(FuncDesc^.elemdescFunc.tdesc, TypeInfo, FuncDesc^.memid);
 702               INVOKE_PROPERTYPUT:
 703                 CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc,
 704                   TypeInfo, FuncDesc^.memid);
 705               INVOKE_PROPERTYPUTREF:
 706                 if FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.vt = VT_PTR then
 707                   CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.ptdesc^,
 708                     TypeInfo, FuncDesc^.memid);
 709             end;
 710         finally
 711           TypeInfo.ReleaseFuncDesc(FuncDesc);
 712         end;
 713       end;
 714     finally
 715       TypeInfo.ReleaseTypeAttr(TypeAttr);
 716     end;
 717   end;
 718
 719 var
 720   TypeInfo: ITypeInfo;
 721 begin
 722   CreateControl;
 723   FControlData^.EnumPropDescs := NewList;
 724   try
 725     OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo));
 726     ProcessTypeInfo(TypeInfo);
 727   except
 728     DestroyEnumPropDescs;
 729     raise;
 730   end;
 731 end;
 732
 733 procedure TOleCtl.CreateInstance;
 734 var
 735   ClassFactory2: IClassFactory2;
 736   LicKeyStr: WideString;
 737
 738   procedure LicenseCheck(Status: HResult; const Ident: string);
 739   begin
 740     if Status = CLASS_E_NOTLICENSED then
 741       raise EOleError.CreateFmt(e_Ole, Ident, [SubClassName]);
 742     OleCheck(Status);
 743   end;
 744
 745 begin
 746   if (FControlData^.LicenseKey <> nil) then
 747   begin
 748     OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or
 749       CLSCTX_LOCAL_SERVER, nil, IClassFactory2, ClassFactory2));
 750     LicKeyStr := PWideChar(FControlData^.LicenseKey);
 751     LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IOleObject,
 752       LicKeyStr, FOleObject), SInvalidLicense);
 753   end else
 754     LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil,
 755       CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject,
 756       FOleObject), SNotLicensed);
 757 end;
 758
 759 procedure CallEventMethod(const EventInfo: TEventInfo);
 760 asm
 761         PUSH    EBX
 762         PUSH    ESI
 763         PUSH    EBP
 764         MOV     EBP,ESP
 765         MOV     EBX,EAX
 766         MOV     EDX,[EBX].TEventInfo.ArgCount
 767         TEST    EDX,EDX
 768         JE      @@5
 769         XOR     EAX,EAX
 770         LEA     ESI,[EBX].TEventInfo.Args
 771 @@1:    MOV     AL,[ESI].TEventArg.Kind
 772         CMP     AL,1
 773         JA      @@2
 774         JE      @@3
 775         TEST    AH,AH
 776         JNE     @@3
 777         MOV     ECX,[ESI].Integer[4]
 778         MOV     AH,1
 779         JMP     @@4
 780 @@2:    PUSH    [ESI].Integer[8]
 781 @@3:    PUSH    [ESI].Integer[4]
 782 @@4:    ADD     ESI,12
 783         DEC     EDX
 784         JNE     @@1
 785 @@5:    MOV     EDX,[EBX].TEventInfo.Sender
 786         MOV     EAX,[EBX].TEventInfo.Method.Data
 787         CALL    [EBX].TEventInfo.Method.Code
 788         MOV     ESP,EBP
 789         POP     EBP
 790         POP     ESI
 791         POP     EBX
 792 end;
 793
 794 type
 795   PVarArg = ^TVarArg;
 796   TVarArg = array[0..3] of DWORD;
 797
 798 function TOleCtl.CreateWindow: Boolean;
 799 begin
 800   Result := FALSE;
 801   if fHandle <> 0 then
 802   begin
 803     Result := TRUE;
 804     Exit;
 805   end;
 806   if fCreatingWnd then
 807     Exit;
 808   fCreatingWnd := TRUE;
 809   try
 810     CreateControl;
 811     if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
 812     begin
 813       FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, fOleCtlIntf, 0,
 814         ParentWindow, BoundsRect);
 815       if FOleInPlaceObject = nil then
 816         raise EOleError.CreateResFmt(e_Ole, Integer( @SCannotActivate ), [nil]);
 817       HookControlWndProc;
 818       if not fVisible and IsWindowVisible(fHandle) then
 819         ShowWindow(fHandle, SW_HIDE);
 820       Result := TRUE;
 821     end
 822       else
 823       Result := inherited CreateWindow;
 824   finally
 825     fCreatingWnd := FALSE;
 826   end;
 827 end;
 828
 829 procedure TOleCtl.D2InvokeEvent(DispID: TDispID; var Params: TDispParams);
 830 type
 831   TStringDesc = record
 832     PStr: Pointer;
 833     BStr: PBStr;
 834   end;
 835 var
 836   I, J, K, ArgType, ArgCount, StrCount: Integer;
 837   ArgPtr: PEventArg;
 838   ParamPtr: PVarArg;
 839   Strings: array[0..MaxDispArgs - 1] of TStringDesc;
 840   EventInfo: TEventInfo;
 841 begin
 842   fOleCtlIntf.GetEventMethod(DispID, EventInfo.Method);
 843   if Integer(EventInfo.Method.Code) >= $10000 then
 844   begin
 845     StrCount := 0;
 846     try
 847       ArgCount := Params.cArgs;
 848       EventInfo.Sender := fOleCtlIntf;
 849       EventInfo.ArgCount := ArgCount;
 850       if ArgCount <> 0 then
 851       begin
 852         ParamPtr := @Params.rgvarg^[EventInfo.ArgCount];
 853         ArgPtr := @EventInfo.Args;
 854         I := 0;
 855         repeat
 856           Dec(Integer(ParamPtr), SizeOf(TVarArg));
 857           ArgType := ParamPtr^[0] and $0000FFFF;
 858           if ArgType and varTypeMask = varOleStr then
 859           begin
 860             ArgPtr^.Kind := akDWord;
 861             with Strings[StrCount] do
 862             begin
 863               PStr := nil;
 864               if ArgType and varByRef <> 0 then
 865               begin
 866                 OleStrToStrVar(PBStr(ParamPtr^[2])^, string(PStr));
 867                 BStr := PBStr(ParamPtr^[2]);
 868                 ArgPtr^.Data[0] := Integer(@PStr);
 869               end else
 870               begin
 871                 OleStrToStrVar(TBStr(ParamPtr^[2]), string(PStr));
 872                 BStr := nil;
 873                 ArgPtr^.Data[0] := Integer(PStr);
 874               end;
 875             end;
 876             Inc(StrCount);
 877           end else
 878           begin
 879             case ArgType of
 880               varSingle:
 881                 begin
 882                   ArgPtr^.Kind := akSingle;
 883                   ArgPtr^.Data[0] := ParamPtr^[2];
 884                 end;
 885               varDouble..varDate:
 886                 begin
 887                   ArgPtr^.Kind := akDouble;
 888                   ArgPtr^.Data[0] := ParamPtr^[2];
 889                   ArgPtr^.Data[1] := ParamPtr^[3];
 890                 end;
 891               varDispatch:
 892                 begin
 893                   ArgPtr^.Kind := akDWord;
 894                   ArgPtr^.Data[0] := Integer(ParamPtr)
 895                 end;
 896             else
 897               ArgPtr^.Kind := akDWord;
 898               if (ArgType and varArray) <> 0 then
 899                 ArgPtr^.Data[0] := Integer(ParamPtr)
 900               else
 901                 ArgPtr^.Data[0] := ParamPtr^[2];
 902             end;
 903           end;
 904           Inc(Integer(ArgPtr), SizeOf(TEventArg));
 905           Inc(I);
 906         until I = EventInfo.ArgCount;
 907       end;
 908       CallEventMethod(EventInfo);
 909       J := StrCount;
 910       while J <> 0 do
 911       begin
 912         Dec(J);
 913         with Strings[J] do
 914           if BStr <> nil then BStr^ := StringToOleStr(string(PStr));
 915       end;
 916     except
 917       DoHandleException;
 918     end;
 919     K := StrCount;
 920     while K <> 0 do
 921     begin
 922       Dec(K);
 923       string(Strings[K].PStr) := '';
 924     end;
 925   end;
 926 end;
 927
 928 procedure TOleCtl.DblClk;
 929 var MouseData: TMouseEventData;
 930     P: TPoint;
 931 begin
 932   if Assigned(OnMouseDblClk) then
 933   begin
 934     MouseData.Button := mbLeft;
 935     MouseData.Shift := 0;
 936     GetCursorPos( P );
 937     P := Screen2Client( P );
 938     MouseData.X := P.x;
 939     MouseData.Y := P.y;
 940     OnMouseDblClk(@Self, MouseData);
 941   end;
 942 end;
 943
 944 destructor TOleCtl.Destroy;
 945
 946   procedure FreeList(var L: PList);
 947   begin
 948     if L = nil then Exit;
 949     L.Release;
 950     L := nil;
 951   end;
 952
 953 begin
 954   SetUIActive(False);
 955   if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
 956   DestroyControl;
 957   DestroyStorage;
 958   FPersistStream := nil;
 959   if FOleObject <> nil then FOleObject.SetClientSite(nil);
 960   FOleObject := nil;
 961   FEventDispatch.Free;
 962   FreeList(FFonts);
 963   FreeList(FPictures);
 964   Dec(FControlData^.InstanceCount);
 965   if FControlData^.InstanceCount = 0 then
 966     DestroyEnumPropDescs;
 967   fOleCtlIntf.Free;
 968   inherited Destroy;
 969 end;
 970
 971 procedure TOleCtl.DestroyControl;
 972 begin
 973   InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection);
 974   InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection);
 975   FPropBrowsing := nil;
 976   FControlDispatch := nil;
 977   FOleControl := nil;
 978 end;
 979
 980 procedure TOleCtl.DestroyEnumPropDescs;
 981 var
 982   I: Integer;
 983 begin
 984   with FControlData^ do
 985     if EnumPropDescs <> nil then
 986     begin
 987       for I := 0 to EnumPropDescs.Count - 1 do
 988         PEnumPropDesc(EnumPropDescs.Items[I]).Free;
 989       EnumPropDescs.Free;
 990       EnumPropDescs := nil;
 991     end;
 992 end;
 993
 994 procedure TOleCtl.DestroyStorage;
 995 begin
 996   if FObjectData <> 0 then
 997   begin
 998     GlobalFree(FObjectData);
 999     FObjectData := 0;
1000   end;
1001 end;
1002
1003 procedure TOleCtl.DoHandleException;
1004 begin
1005   //Application.HandleException(Self);
1006   //TODO: replace Application.HandleException with something
1007 end;
1008
1009 function TOleCtl.GetByteProp(Index: Integer): Byte;
1010 begin
1011   Result := GetIntegerProp(Index);
1012 end;
1013
1014 function TOleCtl.GetColorProp(Index: Integer): TColor;
1015 begin
1016   Result := GetIntegerProp(Index);
1017 end;
1018
1019 function TOleCtl.GetCompProp(Index: Integer): Comp;
1020 begin
1021   Result := GetDoubleProp(Index);
1022 end;
1023
1024 function TOleCtl.GetCurrencyProp(Index: Integer): Currency;
1025 var
1026   Temp: TVarData;
1027 begin
1028   GetProperty(Index, Temp);
1029   Result := Temp.VCurrency;
1030 end;
1031
1032 function TOleCtl.GetDoubleProp(Index: Integer): Double;
1033 var
1034   Temp: TVarData;
1035 begin
1036   GetProperty(Index, Temp);
1037   Result := Temp.VDouble;
1038 end;
1039
1040 procedure TOleCtlIntf.GetEventMethod(DispID: TDispID; var Method: TMethod);
1041 {begin // test for D4 - it works...
1042   Method.Code := nil;
1043   Method.Data := nil;
1044 end;}
1045 const
1046   szOleCtl = sizeof( TOleCtl );
1047 asm
1048         PUSH    EBX
1049         PUSH    ESI
1050         PUSH    EDI
1051         PUSH    ECX
1052         MOV     EBX,EAX
1053         MOV     ECX,[EBX].fOleCtl
1054         ///////////////////////// fix of events handling
1055         MOV     EBX, ECX       // by Alexey Izyumov
1056         ///////////////////////// Octouber, 2001
1057         MOV     ECX,[ECX].TOleCtl.FControlData
1058         MOV     EDI,[ECX].TControlData.EventCount
1059         MOV     ESI,[ECX].TControlData.EventDispIDs
1060         XOR     EAX,EAX
1061         JMP     @@1
1062 @@0:    CMP     EDX,[ESI].Integer[EAX*4]
1063         JE      @@2
1064         INC     EAX
1065 @@1:    CMP     EAX,EDI
1066         JNE     @@0
1067         XOR     EAX,EAX
1068         XOR     EDX,EDX
1069         JMP     @@3
1070 @@2:    PUSH    EAX
1071         CMP     [ECX].TControlData.Version, 401
1072         JB      @@2a
1073         MOV     EAX, [ECX].TControlData2.FirstEventOfs
1074         TEST    EAX, EAX
1075         JNE     @@2b
1076 @@2a:   {MOV     EAX, [EBX]
1077         CALL    TObject.ClassParent
1078         CALL    TObject.InstanceSize}
1079         MOV     EAX, szOleCtl
1080         ADD     EAX, 7
1081         AND     EAX, not 7  // 8 byte alignment
1082 @@2b:   ADD     EBX, EAX
1083         POP     EAX
1084         MOV     EDX,[EBX][EAX*8].TMethod.Data
1085         MOV     EAX,[EBX][EAX*8].TMethod.Code
1086 @@3:    POP     ECX
1087         MOV     [ECX].TMethod.Code,EAX
1088         MOV     [ECX].TMethod.Data,EDX
1089         POP     EDI
1090         POP     ESI
1091         POP     EBX
1092 end;
1093
1094 function TOleCtl.GetEnumPropDesc(DispID: Integer): PEnumPropDesc;
1095 var
1096   I: Integer;
1097 begin
1098   with FControlData^ do
1099   begin
1100     if EnumPropDescs = nil then CreateEnumPropDescs;
1101     for I := 0 to EnumPropDescs.Count - 1 do
1102     begin
1103       Result := EnumPropDescs.Items[I];
1104       if Result.FDispID = DispID then Exit;
1105     end;
1106     Result := nil;
1107   end;
1108 end;
1109
1110 function TOleCtl.GetIDispatchProp(Index: Integer): IDispatch;
1111 var
1112   Temp: TVarData;
1113 begin
1114   GetProperty(Index, Temp);
1115   Result := IDispatch(Temp.VDispatch);
1116 end;
1117
1118 function TOleCtl.GetIntegerProp(Index: Integer): Integer;
1119 var
1120   Temp: TVarData;
1121 begin
1122   GetProperty(Index, Temp);
1123   Result := Temp.VInteger;
1124 end;
1125
1126 function TOleCtl.GetIUnknownProp(Index: Integer): IUnknown;
1127 var
1128   Temp: TVarData;
1129 begin
1130   GetProperty(Index, Temp);
1131   Result := IUnknown(Temp.VUnknown);
1132 end;
1133
1134 function TOleCtl.GetMainMenu: HMenu;
1135 var
1136   Form: PControl;
1137 begin
1138   Result := 0;
1139   Form := ParentForm;
1140   if Form <> nil then
1141     //if Form.FormStyle <> fsMDIChild then
1142       Result := Form.Menu
1143     {else
1144       if Application.MainForm <> nil then
1145         Result := Application.MainForm.Menu};
1146 end;
1147
1148 function TOleCtl.GetOleBoolProp(Index: Integer): TOleBool;
1149 var
1150   Temp: TVarData;
1151 begin
1152   GetProperty(Index, Temp);
1153   Result := Temp.VBoolean;
1154 end;
1155
1156 function TOleCtl.GetOleDateProp(Index: Integer): TOleDate;
1157 var
1158   Temp: TVarData;
1159 begin
1160   GetProperty(Index, Temp);
1161   Result := Temp.VDate;
1162 end;
1163
1164 function TOleCtl.GetOleEnumProp(Index: Integer): TOleEnum;
1165 begin
1166   Result := GetIntegerProp(Index);
1167 end;
1168
1169 function TOleCtl.GetOleObject: Variant;
1170 begin
1171   CreateControl;
1172   Result := Variant(FOleObject as IDispatch);
1173 end;
1174
1175 function TOleCtl.GetOleVariantProp(Index: Integer): OleVariant;
1176 begin
1177   VarClear(Result);
1178   GetProperty(Index, TVarData(Result));
1179 end;
1180
1181 function TOleCtl.GetOnLeave: TOnEvent;
1182 begin
1183   Result := OnExit;
1184 end;
1185
1186 var  // init to zero, never written to
1187   DispParams: TDispParams = ();
1188
1189 procedure TOleCtl.GetProperty(Index: Integer; var Value: TVarData);
1190 var
1191   Status: HResult;
1192   ExcepInfo: TExcepInfo;
1193 begin
1194   CreateControl;
1195   Value.VType := varEmpty;
1196   Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
1197     DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil);
1198   if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
1199 end;
1200
1201 function TOleCtl.GetShortIntProp(Index: Integer): ShortInt;
1202 begin
1203   Result := GetIntegerProp(Index);
1204 end;
1205
1206 function TOleCtl.GetSingleProp(Index: Integer): Single;
1207 var
1208   Temp: TVarData;
1209 begin
1210   GetProperty(Index, Temp);
1211   Result := Temp.VSingle;
1212 end;
1213
1214 function TOleCtl.GetSmallintProp(Index: Integer): Smallint;
1215 var
1216   Temp: TVarData;
1217 begin
1218   GetProperty(Index, Temp);
1219   Result := Temp.VSmallint;
1220 end;
1221
1222 function TOleCtl.GetStringProp(Index: Integer): string;
1223 begin
1224   Result := GetVariantProp(Index);
1225 end;
1226
1227 function TOleCtl.GetTColorProp(Index: Integer): TColor;
1228 begin
1229   Result := GetIntegerProp(Index);
1230 end;
1231
1232 function TOleCtl.GetTDateTimeProp(Index: Integer): TDateTime;
1233 var
1234   Temp: TVarData;
1235 begin
1236   GetProperty(Index, Temp);
1237   Result := Temp.VDate;
1238 end;
1239
1240 function TOleCtl.GetTFontProp(Index: Integer): PGraphicTool;
1241 {var
1242   I: Integer;}
1243 begin
1244   Result := nil;
1245   {for I := 0 to FFonts.Count-1 do
1246     if FControlData^.FontIDs^[I] = Index then
1247     begin
1248       Result := TFont(FFonts[I]);
1249       if Result.FontAdapter = nil then
1250         SetOleFont(Result, GetIDispatchProp(Index) as IFontDisp);
1251     end;}
1252   //TODO: implement TFont later
1253 end;
1254
1255 function TOleCtl.GetTOleEnumProp(Index: Integer): TOleEnum;
1256 begin
1257   Result := GetIntegerProp(Index);
1258 end;
1259
1260 function TOleCtl.GetVariantProp(Index: Integer): Variant;
1261 begin
1262   Result := GetOleVariantProp(Index);
1263 end;
1264
1265 function TOleCtl.GetWideStringProp(Index: Integer): WideString;
1266 var
1267   Temp: TVarData;
1268 begin
1269   Result := '';
1270   GetProperty(Index, Temp);
1271   Pointer(Result) := Temp.VOleStr;
1272 end;
1273
1274 function TOleCtl.GetWordBoolProp(Index: Integer): WordBool;
1275 var
1276   Temp: TVarData;
1277 begin
1278   GetProperty(Index, Temp);
1279   Result := Temp.VBoolean;
1280 end;
1281
1282 function TOleCtl.GetWordProp(Index: Integer): Word;
1283 begin
1284   Result := GetIntegerProp(Index);
1285 end;
1286
1287 procedure TOleCtl.HookControlWndProc;
1288 var
1289   WndHandle: HWnd;
1290 begin
1291   if (FOleInPlaceObject <> nil) and (fHandle = 0) then
1292   begin
1293     WndHandle := 0;
1294     FOleInPlaceObject.GetWindow(WndHandle);
1295     if WndHandle = 0 then
1296       raise EOleError.CreateResFmt(e_Ole, Integer(@SNoWindowHandle), [nil]);
1297     fHandle := WndHandle;
1298     fDefWndProc := Pointer(GetWindowLong(fHandle, GWL_WNDPROC));
1299     CreatingWindow := @Self;
1300     SetWindowLong(fHandle, GWL_WNDPROC, Longint(@WndFunc));
1301     SendMessage(fHandle, WM_NULL, 0, 0);
1302   end;
1303 end;
1304
1305 procedure TOleCtl.Init;
1306 var I: Integer;
1307 begin
1308   OleInit;
1309   inherited;
1310   // overriding this method, we allow for constructor to initialize
1311   // the object.
1312   fControlClassName := 'OleCtl'; // ClassName
1313   fIsControl := TRUE;
1314   fStyle := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
1315             WS_CHILD; // or WS_BORDER or WS_THICKFRAME;
1316
1317   //AttachProc( WndProcCtrl ); for test only
1318
1319   // The rest of initialization -- moved from OleCtrls
1320   InitControlData;
1321   Inc(FControlData^.InstanceCount);
1322   if FControlData^.FontCount > 0 then
1323   begin
1324     FFonts := NewList;
1325     //FFonts.Count := FControlData^.FontCount;
1326     for I := 0 to FControlData^.FontCount-1 do
1327       FFonts.Add( NewFont );
1328   end;
1329   {if FControlData^.PictureCount > 0 then
1330   begin
1331     FPictures := NewList;
1332     //FPictures.Count := FControlData^.PictureCount;
1333     for I := 0 to FControlData^.PictureCount-1 do
1334     begin
1335       FPictures.Add( NewPicture );
1336       TPicture(FPictures[I]).OnChange := PictureChanged;
1337     end;
1338   end;}
1339   FEventDispatch := TEventDispatch.Create(@Self);
1340   CreateInstance;
1341   InitControlInterface(FOleObject);
1342   OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus));
1343
1344   fOleCtlIntf := TOleCtlIntf.Create;
1345   fOleCtlIntf.fOleCtl := @Self;
1346
1347   if (FControlData^.Reserved and cdDeferSetClientSite) = 0 then
1348     if ((FMiscStatus and OLEMISC_SETCLIENTSITEFIRST) <> 0) or
1349       ((FControlData^.Reserved and cdForceSetClientSite) <> 0) then
1350       OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
1351   OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream));
1352   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
1353     fVisible := False;
1354   {if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
1355     ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else
1356     ControlStyle := [csDoubleClicks, csNoStdEvents];}
1357   if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then
1358     fExStyle := 0; // clear WS_EX_CONTROLPARENT
1359   TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or
1360     OLEMISC_NOUIACTIVATE) = 0;
1361   OleCheck(fOleCtlIntf.RequestNewObjectLayout);
1362 end;
1363
1364 procedure TOleCtl.InitControlData;
1365 begin
1366   // nothing here. Originally, this method was abstract.
1367   // Since TOleControl class became TOleCtl object, abstract methods
1368   // are not available. So, make this method empty to override it
1369   // in descendant objects, which represent Active-X controls.
1370 end;
1371
1372 procedure TOleCtl.InitControlInterface(const Obj: IUnknown);
1373 begin
1374   // This method is to override it in derived Active-X control holder.
1375 end;
1376
1377 procedure TOleCtl.InvokeEvent(DispID: TDispID; var Params: TDispParams);
1378 var
1379   EventMethod: TMethod;
1380 begin
1381   if ControlData.Version < 300 then
1382     D2InvokeEvent(DispID, Params)
1383   else
1384   begin
1385     fOleCtlIntf.GetEventMethod(DispID, EventMethod);
1386     if Integer(EventMethod.Code) < $10000 then Exit;
1387
1388     try
1389       asm
1390                 PUSH    EBX
1391                 PUSH    ESI
1392                 MOV     ESI, Params
1393                 MOV     EBX, [ESI].TDispParams.cArgs
1394                 TEST    EBX, EBX
1395                 JZ      @@7
1396                 MOV     ESI, [ESI].TDispParams.rgvarg
1397                 MOV     EAX, EBX
1398                 SHL     EAX, 4     // count * sizeof(TVarArg)
1399                 XOR     EDX, EDX
1400                 ADD     ESI, EAX   // EDI = Params.rgvarg^[ArgCount]
1401         @@1:    SUB     ESI, 16    // Sizeof(TVarArg)
1402                 MOV     EAX, dword ptr [ESI]
1403                 CMP     AX, varSingle
1404                 JA      @@3
1405                 JE      @@4
1406         @@2:    TEST    DL,DL
1407                 JNE     @@2a
1408                 MOV     ECX, ESI
1409                 INC     DL
1410                 TEST    EAX, varArray
1411                 JNZ     @@6
1412                 MOV     ECX, dword ptr [ESI+8]
1413                 JMP     @@6
1414         @@2a:   TEST    EAX, varArray
1415                 JZ      @@5
1416                 PUSH    ESI
1417                 JMP     @@6
1418         @@3:    CMP     AX, varDate
1419                 JA      @@2
1420         @@4:    PUSH    dword ptr [ESI+12]
1421         @@5:    PUSH    dword ptr [ESI+8]
1422         @@6:    DEC     EBX
1423                 JNE     @@1
1424         @@7:    MOV     EDX, Self
1425                 MOV     EAX, EventMethod.Data
1426                 CALL    EventMethod.Code
1427                 POP     ESI
1428                 POP     EBX
1429       end;
1430     except
1431       DoHandleException;
1432     end;
1433   end;
1434 end;
1435
1436 procedure TOleCtl.KeyDown(var Key: Longint; AShift: DWORD);
1437 begin
1438   if Assigned(FOnKeyDown) then FOnKeyDown(@Self, Key, AShift);
1439 end;
1440
1441 procedure TOleCtl.KeyPress(var Key: Char);
1442 begin
1443   if Assigned(FOnChar) then FOnChar(@Self, Key, 0);
1444 end;
1445
1446 procedure TOleCtl.KeyUp(var Key: Longint; AShift: DWORD);
1447 begin
1448   if Assigned(FOnKeyUp) then FOnKeyUp(@Self, Key, AShift);
1449 end;
1450
1451 procedure TOleCtl.MouseDown(Button: TMouseButton; AShift: DWORD; X,
1452   Y: Integer);
1453 begin
1454   //TODO: mouse
1455 end;
1456
1457 procedure TOleCtl.MouseMove(AShift: DWORD; X, Y: Integer);
1458 begin
1459   //TODO: mouse
1460 end;
1461
1462 procedure TOleCtl.MouseUp(Button: TMouseButton; AShift: DWORD; X,
1463   Y: Integer);
1464 begin
1465   //TODO: mouse
1466 end;
1467
1468 procedure TOleCtl.SetByteProp(Index: Integer; Value: Byte);
1469 begin
1470   SetIntegerProp(Index, Value);
1471 end;
1472
1473 procedure TOleCtl.SetColorProp(Index: Integer; Value: TColor);
1474 begin
1475   SetIntegerProp(Index, Value);
1476 end;
1477
1478 procedure TOleCtl.SetCompProp(Index: Integer; const Value: Comp);
1479 var
1480   Temp: TVarData;
1481 begin
1482   Temp.VType := VT_I8;
1483   Temp.VDouble := Value;
1484   SetProperty(Index, Temp);
1485 end;
1486
1487 procedure TOleCtl.SetCurrencyProp(Index: Integer; const Value: Currency);
1488 var
1489   Temp: TVarData;
1490 begin
1491   Temp.VType := varCurrency;
1492   Temp.VCurrency := Value;
1493   SetProperty(Index, Temp);
1494 end;
1495
1496 procedure TOleCtl.SetDoubleProp(Index: Integer; const Value: Double);
1497 var
1498   Temp: TVarData;
1499 begin
1500   Temp.VType := varDouble;
1501   Temp.VDouble := Value;
1502   SetProperty(Index, Temp);
1503 end;
1504
1505 procedure TOleCtl.SetIDispatchProp(Index: Integer; const Value: IDispatch);
1506 var
1507   Temp: TVarData;
1508 begin
1509   Temp.VType := varDispatch;
1510   Temp.VDispatch := Pointer(Value);
1511   SetProperty(Index, Temp);
1512 end;
1513
1514 procedure TOleCtl.SetIntegerProp(Index, Value: Integer);
1515 var
1516   Temp: TVarData;
1517 begin
1518   Temp.VType := varInteger;
1519   Temp.VInteger := Value;
1520   SetProperty(Index, Temp);
1521 end;
1522
1523 procedure TOleCtl.SetIUnknownProp(Index: Integer; const Value: IUnknown);
1524 var
1525   Temp: TVarData;
1526 begin
1527   Temp.VType := VT_UNKNOWN;
1528   Temp.VUnknown := Pointer(Value);
1529   SetProperty(Index, Temp);
1530 end;
1531
1532 procedure TOleCtl.SetMouseDblClk(const Value: TOnMouse);
1533 begin
1534   fOnMouseDblClk := Value;
1535 end;
1536
1537 procedure TOleCtl.SetName(const Value: String);
1538 var
1539   OldName: string;
1540   DispID: Integer;
1541 begin
1542   OldName := Name;
1543   Name := Value; //inherited SetName(Value);
1544   if FOleControl <> nil then
1545   begin
1546     FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME);
1547     if FControlData^.Flags and (cfCaption or cfText) <> 0 then
1548     begin
1549       if FControlData^.Flags and cfCaption <> 0 then
1550         DispID := DISPID_CAPTION else
1551         DispID := DISPID_TEXT;
1552       if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value);
1553     end;
1554   end;
1555 end;
1556
1557 procedure TOleCtl.SetOleBoolProp(Index: Integer; Value: TOleBool);
1558 var
1559   Temp: TVarData;
1560 begin
1561   Temp.VType := varBoolean;
1562   if Value then
1563     Temp.VBoolean := WordBool(-1) else
1564     Temp.VBoolean := WordBool(0);
1565   SetProperty(Index, Temp);
1566 end;
1567
1568 procedure TOleCtl.SetOleDateProp(Index: Integer; const Value: TOleDate);
1569 var
1570   Temp: TVarData;
1571 begin
1572   Temp.VType := varDate;
1573   Temp.VDate := Value;
1574   SetProperty(Index, Temp);
1575 end;
1576
1577 procedure TOleCtl.SetOleEnumProp(Index: Integer; Value: TOleEnum);
1578 begin
1579   SetIntegerProp(Index, Value);
1580 end;
1581
1582 procedure TOleCtl.SetOleVariantProp(Index: Integer;
1583   const Value: OleVariant);
1584 begin
1585   SetProperty(Index, TVarData(Value));
1586 end;
1587
1588 procedure TOleCtl.SetOnChar(const Value: TOnChar);
1589 begin
1590   fOnChar := Value;
1591 end;
1592
1593 procedure TOleCtl.SetOnLeave(const Value: TOnEvent);
1594 begin
1595   OnExit := Value;
1596 end;
1597
1598 procedure TOleCtl.SetParent(AParent: PControl);
1599 var
1600   CS: IOleClientSite;
1601   X: Integer;
1602 begin
1603   inherited Parent := AParent;
1604   if (AParent <> nil) then
1605   begin
1606     try  // work around ATL bug
1607       X := FOleObject.GetClientSite(CS);
1608     except
1609       X := -1;
1610     end;
1611     if (X <> 0) or (CS = nil) then
1612       OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
1613     if FOleControl <> nil then
1614       FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN);
1615   end;
1616 end;
1617
1618 procedure TOleCtl.SetProperty(Index: Integer; const Value: TVarData);
1619 const
1620   DispIDArgs: Longint = DISPID_PROPERTYPUT;
1621 var
1622   Status, InvKind: Integer;
1623   DispParams: TDispParams;
1624   ExcepInfo: TExcepInfo;
1625 begin
1626   CreateControl;
1627   DispParams.rgvarg := @Value;
1628   DispParams.rgdispidNamedArgs := @DispIDArgs;
1629   DispParams.cArgs := 1;
1630   DispParams.cNamedArgs := 1;
1631   if Value.VType <> varDispatch then
1632     InvKind := DISPATCH_PROPERTYPUT else
1633     InvKind := DISPATCH_PROPERTYPUTREF;
1634   Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
1635     InvKind, DispParams, nil, @ExcepInfo, nil);
1636   if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
1637 end;
1638
1639 procedure TOleCtl.SetShortIntProp(Index: Integer; Value: Shortint);
1640 begin
1641   SetIntegerProp(Index, Value);
1642 end;
1643
1644 procedure TOleCtl.SetSingleProp(Index: Integer; const Value: Single);
1645 var
1646   Temp: TVarData;
1647 begin
1648   Temp.VType := varSingle;
1649   Temp.VSingle := Value;
1650   SetProperty(Index, Temp);
1651 end;
1652
1653 procedure TOleCtl.SetSmallintProp(Index: Integer; Value: Smallint);
1654 var
1655   Temp: TVarData;
1656 begin
1657   Temp.VType := varSmallint;
1658   Temp.VSmallint := Value;
1659   SetProperty(Index, Temp);
1660 end;
1661
1662 procedure TOleCtl.SetStringProp(Index: Integer; const Value: string);
1663 var
1664   Temp: TVarData;
1665 begin
1666   Temp.VType := varOleStr;
1667   Temp.VOleStr := StringToOleStr(Value);
1668   try
1669     SetProperty(Index, Temp);
1670   finally
1671     SysFreeString(Temp.VOleStr);
1672   end;
1673 end;
1674
1675 procedure TOleCtl.SetTColorProp(Index: Integer; Value: TColor);
1676 begin
1677   SetIntegerProp(Index, Value);
1678 end;
1679
1680 procedure TOleCtl.SetTDateTimeProp(Index: Integer; const Value: TDateTime);
1681 var
1682   Temp: TVarData;
1683 begin
1684   Temp.VType := varDate;
1685   Temp.VDate := Value;
1686   SetProperty(Index, Temp);
1687 end;
1688
1689 procedure TOleCtl.SetTFontProp(Index: Integer; Value: PGraphicTool);
1690 {var
1691   I: Integer;
1692   F: TFont;
1693   Temp: IFontDisp;}
1694 begin
1695   {for I := 0 to FFonts.Count-1 do
1696     if FControlData^.FontIDs^[I] = Index then
1697     begin
1698       F := TFont(FFonts[I]);
1699       F.Assign(Value);
1700       if F.FontAdapter = nil then
1701       begin
1702         GetOleFont(F, Temp);
1703         SetIDispatchProp(Index, Temp);
1704       end;
1705     end;}
1706   //TODO: implement TFont property later
1707 end;
1708
1709 procedure TOleCtl.SetTOleEnumProp(Index: Integer; Value: TOleEnum);
1710 begin
1711   SetIntegerProp(Index, Value);
1712 end;
1713
1714 procedure TOleCtl.SetUIActive(Active: Boolean);
1715 var
1716   Form: POleCtl; // declare it as POleCtl, though it is only PControl
1717                  // - to access its protected fields
1718 begin
1719   Form := POleCtl( ParentForm );
1720   if Form <> nil then
1721     if Active then
1722     begin
1723       {if (Form.ActiveOleControl <> nil) and
1724         (Form.ActiveOleControl <> Self) then
1725         Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
1726       Form.ActiveOleControl := Self;}
1727       if (Form.fCurrentControl <> nil) and
1728         (Form.fCurrentControl <> @Self) then
1729         Form.fCurrentControl.Perform(CM_UIDEACTIVATE, 0, 0);
1730       Form.fCurrentControl := @Self;
1731     end else
1732       if Form.fCurrentControl = @Self then
1733         Form.fCurrentControl := nil;
1734 end;
1735
1736 procedure TOleCtl.SetVariantProp(Index: Integer; const Value: Variant);
1737 begin
1738   SetOleVariantProp(Index, Value);
1739 end;
1740
1741 procedure TOleCtl.SetWideStringProp(Index: Integer;
1742   const Value: WideString);
1743 var
1744   Temp: TVarData;
1745 begin
1746   Temp.VType := varOleStr;
1747   if Value <> '' then
1748     Temp.VOleStr := PWideChar(Value)
1749   else
1750     Temp.VOleStr := nil;
1751   SetProperty(Index, Temp);
1752 end;
1753
1754 procedure TOleCtl.SetWordBoolProp(Index: Integer; Value: WordBool);
1755 var
1756   Temp: TVarData;
1757 begin
1758   Temp.VType := varBoolean;
1759   if Value then
1760     Temp.VBoolean := WordBool(-1) else
1761     Temp.VBoolean := WordBool(0);
1762   SetProperty(Index, Temp);
1763 end;
1764
1765 procedure TOleCtl.SetWordProp(Index: Integer; Value: Word);
1766 begin
1767   SetIntegerProp(Index, Value);
1768 end;
1769
1770 procedure TOleCtl.StandardEvent(DispID: TDispID; var Params: TDispParams);
1771 type
1772   PVarDataList = ^TVarDataList;
1773   TVarDataList = array[0..3] of TVarData;
1774 const
1775   {ShiftMap: array[0..7] of TShiftState = (
1776     [],
1777     [ssShift],
1778     [ssCtrl],
1779     [ssShift, ssCtrl],
1780     [ssAlt],
1781     [ssShift, ssAlt],
1782     [ssCtrl, ssAlt],
1783     [ssShift, ssCtrl, ssAlt]);
1784   MouseMap: array[0..7] of TShiftState = (
1785     [],
1786     [ssLeft],
1787     [ssRight],
1788     [ssLeft, ssRight],
1789     [ssMiddle],
1790     [ssLeft, ssMiddle],
1791     [ssRight, ssMiddle],
1792     [ssLeft, ssRight, ssMiddle]);}
1793   ShiftMap: array[0..7] of DWord = (
1794     0,
1795     MK_SHIFT,
1796     MK_CONTROL,
1797     MK_SHIFT or MK_CONTROL,
1798     MK_ALT,
1799     MK_SHIFT or MK_ALT,
1800     MK_CONTROL or MK_ALT,
1801     MK_SHIFT or MK_CONTROL or MK_ALT);
1802   MouseMap: array[0..7] of DWORD = (
1803     0,
1804     MK_LBUTTON,
1805     MK_RBUTTON,
1806     MK_LBUTTON or MK_RBUTTON,
1807     MK_MBUTTON,
1808     MK_LBUTTON or MK_MBUTTON,
1809     MK_RBUTTON or MK_MBUTTON,
1810     MK_LBUTTON or MK_RBUTTON or MK_MBUTTON);
1811   ButtonMap: array[0..7] of TMouseButton = (
1812     mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft);
1813 var
1814   Args: PVarDataList;
1815   AShift: DWORD;
1816   Button: TMouseButton;
1817   X, Y: Integer;
1818   Key: Longint;
1819   Ch: Char;
1820 begin
1821   Args := PVarDataList(Params.rgvarg);
1822   try
1823     case DispID of
1824       DISPID_CLICK:
1825         Click;
1826       DISPID_DBLCLICK:
1827         DblClk;
1828       DISPID_KEYDOWN, DISPID_KEYUP:
1829         if Params.cArgs >= 2 then
1830         begin
1831           Key := Variant(Args^[1]);
1832           X := Variant(Args^[0]);
1833           case DispID of
1834             DISPID_KEYDOWN: KeyDown(Key, X);
1835             DISPID_KEYUP:   KeyUp(Key, X);
1836           end;
1837           if ((Args^[1].vType and varByRef) <> 0) then
1838             Word(Args^[1].VPointer^) := Key;
1839         end;
1840       DISPID_KEYPRESS:
1841         if Params.cArgs > 0 then
1842         begin
1843           Ch := Char(Integer(Variant(Args^[0])));
1844           KeyPress(Ch);
1845           if ((Args^[0].vType and varByRef) <> 0) then
1846             Char(Args^[0].VPointer^) := Ch;
1847         end;
1848       DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP:
1849         if Params.cArgs >= 4 then
1850         begin
1851           X := Integer(Variant(Args^[3])) and 7;
1852           Y := Integer(Variant(Args^[2])) and 7;
1853           Button := ButtonMap[X];
1854           AShift := ShiftMap[Y] + MouseMap[X];
1855           X := Variant(Args^[1]);
1856           Y := Variant(Args^[0]);
1857           case DispID of
1858             DISPID_MOUSEDOWN:
1859               MouseDown(Button, AShift, X, Y);
1860             DISPID_MOUSEMOVE:
1861               MouseMove(AShift, X, Y);
1862             DISPID_MOUSEUP:
1863               MouseUp(Button, AShift, X, Y);
1864           end;
1865         end;
1866     end;
1867   except
1868     DoHandleException;
1869   end;
1870 end;
1871
1872 {$IFNDEF _D2orD3}
1873 { TServerEventDispatch }
1874 constructor TServerEventDispatch.Create(Server: TOleServer);
1875 begin
1876   FServer := Server;
1877   InternalRefCount := 1;
1878 end;
1879
1880 { TServerEventDispatch.IUnknown }
1881 function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
1882 begin
1883   if GetInterface(IID, Obj) then
1884   begin
1885     Result := S_OK;
1886     Exit;
1887   end;
1888   if IsEqualIID(IID, FServer.FServerData^.EventIID) then
1889   begin
1890     GetInterface(IDispatch, Obj);
1891     Result := S_OK;
1892     Exit;
1893   end;
1894   Result := E_NOINTERFACE;
1895 end;
1896
1897 function TServerEventDispatch._AddRef: Integer;
1898 begin
1899   if FServer <> nil then FServer._AddRef;
1900   InternalRefCount := InternalRefCount + 1;
1901   Result := InternalRefCount;
1902 end;
1903
1904 function TServerEventDispatch._Release: Integer;
1905 begin
1906   if FServer <> nil then FServer._Release;
1907   InternalRefCount := InternalRefCount -1;
1908   Result := InternalRefCount;
1909 end;
1910
1911 { TServerEventDispatch.IDispatch }
1912 function TServerEventDispatch.GetTypeInfoCount(out Count: Integer): HResult;
1913 begin
1914   Count := 0;
1915   Result:= S_OK;
1916 end;
1917
1918 function TServerEventDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
1919 begin
1920   Pointer(TypeInfo) := nil;
1921   Result := E_NOTIMPL;
1922 end;
1923
1924 function TServerEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
1925   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
1926 begin
1927   Result := E_NOTIMPL;
1928 end;
1929
1930 function TServerEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
1931   LocaleID: Integer; Flags: Word; var Params;
1932   VarResult, ExcepInfo, ArgErr: Pointer): HResult;
1933 var
1934   ParamCount, I: integer;
1935   VarArray : TVariantArray;
1936 begin
1937   // Get parameter count
1938   ParamCount := TDispParams(Params).cArgs;
1939   // Set our array to appropriate length
1940   SetLength(VarArray, ParamCount);
1941   // Copy over data
1942   for I := Low(VarArray) to High(VarArray) do
1943     VarArray[High(VarArray)-I] := OleVariant(TDispParams(Params).rgvarg^[I]);
1944   // Invoke Server proxy class
1945   if FServer <> nil then FServer.InvokeEvent(DispID, VarArray);
1946   // Clean array
1947   SetLength(VarArray, 0);
1948   // Pascal Events return 'void' - so assume success!
1949   Result := S_OK;
1950 end;
1951
1952 function TServerEventDispatch.ServerDisconnect : Boolean;
1953 begin
1954   FServer := nil;
1955   if FServer <> nil then
1956     Result := false
1957   else Result := true;
1958 end;
1959
1960 {TOleServer}
1961 constructor TOleServer.Create; //(AOwner: TComponent);
1962 begin
1963   inherited; // Create(AOwner);
1964   // Allow derived class to initialize ServerData structure pointer
1965   InitServerData;
1966   // Make sure derived class set ServerData pointer to some valid structure
1967   Assert(FServerData <> nil);
1968   // Increment instance count (not used currently)
1969   Inc(FServerData^.InstanceCount);
1970   // Create Event Dispatch Handler
1971   FEventDispatch := TServerEventDispatch.Create(Self);
1972 end;
1973
1974 destructor TOleServer.Destroy;
1975 begin
1976   // Disconnect from the Server (NOTE: Disconnect must handle case when we're no longer connected)
1977   Disconnect;
1978   // Free Events dispatcher
1979   FEventDispatch.ServerDisconnect;
1980   if (FEventDispatch._Release = 0) then FEventDispatch.Free;
1981   // Decrement refcount
1982   Dec(FServerData^.InstanceCount);
1983   inherited Destroy;
1984 end;
1985
1986 procedure TOleServer.Loaded;
1987 begin
1988   {inherited Loaded;}
1989
1990   // Load Server if user requested 'AutoConnect' and we're not in Design mode
1991   {if not (csDesigning in ComponentState) then}
1992     if AutoConnect then
1993         Connect;
1994 end;
1995
1996 procedure TOleServer.InvokeEvent(DispID: TDispID; var Params: TVariantArray);
1997 begin
1998   // To be overriden in derived classes to do dispatching
1999 end;
2000
2001 function TOleServer.GetServer: IUnknown;
2002 var
2003   HR: HResult;
2004   ErrorStr: string;
2005 begin
2006   case ConnectKind of
2007     ckNewInstance:
2008       Result := CreateComObject(FServerData^.ClassId);
2009
2010     ckRunningInstance:
2011     begin
2012       HR := GetActiveObject(FServerData^.ClassId, nil, Result);
2013       if not Succeeded(HR) then
2014       begin
2015         ErrorStr := Format(sNoRunningObject, [ClassIDToProgID(FServerData^.ClassId),
2016                                               GuidToString(FServerData^.ClassId)]);
2017         raise EOleSysError.Create( e_Ole, ErrorStr {, HR, 0} );
2018       end;
2019     end;
2020
2021     ckRunningOrNew:
2022       if not Succeeded(GetActiveObject(FServerData^.ClassId, nil, Result)) then
2023         Result := CreateComObject(FServerData^.ClassId);
2024
2025     ckRemote:
2026       {Highly inefficient: requires at least two round trips - GetClassObject + QI}
2027       Result := CreateRemoteComObject(RemoteMachineName, FServerData^.ClassID);
2028   end;
2029 end;
2030
2031 procedure TOleServer.ConnectEvents(const Obj: IUnknown);
2032 begin
2033   KOLComObj.InterfaceConnect(Obj, FServerData^.EventIID, FEventDispatch, FEventsConnection);
2034 end;
2035
2036 procedure TOleServer.DisconnectEvents(const Obj: Iunknown);
2037 begin
2038   KOLComObj.InterfaceDisconnect(Obj, FServerData^.EventIID, FEventsConnection);
2039 end;
2040
2041 function  TOleServer.GetConnectKind: TConnectKind;
2042 begin
2043   // Should the setting of a RemoteMachine name override the Connection Kind ??
2044   if RemoteMachineName <> '' then
2045     Result := ckRemote
2046   else
2047     Result := FConnectKind;
2048 end;
2049
2050 procedure TOleServer.SetConnectKind(cK: TConnectKind);
2051 begin
2052   // Should we validate that we have a RemoteMachineName for ckRemote ??
2053   FConnectKind := cK;
2054 end;
2055
2056 function  TOleServer.GetAutoConnect: Boolean;
2057 begin
2058   // If user wants to provide the interface to connect to, then we won't
2059   // 'automatically' connect to a server.
2060   if ConnectKind = ckAttachToInterface then
2061     Result := False
2062   else
2063     Result := FAutoConnect;
2064 end;
2065
2066 procedure TOleServer.SetAutoConnect(flag: Boolean);
2067 begin
2068   FAutoConnect := flag;
2069 end;
2070
2071 { TOleServer.IUnknown }
2072 function TOleServer.QueryInterface(const IID: TGUID; out Obj): HResult;
2073 begin
2074   if GetInterface(IID, Obj) then
2075     Result := S_OK
2076   else
2077     Result := E_NOINTERFACE;
2078 end;
2079
2080 function TOleServer._AddRef: Integer;
2081 begin
2082   Inc(FRefCount);
2083   Result := FRefCount;
2084 end;
2085
2086 function TOleServer._Release: Integer;
2087 begin
2088   Dec(FRefCount);
2089   Result := FRefCount;
2090 end;
2091 {$ENDIF _D2orD3}
2092
2093 { TEventDispatch }
2094
2095 constructor TEventDispatch.Create(Control: POleCtl);
2096 begin
2097   FControl := Control;
2098 end;
2099
2100 { TEventDispatch.IUnknown }
2101
2102 function TEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
2103 begin
2104   if GetInterface(IID, Obj) then
2105   begin
2106     Result := S_OK;
2107     Exit;
2108   end;
2109   if IsEqualIID(IID, FControl.FControlData^.EventIID) then
2110   begin
2111     GetInterface(IDispatch, Obj);
2112     Result := S_OK;
2113     Exit;
2114   end;
2115   Result := E_NOINTERFACE;
2116 end;
2117
2118 function TEventDispatch._AddRef: Integer;
2119 begin
2120   Result := FControl.fOleCtlIntf._AddRef;
2121 end;
2122
2123 function TEventDispatch._Release: Integer;
2124 begin
2125   Result := FControl.fOleCtlIntf._Release;
2126 end;
2127
2128 { TEventDispatch.IDispatch }
2129
2130 function TEventDispatch.GetTypeInfoCount(out Count: Integer): HResult;
2131 begin
2132   Count := 0;
2133   Result := S_OK;
2134 end;
2135
2136 function TEventDispatch.GetTypeInfo(Index, LocaleID: Integer;
2137   out TypeInfo): HResult;
2138 begin
2139   Pointer(TypeInfo) := nil;
2140   Result := E_NOTIMPL;
2141 end;
2142
2143 function TEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
2144   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
2145 begin
2146   Result := E_NOTIMPL;
2147 end;
2148
2149 function TEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
2150   LocaleID: Integer; Flags: Word; var Params;
2151   VarResult, ExcepInfo, ArgErr: Pointer): HResult;
2152 begin
2153   if (DispID >= DISPID_MOUSEUP) and (DispID <= DISPID_CLICK) then
2154     FControl.StandardEvent(DispID, TDispParams(Params)) else
2155     FControl.InvokeEvent(DispID, TDispParams(Params));
2156   Result := S_OK;
2157 end;
2158
2159 { TOleCtlIntf }
2160
2161 function TOleCtlIntf._AddRef: Integer;
2162 begin
2163   //{$IFDEF _D2orD3}
2164   //Result := inherited _AddRef;
2165   //{$ELSE}
2166   Inc(FRefCount);
2167   Result := FRefCount;
2168   //{$ENDIF}
2169 end;
2170
2171 function TOleCtlIntf._Release: Integer;
2172 begin
2173   //{$IFDEF _D2orD3}
2174   //Result := inherited _Release;
2175   //{$ELSE}
2176   Dec(FRefCount);
2177   Result := FRefCount;
2178   //{$ENDIF}
2179 end;
2180
2181 function TOleCtlIntf.CanInPlaceActivate: HResult;
2182 begin
2183   Result := S_OK;
2184 end;
2185
2186 function TOleCtlIntf.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
2187 begin
2188   Result := S_OK;
2189 end;
2190
2191 function TOleCtlIntf.DeactivateAndUndo: HResult;
2192 begin
2193   fOleCtl.FOleInPlaceObject.UIDeactivate;
2194   Result := S_OK;
2195 end;
2196
2197 function TOleCtlIntf.DiscardUndoState: HResult;
2198 begin
2199   Result := E_NOTIMPL;
2200 end;
2201
2202 function TOleCtlIntf.EnableModeless(fEnable: BOOL): HResult;
2203 begin
2204   Result := S_OK;
2205 end;
2206
2207 function TOleCtlIntf.GetBorder(out rectBorder: TRect): HResult;
2208 begin
2209   Result := INPLACE_E_NOTOOLSPACE;
2210 end;
2211
2212 function TOleCtlIntf.GetContainer(out container: IOleContainer): HResult;
2213 begin
2214   Result := E_NOINTERFACE;
2215 end;
2216
2217 function TOleCtlIntf.GetExtendedControl(out disp: IDispatch): HResult;
2218 begin
2219   Result := E_NOTIMPL;
2220 end;
2221
2222 function TOleCtlIntf.GetIDsOfNames(const IID: TGUID; Names: Pointer;
2223   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
2224 begin
2225   Result := E_NOTIMPL;
2226 end;
2227
2228 function TOleCtlIntf.GetMoniker(dwAssign, dwWhichMoniker: Integer;
2229   out mk: IMoniker): HResult;
2230 begin
2231   Result := E_NOTIMPL;
2232 end;
2233
2234 function TOleCtlIntf.GetTypeInfo(Index, LocaleID: Integer;
2235   out TypeInfo): HResult;
2236 begin
2237   Pointer(TypeInfo) := nil;
2238   Result := E_NOTIMPL;
2239 end;
2240
2241 function TOleCtlIntf.GetTypeInfoCount(out Count: Integer): HResult;
2242 begin
2243   Count := 0;
2244   Result := S_OK;
2245 end;
2246
2247 function TOleCtlIntf.GetWindowContext(out frame: IOleInPlaceFrame;
2248   out doc: IOleInPlaceUIWindow; out rcPosRect, rcClipRect: TRect;
2249   out frameInfo: TOleInPlaceFrameInfo): HResult;
2250 begin
2251   frame := Self;
2252   doc := nil;
2253   rcPosRect := fOleCtl.BoundsRect;
2254   rcClipRect := MakeRect( 0, 0, 32767, 32767 );
2255   with frameInfo do
2256   begin
2257     fMDIApp := False;
2258     hWndFrame := fOleCtl.ParentForm.GetWindowHandle;
2259                  //GetTopParentHandle;
2260                  // now it is not possible to make alien window to be parent for KOL window
2261     hAccel := 0;
2262     cAccelEntries := 0;
2263   end;
2264   Result := S_OK;
2265 end;
2266
2267 function TOleCtlIntf.InsertMenus(hmenuShared: HMenu;
2268   var menuWidths: TOleMenuGroupWidths): HResult;
2269 {var
2270   Menu: TMainMenu;}
2271 begin
2272   {Menu := GetMainMenu;
2273   if Menu <> nil then
2274     Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);}
2275   //TODO: implement menu populate
2276   Result := S_OK;
2277 end;
2278
2279 function TOleCtlIntf.Invoke(DispID: Integer; const IID: TGUID;
2280   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
2281   ArgErr: Pointer): HResult;
2282 {var
2283   F: PGraphicTool;}
2284 begin
2285   if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
2286   begin
2287     Result := S_OK;
2288     case DispID of
2289       DISPID_AMBIENT_BACKCOLOR:
2290         PVariant(VarResult)^ := fOleCtl.Color;
2291       DISPID_AMBIENT_DISPLAYNAME:
2292         PVariant(VarResult)^ := StringToVarOleStr( fOleCtl.Name );
2293       DISPID_AMBIENT_FONT:
2294       begin
2295         {if (fOleCtl.Parent <> nil) and fOleCtl.ParentFont then
2296           F := Parent.Font // TOleControl(Parent).Font
2297         else
2298           F := Font;
2299         PVariant(VarResult)^ := FontToOleFont(F);}
2300         //TODO: implement Font later
2301       end;
2302       DISPID_AMBIENT_FORECOLOR:
2303         PVariant(VarResult)^ := fOleCtl.fTextColor; // Font.Color;
2304       DISPID_AMBIENT_LOCALEID:
2305         PVariant(VarResult)^ := Integer(GetUserDefaultLCID);
2306       DISPID_AMBIENT_MESSAGEREFLECT:
2307         PVariant(VarResult)^ := True;
2308       DISPID_AMBIENT_USERMODE:
2309         PVariant(VarResult)^ := TRUE; // not (csDesigning in ComponentState);
2310       DISPID_AMBIENT_UIDEAD:
2311         PVariant(VarResult)^ := FALSE; // csDesigning in ComponentState;
2312       DISPID_AMBIENT_SHOWGRABHANDLES:
2313         PVariant(VarResult)^ := False;
2314       DISPID_AMBIENT_SHOWHATCHING:
2315         PVariant(VarResult)^ := False;
2316       DISPID_AMBIENT_SUPPORTSMNEMONICS:
2317         PVariant(VarResult)^ := True;
2318       DISPID_AMBIENT_AUTOCLIP:
2319         PVariant(VarResult)^ := True;
2320     else
2321       Result := DISP_E_MEMBERNOTFOUND;
2322     end;
2323   end else
2324     Result := DISP_E_MEMBERNOTFOUND;
2325 end;
2326
2327 function TOleCtlIntf.LockInPlaceActive(fLock: BOOL): HResult;
2328 begin
2329   Result := E_NOTIMPL;
2330 end;
2331
2332 function TOleCtlIntf.OleControlSite_TranslateAccelerator(msg: PMsg;
2333   grfModifiers: Integer): HResult;
2334 begin
2335   Result := E_NOTIMPL;
2336 end;
2337
2338 function TOleCtlIntf.OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult;
2339 begin
2340   wnd := fOleCtl.ParentForm.GetWindowHandle; // GetTopParentHandle;
2341   Result := S_OK;
2342 end;
2343
2344 function TOleCtlIntf.OleInPlaceFrame_TranslateAccelerator(var msg: TMsg;
2345   wID: Word): HResult;
2346 begin
2347   Result := S_FALSE;
2348 end;
2349
2350 function TOleCtlIntf.OleInPlaceSite_GetWindow(out wnd: HWnd): HResult;
2351 begin
2352   Result := S_OK;
2353   wnd := fOleCtl.ParentWindow;
2354   if wnd = 0 then Result := E_FAIL;
2355 end;
2356
2357 function TOleCtlIntf.OnChanged(dispid: TDispID): HResult;
2358 begin
2359   try
2360     case dispid of
2361       DISPID_BACKCOLOR:
2362         if not fOleCtl.FUpdatingColor then
2363         begin
2364           fOleCtl.FUpdatingColor := True;
2365           try
2366             fOleCtl.fColor := fOleCtl.GetIntegerProp(DISPID_BACKCOLOR);
2367           finally
2368             fOleCtl.FUpdatingColor := False;
2369           end;
2370         end;
2371       DISPID_ENABLED:
2372         if not fOleCtl.FUpdatingEnabled then
2373         begin
2374           fOleCtl.FUpdatingEnabled := True;
2375           try
2376             fOleCtl.Enabled := fOleCtl.GetWordBoolProp(DISPID_ENABLED);
2377           finally
2378             fOleCtl.FUpdatingEnabled := False;
2379           end;
2380         end;
2381       DISPID_FONT:
2382         if not fOleCtl.FUpdatingFont then
2383         begin
2384           fOleCtl.FUpdatingFont := True;
2385           try
2386             //OleFontToFont(GetVariantProp(DISPID_FONT), Font);
2387             // font - implement later
2388           finally
2389             fOleCtl.FUpdatingFont := False;
2390           end;
2391         end;
2392       DISPID_FORECOLOR:
2393         if not fOleCtl.FUpdatingFont then
2394         begin
2395           fOleCtl.FUpdatingFont := True;
2396           try
2397             fOleCtl.fTextColor := fOleCtl.GetIntegerProp(DISPID_FORECOLOR);
2398             //Font.Color := GetIntegerProp(DISPID_FORECOLOR);
2399           finally
2400             fOleCtl.FUpdatingFont := False;
2401           end;
2402         end;
2403     end;
2404   except  // control sent us a notification for a dispid it doesn't have.
2405     //on EOleError do ;
2406   end;
2407   Result := S_OK;
2408 end;
2409
2410 function TOleCtlIntf.OnControlInfoChanged: HResult;
2411 begin
2412   Result := E_NOTIMPL;
2413 end;
2414
2415 function TOleCtlIntf.OnFocus(fGotFocus: BOOL): HResult;
2416 begin
2417   Result := E_NOTIMPL;
2418 end;
2419
2420 function TOleCtlIntf.OnInPlaceActivate: HResult;
2421 begin
2422   fOleCtl.FOleObject.QueryInterface( IOleInPlaceObject,
2423                                      fOleCtl.FOleInPlaceObject);
2424   fOleCtl.FOleObject.QueryInterface( IOleInPlaceActiveObject,
2425                                      fOleCtl.FOleInPlaceActiveObject);
2426   Result := S_OK;
2427 end;
2428
2429 function TOleCtlIntf.OnInPlaceDeactivate: HResult;
2430 begin
2431   fOleCtl.FOleInPlaceActiveObject := nil;
2432   fOleCtl.FOleInPlaceObject := nil;
2433   Result := S_OK;
2434 end;
2435
2436 function TOleCtlIntf.OnPosRectChange(const rcPosRect: TRect): HResult;
2437 begin
2438   fOleCtl.FOleInPlaceObject.SetObjectRects(rcPosRect, MakeRect(0, 0, 32767, 32767));
2439   Result := S_OK;
2440 end;
2441
2442 function TOleCtlIntf.OnRequestEdit(dispid: TDispID): HResult;
2443 begin
2444   Result := S_OK;
2445 end;
2446
2447 function TOleCtlIntf.OnShowWindow(fShow: BOOL): HResult;
2448 begin
2449   Result := S_OK;
2450 end;
2451
2452 function TOleCtlIntf.OnUIActivate: HResult;
2453 begin
2454   fOleCtl.SetUIActive(True);
2455   Result := S_OK;
2456 end;
2457
2458 function TOleCtlIntf.OnUIDeactivate(fUndoable: BOOL): HResult;
2459 begin
2460   SetMenu(0, 0, 0);
2461   fOleCtl.SetUIActive(False);
2462   Result := S_OK;
2463 end;
2464
2465 function TOleCtlIntf.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
2466   out res: Integer; Cookie: Integer): HResult;
2467 begin
2468   Result := S_OK;
2469 end;
2470
2471 function TOleCtlIntf.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
2472   out res, Cookie: Integer): HResult;
2473 begin
2474   Result := S_OK;
2475 end;
2476
2477 function TOleCtlIntf.QueryInterface(const IID: TGUID; out Obj): HResult;
2478 begin
2479   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
2480 end;
2481
2482 function TOleCtlIntf.RemoveMenus(hmenuShared: HMenu): HResult;
2483 begin
2484   while GetMenuItemCount(hmenuShared) > 0 do
2485     RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
2486   Result := S_OK;
2487 end;
2488
2489 function TOleCtlIntf.RequestBorderSpace(
2490   const borderwidths: TRect): HResult;
2491 begin
2492   Result := INPLACE_E_NOTOOLSPACE;
2493 end;
2494
2495 function TOleCtlIntf.RequestNewObjectLayout: HResult;
2496 var
2497   Extent: TPoint;
2498   W, H: Integer;
2499   DC: HDC;
2500   PixelsPerInch: Integer;
2501 begin
2502   Result := fOleCtl.FOleObject.GetExtent(DVASPECT_CONTENT, Extent);
2503   if Result <> S_OK then Exit;
2504
2505   W := fOleCtl.Width;
2506   H := fOleCtl.Height;
2507   if (W = 0) or (H = 0) then
2508   begin
2509     DC := GetDC(0);
2510     PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
2511     ReleaseDC(0, DC);
2512
2513     W := MulDiv(Extent.X, PixelsPerInch, 2540);
2514     H := MulDiv(Extent.Y, PixelsPerInch, 2540);
2515     if (fOleCtl.FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) and
2516        (fOleCtl.FOleControl = nil) then
2517     begin
2518       if W > 32 then W := 32;
2519       if H > 32 then H := 32;
2520     end;
2521   end;
2522   fOleCtl.SetBoundsRect( MakeRect( fOleCtl.Left, fOleCtl.Top,
2523                          fOleCtl.Left + W, fOleCtl.Top + H ) );
2524 end;
2525
2526 function TOleCtlIntf.SaveObject: HResult;
2527 begin
2528   Result := S_OK;
2529 end;
2530
2531 function TOleCtlIntf.Scroll(scrollExtent: TPoint): HResult;
2532 begin
2533   Result := E_NOTIMPL;
2534 end;
2535
2536 function TOleCtlIntf.SetActiveObject(
2537   const activeObject: IOleInPlaceActiveObject;
2538   pszObjName: POleStr): HResult;
2539 begin
2540   Result := S_OK;
2541 end;
2542
2543 function TOleCtlIntf.SetBorderSpace(pborderwidths: PRect): HResult;
2544 begin
2545   Result := E_NOTIMPL;
2546 end;
2547
2548 function TOleCtlIntf.SetMenu(hmenuShared, holemenu: HMenu;
2549   hwndActiveObject: HWnd): HResult;
2550 var
2551   Menu: HMenu;
2552 begin
2553   Menu := fOleCtl.GetMainMenu;
2554   Result := S_OK;
2555   if Menu <> 0 then
2556   begin
2557     //Menu.SetOle2MenuHandle(hmenuShared);
2558     Result := OleSetMenuDescriptor( holemenu,
2559               fOleCtl.ParentForm.GetWindowHandle,
2560               hwndActiveObject, nil, nil);
2561   end;
2562 end;
2563
2564 function TOleCtlIntf.SetStatusText(pszStatusText: POleStr): HResult;
2565 begin
2566   Result := S_OK;
2567 end;
2568
2569 function TOleCtlIntf.ShowObject: HResult;
2570 begin
2571   fOleCtl.HookControlWndProc;
2572   Result := S_OK;
2573 end;
2574
2575 function TOleCtlIntf.ShowPropertyFrame: HResult;
2576 begin
2577   Result := E_NOTIMPL;
2578 end;
2579
2580 function TOleCtlIntf.TransformCoords(var ptlHimetric: TPoint;
2581   var ptfContainer: TPointF; flags: Integer): HResult;
2582 var DC: HDC;
2583     PixelsPerInch: Integer;
2584 begin
2585   DC := GetDC(0);
2586   PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
2587   ReleaseDC(0, DC);
2588
2589   if flags and XFORMCOORDS_HIMETRICTOCONTAINER <> 0 then
2590   begin
2591     ptfContainer.X := MulDiv(ptlHimetric.X, PixelsPerInch, 2540);
2592     ptfContainer.Y := MulDiv(ptlHimetric.Y, PixelsPerInch, 2540);
2593   end else
2594   begin
2595     ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / PixelsPerInch));
2596     ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / PixelsPerInch));
2597   end;
2598   Result := S_OK;
2599 end;
2600
2601 end.