+ more delphi compatibility

* fillchar bug in dispatch code fixed

git-svn-id: trunk@5765 -

packages/extra/winunits/activex.pp

@@ -20,7 +20,7 @@ Unit ActiveX;
 
 Interface
 
-Uses variants,Windows,types;
+Uses variants,Windows,ctypes,types;
 
 
 type
@@ -756,11 +756,15 @@ TYPE
    PMultiQI            = ^Multi_QI;
    tagMULTI_QI         = Record
                           iid: piid;                   // pass this one in
-                          itf: pointer {IUnknown};                // get these out (you must set to NULL before calling)
-                          hr : Hresult;
+                          itf: IUnknown;               // get these out (you must set to NULL before calling)
+                          hr : HResult;
                           END;
    MULTI_QI            = TagMULTI_QI;
    PMulti_QI           = PMultiQI;
+   TMultiQI						 = tagMULTI_QI;
+
+   PMultiQIArray = ^TMultiQIArray;
+   TMultiQIArray = array[0..65535] of TMultiQI;
 
 
    HContext            = Pointer;
@@ -3303,6 +3307,15 @@ type
   function  SysReAllocString(var bstr:pointer;psz: pointer): Integer; external oleaut32dll name 'SysReAllocString';
   function  SysReAllocStringLen(var bstr:pointer;psz: pointer; len:dword): Integer; external oleaut32dll name 'SysReAllocStringLen';
 
+	{ Active object registration API }
+	const
+	  ACTIVEOBJECT_STRONG = 0;
+	  ACTIVEOBJECT_WEAK = 1;
+	
+	function RegisterActiveObject(unk: IUnknown; const clsid: TCLSID; dwFlags: DWORD; out dwRegister: culong): HResult; external oleaut32dll name 'RegisterActiveObject';
+	function RevokeActiveObject(dwRegister: culong; pvReserved: Pointer) : HResult; external oleaut32dll name 'RevokeActiveObject';
+	function GetActiveObject(const clsid: TCLSID; pvReserved: Pointer; out unk: IUnknown) : HResult; external oleaut32dll name 'GetActiveObject';
+  
 implementation
 
 end.

packages/extra/winunits/comconst.pp

@@ -22,6 +22,7 @@ unit comconst;
       SNoMethod = 'Method ''%s'' is not supported by automation object';
       SOleError = 'OLE error %.8x';
       SVarNotObject = 'Variant does not reference an automation object';
+      SDCOMNotInstalled = 'DCOM not installed';
 
   implementation
 

packages/extra/winunits/comobj.pp

@@ -19,7 +19,7 @@ unit comobj;
   interface
 
     uses
-      sysutils,activex;
+      Windows,Types,Variants,Sysutils,ActiveX;
 
     type
       EOleError = class(Exception);
@@ -110,10 +110,28 @@ unit comobj;
        DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
     procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo);
 
+    type
+      TCoCreateInstanceExProc = function(const clsid: TCLSID; unkOuter: IUnknown; dwClsCtx: DWORD; ServerInfo: PCoServerInfo;
+      dwCount: ULONG; rgmqResults: PMultiQIArray): HResult stdcall;
+      TCoInitializeExProc = function (pvReserved: Pointer;
+      coInit: DWORD): HResult; stdcall;
+      TCoAddRefServerProcessProc = function : ULONG; stdcall;
+      TCoReleaseServerProcessProc = function : ULONG; stdcall;
+      TCoResumeClassObjectsProc = function : HResult; stdcall;
+      TCoSuspendClassObjectsProc = function : HResult; stdcall;
+
+    const
+      CoCreateInstanceEx : TCoCreateInstanceExProc = nil;
+      CoInitializeEx : TCoInitializeExProc = nil;
+      CoAddRefServerProcess : TCoAddRefServerProcessProc = nil;
+      CoReleaseServerProcess : TCoReleaseServerProcessProc = nil;
+      CoResumeClassObjects : TCoResumeClassObjectsProc = nil;
+      CoSuspendClassObjects : TCoSuspendClassObjectsProc = nil;
+
 implementation
 
     uses
-      Windows,Types,Variants,ComConst;
+      ComConst,Ole2;
 
     constructor EOleSysError.Create(const Msg: string; aErrorCode: HRESULT; aHelpContext: Integer);
       var
@@ -155,9 +173,34 @@ implementation
 
 
    function CreateRemoteComObject(const MachineName : WideString;const ClassID : TGUID) : IUnknown;
+     var
+       flags : DWORD;
+       localhost : array[0..MAX_COMPUTERNAME_LENGTH] of WideChar;
+       server : TCoServerInfo;
+       mqi : TMultiQI;
+       size : DWORD;
      begin
