Creating Instances of COM objects with IClassFactory

The IDL for the COM onject can be seen here.
A binary of the COM object can be downloaded from here.
The COM object created in Ada is found here.
A zip of the COM source code (in C++) can be downloaded from here.

To install the COM object on your system type:

	regsvr32 beep.dll

To compile under ObjectAda remove the pragma Linker_Options and insure that your project includes the following directories in the project search path:

• XXXX:\program files\aonix\objectada\apilib
• XXXX:\program files\aonix\objectada\win32ada\binding\lib

with win32.objbase; use win32.objbase;
with win32.winerror;
use type HRESULT;
with interfaces.c; use interfaces.c;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with system;

procedure ComBeep2 is

pragma Linker_Options("-lole32");

   -- IID for IBeep
   IID_IBeep         : aliased IID := (16#0FE0EE22#,16#8AA2#,16#11d2#,
                        (Char'Val(16#81#),Char'Val(16#AA#),Char'Val(16#44#),
                         Char'Val(16#45#),Char'Val(16#53#),Char'Val(16#54#),
                         Char'Val(16#00#),Char'Val(16#01#)) );

   -- Class ID of an object to create that has an interface to IBeep
   CLSID_BeepClass   : aliased CLSID := (16#0FE0EE21#,16#8AA2#,16#11d2#,
                        (Char'Val(16#81#),Char'Val(16#AA#),Char'Val(16#44#),
                         Char'Val(16#45#),Char'Val(16#53#),Char'Val(16#54#),
                         Char'Val(16#00#),Char'Val(16#01#)) );
                         
   -- IID for IClassFactory
   IID_IClassFactory : aliased IID := (16#00000001#,16#0000#,16#0000#,
                        (Char'Val(16#C0#),Char'Val(16#00#),
                         Char'Val(16#00#),Char'Val(16#00#),
                         Char'Val(16#00#),Char'Val(16#00#),
                         Char'Val(16#00#),Char'Val(16#46#)) );

   -- Interface IBeep
   type IBeep;
   type Pointer_To_IBeep is access all IBeep;

   -- C++ style VTBL of methods in the IBeep Interface
   type IBeepVtbl;
   type Pointer_To_IBeepVtbl is access all IBeepVtbl;

   -- Create method prototypes for IBeep
   -- Don't forger that first argument of C++ methods is C++'s this pointer

   -- IUnkown
   -- IBeep "interface inherits" from IUnkown and therefore requires those
   -- methods also.

   type af_IBeep_QueryInterface is access function (
      This     : access IBeep;
      riid     : REFIID;
      ppvObject: access Win32.PVOID)
      return HRESULT;

   pragma Convention(Stdcall, af_IBeep_QueryInterface);

   type af_IBeep_AddRef is access function (
      This: access IBeep)
      return Win32.ULONG;
   pragma Convention(Stdcall, af_IBeep_AddRef);

   type af_IBeep_Release is access function (
      This: access IBeep)
      return Win32.ULONG;
   pragma Convention(Stdcall, af_IBeep_Release);

   -- IBeep
   -- IBeep only has one method called Beep that sounds a beep and display a
   -- message box.

   type af_IBeep_Beep is access function (
      This: access IBeep)
      return HRESULT;
   pragma Convention(Stdcall, af_IBeep_Beep);

   -- IBeep just contains a pointer to its VTBL
   type IBeep is
      record
         lpVtbl: Pointer_To_IBeepVtbl;
      end record;

   -- IBeepVtbl contains pointers to all the methods IBeep interfaces to.
   type IBeepVtbl is
      record
         QueryInterface: af_IBeep_QueryInterface;
         AddRef        : af_IBeep_AddRef;
         Release       : af_IBeep_Release;
         Beep          : af_IBeep_Beep;
      end record;

   -- Normally Ada passes by reference non scalar types, so we need the
   -- following:
   pragma Convention(C_Pass_By_Copy, IBeep);
   pragma Convention(C_Pass_By_Copy, IBeepVtbl);

   -- Conversion functions to make the compiler happy.
   function To_LPOLESTR is
       new Ada.Unchecked_Conversion (wchar_array, LPOLESTR);
   function To_LPUNKNOWN is
       new Ada.Unchecked_Conversion (system.address, LPUNKNOWN);
   function To_LPCLASSFACTORY is
       new Ada.Unchecked_Conversion (system.address, LPCLASSFACTORY);
   function To_Pointer_To_IBeep is
       new Ada.Unchecked_Conversion (Win32.PVOID, Pointer_To_IBeep);


   RetPointer             : aliased Win32.PVOID;
   hr                     : HRESULT;
   ClassFactoryInterface  : LPCLASSFACTORY;
   BeepInterface          : Pointer_To_IBeep;
   refcount               : Win32.ULONG;
   com_error              : exception;
begin

   put_line("Initialize Com Libraries");
   hr := CoInitialize(system.null_address);
   if hr /= S_OK then
      raise com_error;
   end if;

   put_line("Use CoGetClassObject to get IClassFactory of Beeper Class");
   hr := CoGetClassObject(CLSID_BeepClass'unchecked_access,
                          Win32.DWORD(CLSCTX_ALL),
                          System.Null_Address,
                          IID_IClassFactory'unchecked_access,
                          RetPointer'unchecked_access);
   if hr /= S_OK then
      raise com_error;
   end if;


   put_line("Convert return pointer to pointer to IClassFactory");
   ClassFactoryInterface := To_LPCLASSFACTORY(RetPointer);

   put_line("Use class factory to construct IBeep");
   hr := ClassFactoryInterface.lpvtbl.CreateInstance(ClassFactoryInterface,
               To_LPUNKNOWN(system.null_address),
               IID_IBeep'unchecked_access,
               RetPointer'unchecked_access);

   put_line("Convert return pointer to pointer to IBeep");
   BeepInterface := To_Pointer_To_IBeep(RetPointer);

   put_line("Release class factory");
   refcount := ClassFactoryInterface.lpvtbl.Release(ClassFactoryInterface);

   put_Line("IBeep->Beep");
   hr := BeepInterface.lpvtbl.Beep(BeepInterface);
   if hr /= S_OK then
      raise com_error;
   end if;

   put_Line("Release IBeep Interface");
   refcount := BeepInterface.lpvtbl.Release(BeepInterface);

   put_line("Uninit COM Libs");
   CoUninitialize;
end ComBeep2;