* more ComObj stuff implemented

git-svn-id: trunk@3386 -

packages/extra/winunits/activex.pp

@@ -3148,6 +3148,7 @@ type
   function ProgIDFromCLSID(const _para1:TCLSID; out _para2:POLESTR):HRESULT;stdcall; external  'ole32.dll' name 'ProgIDFromCLSID';
 
   function CLSIDFromProgID(_para1:POLESTR; _para2:LPCLSID):HRESULT;stdcall; external  'ole32.dll' name 'CLSIDFromProgID';
+  function CLSIDFromProgID(_para1:POLESTR; out _para2:TCLSID):HRESULT;stdcall; external  'ole32.dll' name 'CLSIDFromProgID';
 
   function StringFromGUID2(const _para1:TGUID; _para2:LPOLESTR; _para3:longint):longint;stdcall; external  'ole32.dll' name 'StringFromGUID2';
 

packages/extra/winunits/comobj.pp

@@ -13,22 +13,75 @@
  **********************************************************************}
 {$mode objfpc}
 {$H+}
+{$inline on}
 unit comobj;
 
   interface
 
-   function CreateClassID : ansistring;
+    uses
+      sysutils;
+
+    type
+      EOleError = class(Exception);
+
+      EOleSysError = class(EOleError)
+      private
+        FErrorCode: HRESULT;
+      public
+        constructor Create(const Msg: string; aErrorCode: HRESULT;aHelpContext: Integer);
+        property ErrorCode: HRESULT read FErrorCode write FErrorCode;
+      end;
+
+      EOleException = class(EOleSysError)
+      private
+        FHelpFile: string;
+        FSource: string;
+      public
+        constructor Create(const Msg: string; aErrorCode: HRESULT;const aSource,aHelpFile: string;aHelpContext: Integer);
+        property HelpFile: string read FHelpFile write FHelpFile;
+        property Source: string read FSource write FSource;
+      end;
+
+  EOleRegistrationError = class(EOleError);
 
-   function CreateComObject(const ClassID: TGUID) : IUnknown;
-   function CreateRemoteComObject(const MachineName : WideString;const ClassID : TGUID) : IUnknown;
-   function CreateOleObject(const ClassName : string) : IDispatch;
-   function GetActiveOleObject(const ClassName: string) : IDispatch;
+
+    function CreateClassID : ansistring;
+
+    function CreateComObject(const ClassID: TGUID) : IUnknown;
+    function CreateRemoteComObject(const MachineName : WideString;const ClassID : TGUID) : IUnknown;
+    function CreateOleObject(const ClassName : string) : IDispatch;
+    function GetActiveOleObject(const ClassName: string) : IDispatch;
+
+    procedure OleCheck(Value : HResult);inline;
+    procedure OleError(Code: HResult);
+
+    function ProgIDToClassID(const id : string) : TGUID;
 
   implementation
 
     uses
        windows,activex;
 
+    constructor EOleSysError.Create(const Msg: string; aErrorCode: HRESULT; aHelpContext: Integer);
+      var
+        m : string;
+      begin
+        if Msg='' then
+          m:=SysErrorMessage(aErrorCode)
+        else
+          m:=Msg;
+        inherited CreateHelp(m,HelpContext);
+        FErrorCode:=aErrorCode;
+      end;
+
+
+    constructor EOleException.Create(const Msg: string; aErrorCode: HRESULT;const aSource,aHelpFile: string; aHelpContext: Integer);
+      begin
+        inherited Create(Msg,aErrorCode,aHelpContext);
+        FHelpFile:=aHelpFile;
+        FSource:=aSource;
+      end;
+
     {$define FPC_COMOBJ_HAS_CREATE_CLASS_ID}
     function CreateClassID : ansistring;
       var
@@ -57,9 +110,11 @@ unit comobj;
 
 
    function CreateOleObject(const ClassName : string) : IDispatch;
+     var
+       id : TCLSID;
      begin
-       {!!!!!!!}
-       runerror(211);
+        id:=ProgIDToClassID(ClassName);
+        OleCheck(CoCreateInstance(id,nil,CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER,IDispatch,result));
      end;
 
 
@@ -70,5 +125,31 @@ unit comobj;
      end;
 
 
+   procedure OleError(Code: HResult);
+     begin
+       raise EOleSysError.Create('',Code,0);
+     end;
+
+
+   procedure OleCheck(Value : HResult);inline;
+     begin
+       if not(Succeeded(Value)) then
+         OleError(Value);
+     end;
+
+
+   function ProgIDToClassID(const id : string) : TGUID;
+     begin
+       OleCheck(CLSIDFromProgID(PWideChar(WideString(id)),result));
+     end;
+
+const
+  Initialized : boolean = false;
 
+initialization
+  if not(IsLibrary) then
+    Initialized:=Succeeded(CoInitialize(nil));
+finalization
+  if Initialized then
+    CoUninitialize;
 end.