-       {!!!!!!!}
-       runerror(211);
+       if not(assigned(CoCreateInstanceEx)) then
+         raise Exception.CreateRes(@SDCOMNotInstalled);
+
+       FillChar(server,sizeof(server),0);
+       server.pwszName:=PWideChar(MachineName);
+
+       FillChar(mqi,sizeof(mqi),0);
+       mqi.iid:=@IID_IUnknown;
+
+       flags:=CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
+
+       { actually a remote call? }
+       size:=sizeof(localhost);
+       if (MachineName<>'') and
+          (not(GetComputerNameW(localhost,size)) or
+          (WideCompareText(localhost,MachineName)<>0)) then
+           flags:=CLSCTX_REMOTE_SERVER;
+
+       OleCheck(CoCreateInstanceEx(ClassID,nil,flags,@server,1,@mqi));
+       OleCheck(mqi.hr);
+       Result:=mqi.itf;
      end;
 
 
@@ -171,9 +214,13 @@ implementation
 
 
    function GetActiveOleObject(const ClassName : string) : IDispatch;
+     var
+     	 intf : IUnknown;
+       id : TCLSID;
      begin
-       {!!!!!!!}
-       runerror(211);
+       id:=ProgIDToClassID(ClassName);
+       OleCheck(GetActiveObject(id,nil,intf));
+       OleCheck(intf.QueryInterface(IDispatch,Result));
      end;
 
 
@@ -353,7 +400,7 @@ implementation
                 rgdispidNamedArgs:=nil
               else
                 rgdispidNamedArgs:=@DispIDs^[1];
-              cArgs:=CallDesc^.ArgCount;              
+              cArgs:=CallDesc^.ArgCount;
             end;
           InvokeKind:=CallDesc^.CallType;
           MethodID:=DispIDs^[0];
@@ -442,7 +489,7 @@ implementation
       	dispatchinterface : pointer;
       	ids : array[0..255] of TDispID;
       begin
-        fillchar(ids,sizeof(ids),sizeof(ids));
+        fillchar(ids,sizeof(ids),0);
 {$ifdef DEBUG_COMDISPATCH}
         writeln('ComObjDispatchInvoke called');
         writeln('ComObjDispatchInvoke: @CallDesc = $',hexstr(PtrInt(CallDesc),SizeOf(Pointer)*2),' CallDesc^.ArgCount = ',CallDesc^.ArgCount);
@@ -463,8 +510,20 @@ implementation
 
 const
   Initialized : boolean = false;
-
+var
+  Ole32Dll : HModule;
 initialization
+  Ole32Dll:=GetModuleHandle('ole32.dll');
+  if Ole32Dll<>0 then
+    begin
+      Pointer(CoCreateInstanceEx):=GetProcAddress(Ole32Dll,'CoCreateInstanceExProc');
+      Pointer(CoInitializeEx):=GetProcAddress(Ole32Dll,'CoInitializeExProc');
+      Pointer(CoAddRefServerProcess):=GetProcAddress(Ole32Dll,'CoAddRefServerProcessProc');
+      Pointer(CoReleaseServerProcess):=GetProcAddress(Ole32Dll,'CoReleaseServerProcessProc');
+      Pointer(CoResumeClassObjects):=GetProcAddress(Ole32Dll,'CoResumeClassObjectsProc');
+      Pointer(CoSuspendClassObjects):=GetProcAddress(Ole32Dll,'CoSuspendClassObjectsProc');
+    end;
+
   if not(IsLibrary) then
     Initialized:=Succeeded(CoInitialize(nil));
   SafeCallErrorProc:=@SafeCallErrorHandler;

packages/extra/winunits/ole2.pp

@@ -12,22 +12,80 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
+{$MODE OBJFPC}
 unit ole2;
 
-{$Mode ObjFpc}
-
   interface
 
     uses
