Using COM objects from Ada

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

A version that uses the Win32 Api from the OpenPack is available here from John Walker.

To compile under ObjectAda with Win32Ada 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 win32.winerror;
with interfaces.c; use interfaces.c;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with system;

procedure ComBeep 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#)) );

   -- 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 Win32.Winerror.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 displays a
   -- message box.

   type af_IBeep_Beep is access function (
      This: access IBeep)
      return Win32.Winerror.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_LPUNKNOWN is
       new Ada.Unchecked_Conversion (system.address, LPUNKNOWN);
   function To_Pointer_To_IBeep is
       new Ada.Unchecked_Conversion (Win32.PVOID, Pointer_To_IBeep);


   RetPointer        : aliased Win32.PVOID;
   hr                : Win32.Winerror.HRESULT;
   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("CoCreateInstance");
   hr := CoCreateInstance(CLSID_BeepClass'unchecked_access,
                          To_LPUNKNOWN(system.null_address),
                          Win32.DWORD(CLSCTX_ALL),
                          IID_IBeep'unchecked_access,
                          RetPointer'unchecked_access);
   if hr /= S_OK then
      raise com_error;
   end if;

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

   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 ComBeep;