-       windows;
-
-    type
-       IUnknown = class
-         public
-           function QueryInterface(const iid: TIID; var obj): HResult; virtual; {$ifndef VER0_99_10}stdcall;{$endif} abstract;
-           function AddRef: Longint; virtual; {$ifndef VER0_99_10}stdcall;{$endif} abstract;
-           function Release: Longint; virtual; {$ifndef VER0_99_10}stdcall;{$endif} abstract;
-       end;
+      windows;
+
+    const
+      GUID_NULL: TGUID = (D1:$00000000;D2:$0000;D3:$0000;D4:($00,$00,$00,$00,$00,$00,$00,$00));
+      IID_IUnknown: TGUID = (D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IClassFactory: TGUID = (D1:$00000001;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IMarshal: TGUID = (D1:$00000003;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IMalloc: TGUID = (D1:$00000002;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IStdMarshalInfo: TGUID = (D1:$00000018;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IExternalConnection: TGUID = (D1:$00000019;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumUnknown: TGUID = (D1:$00000100;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IBindCtx: TGUID = (D1:$0000000E;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumMoniker: TGUID = (D1:$00000102;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IRunnableObject: TGUID = (D1:$00000126;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IRunningObjectTable: TGUID = (D1:$00000010;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IPersist: TGUID = (D1:$0000010C;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IPersistStream: TGUID = (D1:$00000109;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IMoniker: TGUID = (D1:$0000000F;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumString: TGUID = (D1:$00000101;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IStream: TGUID = (D1:$0000000C;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumStatStg: TGUID = (D1:$0000000D;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IStorage: TGUID = (D1:$0000000B;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IPersistFile: TGUID = (D1:$0000010B;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IPersistStorage: TGUID = (D1:$0000010A;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_ILockBytes: TGUID = (D1:$0000000A;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumFormatEtc: TGUID = (D1:$00000103;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumStatData: TGUID = (D1:$00000105;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IRootStorage: TGUID = (D1:$00000012;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IAdviseSink: TGUID = (D1:$0000010F;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IAdviseSink2: TGUID = (D1:$00000125;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IDataObject: TGUID = (D1:$0000010E;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IDataAdviseHolder: TGUID = (D1:$00000110;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IMessageFilter: TGUID = (D1:$00000016;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IRpcChannelBuffer: TGUID = (D1:$D5F56B60;D2:$593B;D3:$101A;D4:($B5,$69,$08,$00,$2B,$2D,$BF,$7A));
+      IID_IRpcProxyBuffer: TGUID = (D1:$D5F56A34;D2:$593B;D3:$101A;D4:($B5,$69,$08,$00,$2B,$2D,$BF,$7A));
+      IID_IRpcStubBuffer: TGUID = (D1:$D5F56AFC;D2:$593B;D3:$101A;D4:($B5,$69,$08,$00,$2B,$2D,$BF,$7A));
+      IID_IPSFactoryBuffer: TGUID = (D1:$D5F569D0;D2:$593B;D3:$101A;D4:($B5,$69,$08,$00,$2B,$2D,$BF,$7A));
+      IID_ICreateTypeInfo: TGUID = (D1:$00020405;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_ICreateTypeLib: TGUID = (D1:$00020406;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IDispatch: TGUID = (D1:$00020400;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumVariant: TGUID = (D1:$00020404;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_ITypeComp: TGUID = (D1:$00020403;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_ITypeInfo: TGUID = (D1:$00020401;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_ITypeLib: TGUID = (D1:$00020402;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IErrorInfo: TGUID = (D1:$1CF2B120;D2:$547D;D3:$101B;D4:($8E,$65,$08,$00,$2B,$2B,$D1,$19));
+      IID_ICreateErrorInfo: TGUID = (D1:$22F03340;D2:$547D;D3:$101B;D4:($8E,$65,$08,$00,$2B,$2B,$D1,$19));
+      IID_ISupportErrorInfo: TGUID = (D1:$DF0B3D60;D2:$548F;D3:$101B;D4:($8E,$65,$08,$00,$2B,$2B,$D1,$19));
+      IID_IOleAdviseHolder: TGUID = (D1:$00000111;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleCache: TGUID = (D1:$0000011E;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleCache2: TGUID = (D1:$00000128;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleCacheControl: TGUID = (D1:$00000129;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IParseDisplayName: TGUID = (D1:$0000011A;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleContainer: TGUID = (D1:$0000011B;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleClientSite: TGUID = (D1:$00000118;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleObject: TGUID = (D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleWindow: TGUID = (D1:$00000114;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleLink: TGUID = (D1:$0000011D;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleItemContainer: TGUID = (D1:$0000011C;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleInPlaceUIWindow: TGUID = (D1:$00000115;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleInPlaceActiveObject: TGUID = (D1:$00000117;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleInPlaceFrame: TGUID = (D1:$00000116;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleInPlaceObject: TGUID = (D1:$00000113;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IOleInPlaceSite: TGUID = (D1:$00000119;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IViewObject: TGUID = (D1:$0000010D;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IViewObject2: TGUID = (D1:$00000127;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IDropSource: TGUID = (D1:$00000121;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IDropTarget: TGUID = (D1:$00000122;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
+      IID_IEnumOleVerb: TGUID = (D1:$00000104;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
 
   implementation