COM Exe Server With PowerBASIC Console Compiler 5.04

[Frederick J. Harris]

Just got this working so I thought I'd post it in case anyone is interested.  Several weeks ago I was working through an Atl book of mine and chapter 5 was about building Exe COM servers and the issues related to marshalling parameters between processes as opposed to the easier scenerio with InProc Dll servers where everything resides in the same process.  It turns out that if the *.idl file C++ programmers use to define interfaces in a language agnostic manner contains the oleautomation attribute as part of the COM interface definition, and all the parameters to the functions are automation compatible, then the 'Universal Marshaller' in oleauto32.dll can be used to perform all the marshalling.  This was very easy to get working in C++.  Essentially, all that needed to be done was to add 'oleautomation' to the interface definitions, add a 'library' clause to the idl file, create the type lib with the midl compiler (its very easy), and finally write some registry code to register the component and type library.

It occurred to me that this could probably be made to work with PowerBASIC.  My biggest uncertainty concerned using PBTyp.exe to embed the midl generated *.tlb (binary type library) into the exe.  PowerBASIC's documentation on PBTyp.exe states that a tlb file can be embedded in either a dll or exe so I gave it a try and it worked.  If it wouldn't have worked I should have been able to just use the seperate *.tlb file, but I'm glad it worked because that is a neater solution to have the type library embedded right into the binary.

So anyway, below is the code for CC.exe.  It can be run in three modes.  You can just paste it into your editor and run it 'as is'.  In that case it is running without being started by any command line parameters.  It will create an object internally and dump varios diagnostic info as well as its Class Factory and custom interfaces.

If started from the command line with the /r switch, e.g.,

C:\Code\PwrBasic\PBCC50\CC>CC.exe /r

it will register itself in your registry in terms of Prog Ids, Clsids, Interfaces, and typelib info.  If run in that mode it simply exits after outputting some diagnostic information.  After doing that you'll want to open your registry with regedit and check out the CLSID, ProgIds, Interface, and TypeLib keys under HKEY_CLASSES_ROOT.

The last mode in which it runs is when a client tries to connect to it.  COM's Service Control Manager ( SCM ) will locate info found in the registry in terms of clsids, and marshalling support and start the exe server.  I'm also including a short client you can try.  When SCM starts it the program (CC.exe) will be started with the "-Embedding" or "/Embedding" command line parameters.  

Here is CC.bas

Code Select Expand


#Compile Exe              "CC.Exe"         'C:\Code\PwrBasic\PBWin90\CC\CC.Exe
#Dim                      All
#Register                 None
#Include                  "Win32Api.inc"
#Include                  "ObjBase.inc"
#Include                  "OAIdl.inc"
#Include                  "Registry.inc"

Declare Function CoRegisterClassObjectPtr Lib "OLE32.DLL" Alias "CoRegisterClassObject" _
( _
 Byref rclsid       As Guid, _
 Byval pUnknown     As Dword, _
 Byval dwClsContext As Dword, _
 Byval flags        As Dword, _
 Byval lpdwRegister As Dword _
) As Long                

                         'IClassFactory1 Interface Function Pointers
Declare Function          ptrCreateInstance (Byval this As Dword, Byval pUnk As Dword, Byref iid As Guid, Byref ppv As Dword) As Long
Declare Function          ptrLockServer     (Byval this As Dword, Byval blnLock As Long                                     ) As Long

                         'IX, IY Interface Function Pointer Prototypes
Declare Function          ptrQueryInterface (Byval this As Dword, Byref iid As Guid, Byref pUnknown As Dword                ) As Long
Declare Function          ptrAddRef         (Byval this As Dword                                                            ) As Dword
Declare Function          ptrRelease        (Byval this As Dword                                                            ) As Dword
Declare Function          ptrSetInt         (Byval this As Dword, Byval iVal As Long                                        ) As Long
Declare Function          ptrGetInt         (Byval this As Dword, Byref pVal As Long                                        ) As Long
Declare Function          ptrSetText        (Byval this As Dword, Byval strText As String                                   ) As Long
Declare Function          ptrGetText        (Byval this As Dword, Byref ptrText As String                                   ) As Long

$IID_IClassFactory        =  Guid$("{00000001-0000-0000-C000-000000000046}")
$IID_IUnknown             =  Guid$("{00000000-0000-0000-C000-000000000046}")
$CLSID_CC                 =  Guid$("{20000000-0000-0000-0000-000000000020}")
$IID_IX                   =  Guid$("{20000000-0000-0000-0000-000000000021}")
$IID_IY                   =  Guid$("{20000000-0000-0000-0000-000000000022}")
$LIBID_CCLibrary          =  Guid$("{20000000-0000-0000-0000-000000000023}")
$CLSID_Junk               =  Guid$("{12345678-9876-5432-1012-345678901234}")
$IID_Junk                 =  Guid$("{12345678-9876-5432-1012-345678901234}")

Type IXVtbl
 QueryInterface          As Dword Ptr
 AddRef                  As Dword Ptr
 Release                 As Dword Ptr
 SetXInt                 As Dword Ptr
 GetXInt                 As Dword Ptr
 SetXText                As Dword Ptr
 GetXText                As Dword Ptr
End Type

Type I_X
 lpIX                    As IXVtbl Ptr
End Type

Type IYVtbl
 QueryInterface          As Dword Ptr
 AddRef                  As Dword Ptr
 Release                 As Dword Ptr
 SetYInt                 As Dword Ptr
 GetYInt                 As Dword Ptr
 SetYText                As Dword Ptr
 GetYText                As Dword Ptr
End Type

Type I_Y
 lpIY                    As IYVtbl Ptr
End Type

Type CC
 lpIX                    As IXVtbl Ptr
 lpIY                    As IYVtbl Ptr
 m_iXInt                 As Long
 m_iYInt                 As Long
 m_XText                 As Dword Ptr
 m_YText                 As Dword Ptr
 m_cRef                  As Long
End Type

Type IClassFactoryVtbl
 QueryInterface          As Dword Ptr
 AddRef                  As Dword Ptr
 Release                 As Dword Ptr
 CreateInstance          As Dword Ptr
 LockServer              As Dword Ptr
End Type

Type IClassFactory1
 lpVtbl                  As IClassFactoryVtbl Ptr
End Type

Global g_szFriendlyName   As Asciiz*64
Global g_szVerIndProgID   As Asciiz*64
Global g_szProgID         As Asciiz*64
Global CCClassFactory     As IClassFactory1     'sizeof() =  4
Global IClassFactory_Vtbl As IClassFactoryVtbl  'sizeof() = 20
Global IX_Vtbl            As IXVtbl             'sizeof() = 28
Global IY_Vtbl            As IYVtbl             'sizeof() = 28
Global g_hModule          As Dword
Global g_lLocks           As Long


Sub CCLock()
 Print "  Entering CCLock()"
 Print "    g_lLocks = " g_lLocks
 Call InterlockedIncrement(g_lLocks)
 Print "    g_lLocks = " g_lLocks
 Print "  Leaving CCLock()"
End Sub


Sub CCUnLock()
 If g_lLocks > 0 Then
    Print "Entering CCUnLock()"
    Print "  g_lLocks = " g_lLocks
    Call InterlockedDecrement(g_lLocks)
    Print "  g_lLocks = " g_lLocks
    If g_lLocks=0 Then
       Call PostQuitMessage(0)
    End If  
 Print "Leaving CCUnLock()"
 End If  
End Sub


Function IX_QueryInterface(ByVal this As I_X Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
 @ppv=%NULL
 Select Case iid
   Case $IID_IUnknown
     Print "  Called IX_QueryInterface() For IID_IUnknown And this=" this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IX
     Print "  Called IX_QueryInterface() For IID_IX And this=" this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IY
     Print "  Called IX_QueryInterface() For IID_IY And this=" this
     Incr this
     @ppv=this
     Call IY_AddRef(this)
     Function=%S_OK
     Exit Function
   Case Else
     Print "Called IX_QueryInterface()"
 End Select

 Function=%E_NoInterface
End Function


Function IX_AddRef(ByVal this As I_X Ptr) As Long
 Local pCC As CC Ptr

 Print "Called IX_AddRef()"
 pCC=this
 Incr @pCC.m_cRef

 IX_AddRef=@pCC.m_cRef
End Function


Function IX_Release(ByVal this As I_X Ptr) As Long
 Local pCC As CC Ptr

 pCC=this
 Decr @pCC.m_cRef
 If @pCC.m_cRef=0 Then
    Call CoTaskMemFree(this)
    Call CCUnLock()
    Print "Called IX_Release() And CC Was Deleted!"
 Else
    Print "Called IX_Release()"
 End If

 Function=@pCC.m_cRef
End Function


Function SetXInt(ByVal this As I_X Ptr, Byval iXVal As Long) As Long
 Local pCC As CC Ptr

 Print "Called SetXInt(" & Trim$(Str$(iXVal)) & ")"
 pCC=this
 @pCC.m_iXInt=iXVal

 Function=%S_OK
End Function


Function GetXInt(ByVal this As I_X Ptr, Byref pXVal As Long) As Long
 Local pCC As CC Ptr

 pCC=this
 pXVal=@pCC.m_iXInt
 Print "Called GetXInt(" & Trim$(Str$(pXVal)) & ")"

 Function=%S_OK
End Function


Function SetXText(ByVal this As I_X Ptr, Byval strXText As String) As Long
 Local pCC As CC Ptr

 Print "Setting IXText To " & strXText
 pCC=this
 If SysReAllocString(@pCC.m_XText, Byval Strptr(strXText)) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
End Function


Function GetXText(ByVal this As I_X Ptr, Byref strXText As String) As Long
 Local pCC As CC Ptr

 pCC=this
 If SysReAllocString(strXText, Byval @pCC.m_XText) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
 Print "IX Text: " & strXText
End Function


Function IY_QueryInterface(ByVal this As I_Y Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
 @ppv=%NULL
 Select Case iid
   Case $IID_IUnknown
     Print "Called IY_QueryInterface() For IID_IUnknown"
     Decr this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IX
     Print "Called IY_QueryInterface() For IID_IX"
     Decr this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IY
     Print "Called IY_QueryInterface() For IID_IY"
     @ppv=this
     Call IY_AddRef(this)
     Function=%S_OK
     Exit Function
   Case Else
     Print "Called IY_QueryInterface()"
 End Select

 Function=%E_NoInterface
End Function


Function IY_AddRef(ByVal this As I_Y Ptr) As Long
 Local pCC As CC Ptr

 Print "Called IY_AddRef()"
 Decr this
 pCC=this
 Incr @pCC.m_cRef

 IY_AddRef=@pCC.m_cRef
End Function


Function IY_Release(ByVal this As I_Y Ptr) As Long
 Local pCC As CC Ptr

 Decr this
 pCC=this
 Decr @pCC.m_cRef
 If @pCC.m_cRef=0 Then
    Call CoTaskMemFree(this)
    Call CCUnLock()
    Print "Called IY_Release() And CB Was Deleted!"
 Else
    Print "Called IY_Release()"
 End If

 Function=@pCC.m_cRef
End Function


Function SetYInt(ByVal this As I_Y Ptr, Byval iYVal As Long) As Long
 Local pCC As CC Ptr

 Print "Called SetYInt(" & Trim$(Str$(iYVal)) & ")"
 Decr this
 pCC=this
 @pCC.m_iYInt=iYVal

 Function=%S_OK
End Function


Function GetYInt(ByVal this As I_Y Ptr, Byref pYVal As Long) As Long
 Local pCC As CC Ptr

 Decr this
 pCC=this
 pYVal=@pCC.m_iYInt
 Print "Called GetXInt(" & Trim$(Str$(pYVal)) & ")"

 Function=%S_OK
End Function


Function SetYText(ByVal this As I_Y Ptr, Byval strYText As String) Export As Long
 Local pCC As CC Ptr

 Print "Setting IYText To " & strYText
 Decr this
 pCC=this
 If SysReAllocString(@pCC.m_YText, Byval Strptr(strYText)) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
End Function


Function GetYText(ByVal this As I_Y Ptr, Byref strYText As String) Export As Long
 Local pCC As CC Ptr

 Decr this
 pCC=this
 If SysReAllocString(strYText, Byval @pCC.m_YText) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
 Print "IY Text: " & strYText
End Function


Function CCClassFactory_QueryInterface(ByVal this As IClassFactory1 Ptr, ByRef RefIID As Guid, ByVal pCF As Dword Ptr) As Long
 Print "Called CCClassFactory_QueryInterface()"
 If RefIID=$IID_IUnknown Or RefIID=$IID_IClassFactory Then
    Call CCClassFactory_AddRef(this)
    @pCF=this
    Print "  Leaving CCClassFactory_QueryInterface()"
    Function=%NOERROR
    Exit Function
 End If

 Function=%E_NoInterface
End Function


Function CCClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
 Print "Called CCClassFactory_AddRef()!"
 'Print "    Leaving CCClassFactory_AddRef()!"
 CCClassFactory_AddRef=10
End Function


Function CCClassFactory_Release(ByVal this As IClassFactory1 Ptr) As Long
 Print "Called CCClassFactory_Release()!"
 'Print "    this=" this
 'Print "  Leaving CCClassFactory_Release()!"
 CCClassFactory_Release=20
End Function


Function CCClassFactory_CreateInstance(ByVal this As IClassFactory1 Ptr, ByVal pUnknown As Dword, ByRef RefIID As Guid, ByVal ppv As Dword Ptr) As Long
 Local strIXStr, strIYStr As String
 Local pIX As I_X Ptr
 Local pCC As CC Ptr
 Local hr  As Long

 Print "Called CCClassFactory_CreateInstance()"
 @ppv=%NULL
 If pUnknown Then
    hr=%CLASS_E_NOAGGREGATION
    Exit Function
 Else
    If RefIID=$IID_IUnknown Or RefIID=$IID_IX Or RefIID=$IID_IY Then
       pCC=CoTaskMemAlloc(SizeOf(CC))
       If pCC Then
          Print "  pCC      ="pCC
          @pCC.lpIX=VarPtr(IX_Vtbl)
          @pCC.lpIY=VarPtr(IY_Vtbl)
          Print "  @pCC.lpIX=" @pCC.lpIX
          Print "  @pCC.lpIY=" @pCC.lpIY : Print
          Print " " Varptr(@pCC.lpIX), @pCC.lpIX
          Print " " Varptr(@pCC.lpIY), @pCC.lpIY  : Print
          strIXStr="Default IX Interface String"
          strIYStr="Default IY Interface String"
          strIXStr=UCode$(strIXStr)
          strIYStr=UCode$(strIYStr)
          @pCC.m_XText=SysAllocStringLen(Byval Strptr(strIXStr),Len(strIXStr)+1)
          @pCC.m_YText=SysAllocStringLen(Byval Strptr(strIYStr),Len(strIYStr)+1)
          @pCC.m_cRef=0
          pIX=pCC
          hr= IX_QueryInterface(pIX,RefIID,ppv)
          Print "  pCC  = " pCC
          Print "  pIX  = " pIX
          Print "  @ppv = " @ppv
          If SUCCEEDED(hr) Then
             Call CCClassFactory_AddRef(this)
             Call CCLock()
          Else
             Call CoTaskMemFree(pCC)
             CCClassFactory_CreateInstance=%E_FAIL
             Print : Print "CreateInstance Failed!"
             Exit Function
          End If
       Else
          hr=%E_OutOfMemory
          Exit Function
       End If
    Else  
       hr=%E_FAIL
       Exit Function
    End If
 End If  
 Print "Leaving CBClassFactory_CreateInstance()"

 CCClassFactory_CreateInstance=%S_Ok
End Function


Function CCClassFactory_LockServer(ByVal this As IClassFactory1 Ptr, Byval flock As Long) As Long
 Print "Called CCClassFactory_LockServer()"
 If flock Then
    Call CCLock()
 Else
    Call CCUnLock()
 End If

 CCClassFactory_LockServer=%NOERROR
End Function


Function ExeRegisterServer(hInstance As Long) As Long
 Local strAsciPath,strWideCharPath As String
 Local hr,iBytesReturned As Long
 Local szPath As Asciiz*256
 Local pTypeLib As ITypeLib
 
 Print "  Entering ExeRegisterServer()"
 If GetModuleFileName(hInstance, szPath, 256) Then
    Print "    szPath         = " szPath
    strAsciPath=szPath
    strWideCharPath=UCode$(strAsciPath & $Nul)
    hr=LoadTypeLibEx(Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
    If SUCCEEDED(hr) Then
       Print "    LoadTypeLib() Succeeded!"
       'Call pTypeLib.Release()
       Set pTypeLib = Nothing
       hr=RegisterServer(szPath, $CLSID_CC, $LIBID_CCLibrary, g_szFriendlyName, g_szVerIndProgID, g_szProgID)
    Else
       Local dwFlags As Dword
       Local szError As Asciiz*256
       Print "    LoadTypeLib() Failed!"
       iBytesReturned= _
       FormatMessage _
       ( _
         dwFlags, _
         Byval 0, _
         hr, _
         MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), _
         Byval Varptr(szError), _
         256, _
         Byval %NULL _
       )
       Print "    iBytesReturned = " iBytesReturned
       Print "szBuffer           = " szError
    End If
 End If
 Print "  Leaving ExeRegisterServer()"

 Function=hr
End Function


Function ExeUnregisterServer(hInstance As Long) As Long
 Print "  Entering ExeUnregisterServer()"
 Print "    Not Implemented Yet!"
 Print "  Leaving ExeUnregisterServer()"
End Function


Function blnRegistration(Byval hInstance As Long, Byval lpCmdLine As Asciiz Ptr, Byref regID As Dword) As Long
 Local hr As Long

 Print "Entering blnCmdLineProcessing()"
 If InStr(@lpCmdLine,"/r") Then
    Print "  Calling ExeRegisterServer()"
    Call ExeRegisterServer(hInstance)
    Print "Leaving blnCmdLineProcessing()"
    Print
    Function=%TRUE
    Exit Function
 End If
 If InStr(@lpCmdLine,"/u") Then
    Print "  Calling ExeUnregisterServer()"
    Call ExeUnregisterServer(hInstance)
    Print "Leaving blnCmdLineProcessing()"
    Print
    Function=%TRUE
    Exit Function
 End If
 Print "Leaving blnCmdLineProcessing()"
 Print

 Function=%FALSE
End Function


Function Initialize() As Long
 Local pClsFac As Dword Ptr
 Local hr As Long

 Print "Entering Initialize()"
 g_szFriendlyName                           = "Com Object CC"
 g_szProgID                                 = "ComObject.CC.1"
 g_szVerIndProgID                           = "ComObject.CC"
 IClassFactory_Vtbl.QueryInterface          = CodePtr(CCClassFactory_QueryInterface)
 IClassFactory_Vtbl.AddRef                  = CodePtr(CCClassFactory_AddRef)
 IClassFactory_Vtbl.Release                 = CodePtr(CCClassFactory_Release)
 IClassFactory_Vtbl.CreateInstance          = CodePtr(CCClassFactory_CreateInstance)
 IClassFactory_Vtbl.LockServer              = CodePtr(CCClassFactory_LockServer)
 CCClassFactory.lpVtbl                      = VarPtr(IClassFactory_Vtbl)
 Print "  IClassFactory_Vtbl.QueryInterface = " IClassFactory_Vtbl.QueryInterface
 Print "  IClassFactory_Vtbl.AddRef         = " IClassFactory_Vtbl.AddRef
 Print "  IClassFactory_Vtbl.Release        = " IClassFactory_Vtbl.Release
 Print "  IClassFactory_Vtbl.CreateInstance = " IClassFactory_Vtbl.CreateInstance
 Print "  IClassFactory_Vtbl.LockServer     = " IClassFactory_Vtbl.LockServer
 Print
 Print "  Varptr(CCClassFactory)            = " Varptr(CCClassFactory)
 Print "  Varptr(CCClassFactory.lpVtbl)     = " Varptr(CCClassFactory.lpVtbl)
 Print "  Varptr(IClassFactory_Vtbl)        = " Varptr(IClassFactory_Vtbl)
 Print "  CCClassFactory.lpVtbl             = " CCClassFactory.lpVtbl  
 IX_Vtbl.QueryInterface                     = CodePtr(IX_QueryInterface)
 IX_Vtbl.AddRef                             = CodePtr(IX_AddRef)
 IX_Vtbl.Release                            = CodePtr(IX_Release)
 IX_Vtbl.SetXInt                            = CodePtr(SetXInt)
 IX_Vtbl.GetXInt                            = CodePtr(GetXInt)
 IX_Vtbl.SetXText                           = CodePtr(SetXText)
 IX_Vtbl.GetXText                           = CodePtr(GetXText)
 IY_Vtbl.QueryInterface                     = CodePtr(IY_QueryInterface)
 IY_Vtbl.AddRef                             = CodePtr(IY_AddRef)
 IY_Vtbl.Release                            = CodePtr(IY_Release)
 IY_Vtbl.SetYInt                            = CodePtr(SetYInt)
 IY_Vtbl.GetYInt                            = CodePtr(GetYInt)
 IY_Vtbl.SetYText                           = CodePtr(SetYText)
 IY_Vtbl.GetYText                           = CodePtr(GetYText)
 'hr=CCClassFactory_QueryInterface(VarPtr(CCClassFactory), $IID_IClassFactory, Varptr(CCClassFactory))
 hr=CCClassFactory_QueryInterface(VarPtr(CCClassFactory), $IID_IClassFactory, Varptr(pClsFac))
 If FAILED(hr) Then
    CCClassFactory.lpVTbl=0
    hr=%CLASS_E_CLASSNOTAVAILABLE
    Exit Function
 Else
    'Print "  VarPtr(CCClassFactory) = " Varptr(CCClassFactory)
    Print "  pClsFac = " pClsFac
 End If
 Print "Leaving Initialize()" : Print

 Function=hr
End Function


Sub DumpClassObject()
 Local pClassFactory As IClassFactory1 Ptr
 Local pVtbl,Vtbl As Dword Ptr
 Local pUnk As Dword
 Register i As Long
 Local hr As Long
 
 Print
 Print "Entering DumpClassObject()"
 pClassFactory=Varptr(CCClassFactory)
 pVtbl = pClassFactory
 Print "  pClassFactory         = " pClassFactory
 Print "  @pClassFactory        = " @pVtbl
 Print "  @pClassFactory.lpVtbl = " @pClassFactory.lpVtbl
 Vtbl=@pClassFactory.lpVtbl
 Print
 Print "pClassFactory  Varptr(@Vtbl[i]   @Vtbl[i]    Function Call Through Fn Ptr"
 Print "======================================================================================="
 Print pClassFactory, Varptr(@Vtbl[0]) Tab(33) @Vtbl[0] "    ";
 Call Dword @Vtbl[0] Using ptrQueryInterface(Varptr(@pVtbl[0]), $IID_Junk, pUnk) To hr           'QueryInterface()
 Print pClassFactory, Varptr(@Vtbl[1]) Tab(33) @Vtbl[1] "    ";
 Call Dword @Vtbl[1] Using ptrAddRef(Varptr(@pVtbl[0])) To hr                                    'AddRef()
 Print pClassFactory, Varptr(@Vtbl[2]) Tab(33) @Vtbl[2] "    ";
 Call Dword @Vtbl[2] Using ptrRelease(Varptr(@pVtbl[0])) To hr                                   'Release()
 Print pClassFactory, Varptr(@Vtbl[3]) Tab(33) @Vtbl[3] "    ";
 Call Dword @Vtbl[3] Using ptrCreateInstance(Varptr(@pVtbl[0]), %NULL, $CLSID_Junk, pUnk) To hr  'CreateInstance()
 Print pClassFactory, Varptr(@Vtbl[4]) Tab(33) @Vtbl[4] "    ";
 Call Dword @Vtbl[4] Using ptrLockServer(Varptr(@pVtbl[0]), %FALSE) To hr                        'LockServer()
 Print
 Print "Leaving DumpClassObject()" : Print
End Sub


Sub DumpCustomInterfaces()
 Local pVTbl,VTbl As Dword Ptr
 Local strBStr As String
 Local iReturn As Long
 Local pUnk As Dword
 Register i As Long
 Local hr As Long
 
 Print "Entering DumpCustomInterfaces()" : Print
 hr=CCClassFactory_CreateInstance(Varptr(CCClassFactory), pUnk, $IID_IX, Varptr(pVTbl))
 Print "VarPtr(pVTbl) = " Varptr(pVTbl)
 Print "pVTbl         = " pVTbl
 Print
 Print "Varptr(@pVTbl[i])  Varptr(@VTbl[i])  @VTbl[i]   Function Call With Call Dword"
 Print "=============================================================================="
 For i=0 To 1
   VTbl=@pVTbl[i]                                                                          'Call...
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[0]) Tab(37)@VTbl[0] "   ";
   Call DWord @VTbl[0] Using ptrQueryInterface(Varptr(@pVTbl[i]), $IID_Junk, pUnk) To hr   'QueryInterface()
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[1]) Tab(37)@VTbl[1] "   ";
   Call DWord @VTbl[1] Using ptrAddRef(Varptr(@pVTbl[i])) To hr                            'AddRef()
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[2]) Tab(37)@VTbl[2] "   ";
   Call DWord @VTbl[2] Using ptrRelease(Varptr(@pVTbl[i])) To hr                           'Release()
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[3]) Tab(37)@VTbl[3] "   ";
   Call DWord @VTbl[3] Using ptrSetInt(Varptr(@pVTbl[i]),i) To hr                          'SetXInt() / SetYInt()
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[4]) Tab(37)@VTbl[4] "   ";
   Call DWord @VTbl[4] Using ptrGetInt(Varptr(@pVTbl[i]),iReturn) To hr                    'GetXInt() / GetYInt()
   If i Then
      strBStr="New IY String"
   Else
      strBStr="New IX String"
   End If
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[5]) Tab(37)@VTbl[5] "   ";
   Call DWord @VTbl[5] Using ptrSetText(Varptr(@pVTbl[i]),strBStr) To hr                   'SetXText() / SetYText()
   Print LTrim$(Str$(Varptr(@pVTbl[i]))) Tab(19)Varptr(@VTbl[6]) Tab(37)@VTbl[6] "   ";
   Call DWord @VTbl[6] Using ptrGetText(Varptr(@pVTbl[i]),strBStr) To hr                   'GetXText() / GetYText()
   Print
 Next i
 VTbl=@pVTbl[0]
 Call DWord @VTbl[2] Using ptrRelease(Varptr(@pVTbl[0])) To hr
 Print : Print "Leaving DumpCustomInterfaces()" : Print
End Sub


Function WinMain(ByVal hInstance As Long, ByVal hPrev As Long, ByVal lpCmdLine As Asciiz Ptr, ByVal iShow As Long) As Long
 Local regID As Dword
 Local Msg As tagMsg
 Local hr As Long
   
 If SUCCEEDED(Initialize()) Then
    If blnRegistration(hInstance, lpCmdLine, regID) Then
       Function=0
       Exit Function
    End If
 Else
    Function = -1
    Exit Function
 End If
 If InStr(@lpCmdLine,"/Embedding") Or InStr(@lpCmdLine,"-Embedding") Then
    Print "  Was Loaded By COM!"
    hr=CoRegisterClassObjectPtr($CLSID_CC, Varptr(CCClassFactory), %CLSCTX_LOCAL_SERVER, %REGCLS_MULTIPLEUSE, regID)
    If SUCCEEDED(hr) Then
       Print "  CoRegisterClassObject() Succeeded!"
       While GetMessage(Msg,%NULL,0,0)
         Call TranslateMessage(Msg)
         Call DispatchMessage(Msg)
       Wend
       CoRevokeClassObject(regID)
    Else
       Print "CoRegisterClassObject() Failed!"
       Local dwFlags As Dword
       Local szError As Asciiz*512
       dwFlags=%FORMAT_MESSAGE_FROM_SYSTEM
       FormatMessage(dwFlags, Byval 0, hr, MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), Byval Varptr(szError), 512, Byval %NULL)
       Print "szBuffer = " szError
   End If
 Else
   Call DumpClassObject()
   Call DumpCustomInterfaces()
 End If  
 Waitkey$

 WinMain=0
End Function


I just made a minor change in the above code from the way I originally posted it several hours ago.  There is a problem with a parameter in CoRegisterClassObject() and Jose recommended I use an Alias clause to create an alternate function that calls CoRegisterClassObject.  I've now incorporated that into this program and tested it and it works fine.  Thanks Jose for the suggestion and the alternate Declare!

[Frederick J. Harris]

Here is Registry.inc which is referenced in the includes at top of CC.bas...

Code Select Expand


'Registry.inc

Function SetKeyAndValue(Byref szKey As Asciiz, Byref szSubKey As Asciiz, Byref szValue As Asciiz) As Long
  Local szKeyBuf As Asciiz*1024
  Local lResult As Long
  Local hKey As Dword

  If szKey<>"" Then
     szKeyBuf=szKey
     If szSubKey<>"" Then
        szKeyBuf=szKeyBuf+"\"+szSubKey
     End If
     lResult=RegCreateKeyEx(%HKEY_CLASSES_ROOT,szKeyBuf,0,Byval %NULL,%REG_OPTION_NON_VOLATILE,%KEY_ALL_ACCESS,Byval %NULL,hKey,%NULL)
     If lResult<>%ERROR_SUCCESS Then
        Function=%FALSE
        Exit Function
     End If
     If szValue<>"" Then
        Call RegSetValueEx(hKey,Byval %NULL, Byval 0, %REG_SZ, szValue, Len(szValue)+1)
     End If
     Call RegCloseKey(hKey)
  Else
     Function=%FALSE
     Exit Function
  End If

  Function=%TRUE
End Function


Function RecursiveDeleteKey(Byval hKeyParent As Dword, Byref lpszKeyChild As Asciiz) As Long
  Local dwSize,hKeyChild As Dword
  Local szBuffer As Asciiz*256
  Local time As FILETIME
  Local lRes As Long

  dwSize=256
  lRes=RegOpenKeyEx(hKeyParent,lpszKeyChild,0,%KEY_ALL_ACCESS,hKeyChild)
  If lRes<>%ERROR_SUCCESS Then
     Function=lRes
     Exit Function
  End If
  While(RegEnumKeyEx(hKeyChild,0,szBuffer,dwSize,0,Byval 0,Byval 0,time)=%S_OK)
    lRes=RecursiveDeleteKey(hKeyChild,szBuffer)  'Delete the decendents of this child.
    If lRes<>%ERROR_SUCCESS Then
       Call RegCloseKey(hKeyChild)
       Function=lRes
       Exit Function
    End If
    dwSize=256
  Loop
  Call RegCloseKey(hKeyChild)

  Function=RegDeleteKey(hKeyParent,lpszKeyChild)  'Delete this child.
End Function


Function RegisterServer(Byref szExeName As Asciiz, Byref ClassId As Guid, Byref LibId As Guid, Byref szFriendlyName As Asciiz, Byref szVerIndProgID As Asciiz, Byref szProgID As Asciiz) As Long
  Local szClsid As Asciiz*48, szLibid As Asciiz*48, szKey As Asciiz*64
  Local iReturn As Long

  Print "    Entering RegisterServer()"
  Print "      szExeName  = " szExeName
  szClsid=GuidTxt$(ClassId)
  szLibid=GuidTxt$(LibId)
  If szClsid <> "" And szLibid <> "" Then
     Print "      szClsid    = " szClsid
     Print "      szLibid    = " szLibid
     szKey="CLSID\" & szClsid
     Print "      szKey      = " szKey
     If IsFalse(SetKeyAndValue(szKey, Byval %NULL, szFriendlyName)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "LocalServer32", szExeName)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "ProgID", szProgID)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "TypeLib", szLibid)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szVerIndProgID,Byval %NULL, szFriendlyName)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szVerIndProgID, "CLSID", szClsid)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szVerIndProgID, "CurVer", szProgID)) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szProgID, Byval %NULL, "A COM Object Of Class C")) Then
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szProgID, "CLSID", szClsid)) Then
        Function=%E_FAIL : Exit Function
     End If
     Function=%S_OK
     Exit Function
  Else
     Function=%E_FAIL
     Exit Function
  End If
  Print "    Leaving RegisterServer()"
End Function


[Frederick J. Harris]

Here is the CC.idl file I compiled with midl.exe.  The purpose of the midl (Microsoft Interface Definition Language) is to provide a language neutral (however, it looks suspiciously like C++) way of describing interfaces.  The key to everything I've done in this code is the 'oleautomation' attribute attached to the IX and IY interfaces.  If this attribute is assigned to a coclass ( COM class ), when RegisterTypeLibEx() is called, the IX and IY interface keys created will contain sub keys pointing to the OleAuto32.dll file which is a core COM System dll that knows how to Marshall automation compatible interface function parameters between processes.

Code Select Expand


import "oaidl.idl";

[object, uuid(20000000-0000-0000-0000-000000000021), oleautomation, helpstring("The IX Interface Functions")] //IX
interface IX : IUnknown
{
HRESULT SetXInt([in] int iXVal);
HRESULT GetXInt([out, retval] int* pInt);
HRESULT SetXText([in] BSTR strText);
HRESULT GetXText([out, retval] BSTR* strText);
};


[object, uuid(20000000-0000-0000-0000-000000000022), oleautomation, helpstring("The IY Interface Functions")] //IY
interface IY : IUnknown
{
HRESULT SetYInt([in] int iYVal);
HRESULT GetYInt([out, retval] int* pInt);
HRESULT SetYText([in] BSTR strText);
HRESULT GetYText([out, retval] BSTR* strText);
};

[uuid(20000000-0000-0000-0000-000000000023), version(1.0), helpstring("Class CC With TypeLib")]
library CCLibrary
{
importlib("stdole32.tlb");
[uuid(20000000-0000-0000-0000-000000000020)]
coclass CC
{
 [default] interface IX;
           interface IY;
};
};


[Frederick J. Harris]

Here is a test client program - CCClient1.bas.  After the code are the outputs from both the client & server.  Since I left the console on, you'll have two console windows open - one from the client & one from the server.  You need to hit [ENTER] to dismiss both.  Check out your task manager to make sure CC.exe terminated...

Code Select Expand


#Compile Exe
#Dim All

$CLSID_CC = GUID$("{20000000-0000-0000-0000-000000000020}")
$IID_IX   = GUID$("{20000000-0000-0000-0000-000000000021}")
$IID_IY   = GUID$("{20000000-0000-0000-0000-000000000022}")

Interface IX $IID_IX : Inherit IAutomation
  Method SetXInt(Byval iXVal As Long)
  Method GetXInt() As Long
  Method SetXText(Byval strText As String)
  Method GetXText() As String
End Interface

Interface IY $IID_IY : Inherit IAutomation
  Method SetYInt(Byval iYVal As Long)
  Method GetYInt() As Long
  Method SetYText(Byval strText As String)
  Method GetYText() As String
End Interface

Function PBMain() As Long
  Local strXText, strYText As String
  Local hr,iXInt,iYInt As Long
  Local pIX As IX
  Local pIY As IY

  pIX=AnyCom("ComObject.CC")
  pIX.SetXInt(5)
  pIX.SetXText("Here Is A New IX Interface BSTR!")
  iXInt=pIX.GetXInt()
  strXText=pIX.GetXText()
  Print "iXInt    = " iXInt
  Print "strXText = " strXText
  pIY=pIX
  Set pIX = Nothing
  pIY.SetYInt(10)
  pIY.SetYText("Here Is A New IY Interface BSTR!")
  iYInt=pIY.GetYInt()
  strYText=pIY.GetYText()
  Print "iYInt    = " iYInt
  Print "strYText = " strYText
  Set pIY = Nothing
  Waitkey$

  PBMain=0
End Function

'Client Output
'==========================================
'iXInt    =  5
'strXText = Here Is A New IX Interface BSTR!
'iYInt    =  10
'strYText = Here Is A New IY Interface BSTR!
'==========================================
'End Client Output



'Server CC.Exe Output
'=============================================
'Entering Initialize()
'  IClassFactory_Vtbl.QueryInterface =  4216909
'  IClassFactory_Vtbl.AddRef         =  4217109
'  IClassFactory_Vtbl.Release        =  4217194
'  IClassFactory_Vtbl.CreateInstance =  4217287
'  IClassFactory_Vtbl.LockServer     =  4218359
'
'  Varptr(CCClassFactory)            =  4249588
'  Varptr(CCClassFactory.lpVtbl)     =  4249588
'  Varptr(IClassFactory_Vtbl)        =  4249592
'  CCClassFactory.lpVtbl             =  4249592
'  Called CCClassFactory_QueryInterface()
'  Called CCClassFactory_AddRef()!
'  Leaving CCClassFactory_QueryInterface()
'  pClsFac =  4249588
'Leaving Initialize()
'
'Entering blnCmdLineProcessing()
'Leaving blnCmdLineProcessing()
'
'Was Loaded By COM!
'Called CCClassFactory_AddRef()!
'CoRegisterClassObject() Succeeded!
'Called CCClassFactory_AddRef()!
'Called CCClassFactory_QueryInterface()
'Called CCClassFactory_AddRef()!
' Leaving CCClassFactory_QueryInterface()
'Called CCClassFactory_Release()!
'Called CCClassFactory_CreateInstance()
'  pCC      = 14123696
'  @pCC.lpIX= 4249612
'  @pCC.lpIY= 4249640
'
'  14123696     4249612
'  14123700     4249640
'
'  Called IX_QueryInterface() For IID_IUnknown And this= 14123696
'  Called IX_AddRef()
'  pCC  =  14123696
'  pIX  =  14123696
'  @ppv =  14123696
'  Called CCClassFactory_AddRef()!
'  Entering CCLock()
'    g_lLocks =  0
'    g_lLocks =  1
'  Leaving CCLock()
'Leaving CBClassFactory_CreateInstance()
'
'Called IX_AddRef()
'Called IX_QueryInterface()
'Called IX_QueryInterface()
'Called IX_QueryInterface() For IID_IUnknown And this= 14123696
'Called IX_AddRef()
'Called IX_AddRef()
'Called IX_QueryInterface()
'Called IX_QueryInterface()
'Called IX_Release()
'Called IX_QueryInterface() For IID_IX And this= 14123696
'Called IX_AddRef()
'Called IX_AddRef()
'Called IX_Release()
'Called IX_Release()
'Called CCClassFactory_Release()!
'Called IX_QueryInterface()
'Called IX_QueryInterface() For IID_IX And this= 14123696
'Called IX_AddRef()
'Called SetXInt(5)
'Setting IXText To Here Is A New IX Interface BSTR!
'Called GetXInt(5)
'IX Text: Here Is A New IX Interface BSTR!
'Called IX_QueryInterface() For IID_IY And this= 14123696
'Called IY_AddRef()
'Called IX_AddRef()
'Called IY_QueryInterface()
'Called IX_QueryInterface() For IID_IY And this= 14123696
'Called IY_AddRef()
'Called SetYInt(10)
'Setting IYText To Here Is A New IY Interface BSTR!
'Called GetXInt(10)
'IY Text: Here Is A New IY Interface BSTR!
'Called IX_Release()
'Called IX_Release()
'Called IX_Release()
'Called IY_Release()
'Called IY_Release()
'Called IX_Release()
'Entering CCUnLock()
'  g_lLocks =  1
'  g_lLocks =  0
'Leaving CCUnLock()
'Called IX_Release() And CC Was Deleted!
'Called CCClassFactory_QueryInterface()
'Called CCClassFactory_QueryInterface()
'Called CCClassFactory_AddRef()!
'Leaving CCClassFactory_QueryInterface()
'Called CCClassFactory_Release()!
'Called CCClassFactory_Release()!
'======================================================
'End CC.Exe Server Output


[Frederick J. Harris]

I'll have to see if I can include the CC.tlb file so you can use PBTyp to embed it into your CC.exe executable.  On the other hand, I'd just about be willing to bet you've got an midl.exe somewhere on your computer - perhaps unbeknownst to you!  Do a search once and see!  I did that once and came up with about a dozen!  But then I've a lot of C/C++ tools.  The type lib is created with a command line like so...

midl CC.idl

That will create about a half dozen files and among them will be CC.tlb.  That is compiled into the CC.exe you can make with the above code like so...

C:\........CC>PBTyp.exe CC.exe CC.rc

here is the CC.rc file...

Code Select Expand


//CC.rc
1  typelib CC.TLB
//End CC.rc


If you're thinking there's not too much to that you are right!  Here is the output from PBTyp...

'C:\Code\PwrBasic\PBCC50\CC>PBTyp CC.Exe CC.rc

'PowerBASIC PBTYP TypeLib Embedder - Rev 1.0
'Copyright (c) 2007 PowerBASIC Inc.

'Module:   CC
'Target:   CC.EXE
'TypeLib:  CC.TLB
'Resource: CC.RC

[Frederick J. Harris]

Finally, if you don't feel like assembling all this, here is the output from running CC.exe with no command line parameters.  Actually, you should be able to run CC.bas as is without dealing with PBTyp, CC.tlb, CC.rc and so on to get this output.  You just won't be able to run it as an external COM exe server....

Code Select Expand


#if 0
Entering Initialize()
 IClassFactory_Vtbl.QueryInterface =  4216909
 IClassFactory_Vtbl.AddRef         =  4217109
 IClassFactory_Vtbl.Release        =  4217194
 IClassFactory_Vtbl.CreateInstance =  4217287
 IClassFactory_Vtbl.LockServer     =  4218359

 Varptr(CCClassFactory)            =  4249588
 Varptr(CCClassFactory.lpVtbl)     =  4249588
 Varptr(IClassFactory_Vtbl)        =  4249592
 CCClassFactory.lpVtbl             =  4249592
 Called CCClassFactory_QueryInterface()
 Called CCClassFactory_AddRef()!
 Leaving CCClassFactory_QueryInterface()
 pClsFac =  4249588
Leaving Initialize()


Entering blnCmdLineProcessing()
Leaving blnCmdLineProcessing()


Entering DumpClassObject()
 pClassFactory         =  4249588
 @pClassFactory        =  4249592
 @pClassFactory.lpVtbl =  4249592

 pClassFactory  Varptr(@Vtbl[i]   @Vtbl[i]    Function Call Through Fn Ptr
 =======================================================================================
  4249588       4249592           4216909     Called CCClassFactory_QueryInterface()
  4249588       4249596           4217109     Called CCClassFactory_AddRef()!
  4249588       4249600           4217194     Called CCClassFactory_Release()!
  4249588       4249604           4217287     Called CCClassFactory_CreateInstance()
  4249588       4249608           4218359     Called CCClassFactory_LockServer()

Leaving DumpClassObject()

Entering DumpCustomInterfaces()
 Called CCClassFactory_CreateInstance()
   pCC      = 1279816
   @pCC.lpIX= 4249612
   @pCC.lpIY= 4249640

   1279816      4249612
   1279820      4249640

   Called IX_QueryInterface() For IID_IX And this= 1279816
   Called IX_AddRef()
   pCC  =  1279816
   pIX  =  1279816
   @ppv =  1279816
   Called CCClassFactory_AddRef()!
   Entering CCLock()
     g_lLocks =  0
     g_lLocks =  1
   Leaving CCLock()
 Leaving CBClassFactory_CreateInstance()

 VarPtr(pVTbl) =  1244064
 pVTbl         =  1279816

 Varptr(@pVTbl[i])  Varptr(@VTbl[i])  @VTbl[i]   Function Call With Call Dword
 ==============================================================================
 1279816            4249612           4214242    Called IX_QueryInterface()
 1279816            4249616           4214687    Called IX_AddRef()
 1279816            4249620           4214796    Called IX_Release()
 1279816            4249624           4214964    Called SetXInt(0)
 1279816            4249628           4215109    Called GetXInt(0)
 1279816            4249632           4215262    Setting IXText To New IX String
 1279816            4249636           4215426    IX Text: New IX String

 1279820            4249640           4215581    Called IY_QueryInterface()
 1279820            4249644           4215991    Called IY_AddRef()
 1279820            4249648           4216104    Called IY_Release()
 1279820            4249652           4216276    Called SetYInt(1)
 1279820            4249656           4216425    Called GetXInt(1)
 1279820            4249660           4216582    Setting IYText To New IY String
 1279820            4249664           4216750    IY Text: New IY String

 Entering CCUnLock()
   g_lLocks =  1
   g_lLocks =  0
 Leaving CCUnLock()

 Called IX_Release() And CC Was Deleted!
Leaving DumpCustomInterfaces()
#endif


[Frederick J. Harris]

One really cool thing I discovered accidentally concerns the addresses of everything.  Note the globals at the top of the program.  Just by accident I have all the Class Factory, Class Factory VTables, IX/IY Interfaces and VTables declared sequentially one right after another.  They start at 4249588.  Note the addresses of all the interfaces and VTables.  They are sequential in one small block of memory of about 80 bytes!  Pretty neat!

[Frederick J. Harris]

Attached is a zip file with all the code, exes, tlbs, etc.  Let me know if something doesn't work.

[Frederick J. Harris]

I see there have been two downloads of the zip file I provided.  I just made a slight change to the critical CoRegisterClassObject() function in WinMain() so that Jose's includes don't need changed to compile the program.  Just wanted to provide a 'heads up' on that. Tomorrow I'll update the zip.

This is pretty much a 'work in progress', so I'll add additional content as I get it done.  I already have a C and A C++ implementation of this code.  The C++ implementation is a GUI program, and that was challenging to create to say the least.  Next I'll see if I can convert that to PowerBASIC.  Also, I've got VB6 and .NET client code working, so I'll try to post that too eventually.

[Petr Schreiber]

Thanks Frederick,

first it GPFed for me, but this was because I forgot to register it.

So after using this first:

CC.exe /r

it worked great.

Thanks for sharing, I am looking forward to your next experiments.


Petr

[Frederick J. Harris]

Work In Progress - GUI Version...

Code Select Expand


'CC.bas
#Compile Exe              "CC.Exe"         'C:\Code\PwrBasic\PBWin90\CC\CC.Exe
#Dim                      All
#Register                 None
#Include                  "Win32Api.inc"
#Include                  "ObjBase.inc"
#Include                  "OAIdl.inc"
#Include                  "Registry.inc"
#Include                  "CC.inc"
#Include                  "Main.inc"

Function fnWndProc_OnCreate(wea As WndEventArgs) As Long
 Local pCreateStruct As CREATESTRUCT Ptr
 Local lpCmdLine As Asciiz Ptr
 Local hCtl,pUnk As Dword
 Local Vtbl As Dword Ptr
 Local hr As Long

 Print "  Entering fnWndProc_OnCreate()"
 pCreateStruct=wea.lParam
 wea.hInst=@pCreateStruct.hInstance
 lpCmdLine=@pCreateStruct.lpCreateParams
 Print "    lpCmdLine       = " lpCmdLine
 Print "    @lpCmdLine      = " @lpCmdLine
 Print "    Len(@lpCmdLine) = " Len(@lpCmdLine)
 If Len(@lpCmdLine)=0 Then
    hr=CCClassFactory_CreateInstance(Varptr(CCClassFactory), pUnk, $IID_IX, Varptr(pIX))
    Print "    pIX          = " pIX
    Print "    @pIX         = " @pIX
    Vtbl=@pIX
    Print "    Vtbl         = " Vtbl
    If FAILED(hr) Then
       Function=-1 : Exit Function
    End If
    Call Dword @Vtbl[0] Using ptrQueryInterface(pIX, $IID_IY, pIY) To hr
    If SUCCEEDED(hr) Then
       Print "    pIX->QueryInterface(pIY) Succeeded!"
    Else
       Print "    pIX->QueryInterface(pIY) Failed!"
    End If
    Print "    pIY  = " pIY
    Print "    @pIY = " @pIY
    hCtl=CreateWindowEx(0,"static","The IX Interface",%WS_CHILD Or %WS_VISIBLE,215,5,120,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Set X Int",%WS_CHILD Or %WS_VISIBLE,10,35,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,35,40,22,Wea.hWnd,%EDIT_SET_X_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Set X Int",%WS_CHILD Or %WS_VISIBLE,160,35,75,22,Wea.hWnd,%BTN_SET_X_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Get X Int",%WS_CHILD Or %WS_VISIBLE,280,35,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,380,35,40,22,Wea.hWnd,%EDIT_GET_X_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Get X Int",%WS_CHILD Or %WS_VISIBLE,440,35,75,22,Wea.hWnd,%BTN_GET_X_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Set X Text",%WS_CHILD Or %WS_VISIBLE,10,75,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,75,320,22,Wea.hWnd,%EDIT_SET_X_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Set X Text",%WS_CHILD Or %WS_VISIBLE,440,75,75,22,Wea.hWnd,%BTN_SET_X_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Get X Text",%WS_CHILD Or %WS_VISIBLE,10,115,110,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,115,320,22,Wea.hWnd,%EDIT_GET_X_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Get X Text",%WS_CHILD Or %WS_VISIBLE,440,115,75,22,Wea.hWnd,%BTN_GET_X_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","The IY Interface",%WS_CHILD Or %WS_VISIBLE,215,170,120,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Set Y Int",%WS_CHILD Or %WS_VISIBLE,10,195,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,195,40,22,Wea.hWnd,%EDIT_SET_Y_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Set Y Int",%WS_CHILD Or %WS_VISIBLE,160,195,75,22,Wea.hWnd,%BTN_SET_Y_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Get Y Int",%WS_CHILD Or %WS_VISIBLE,280,195,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,380,195,40,22,Wea.hWnd,%EDIT_GET_Y_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Get Y Int",%WS_CHILD Or %WS_VISIBLE,440,195,75,22,Wea.hWnd,%BTN_GET_Y_INT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Set Y Text",%WS_CHILD Or %WS_VISIBLE,10,235,80,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,235,320,22,Wea.hWnd,%EDIT_SET_Y_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Set Y Text",%WS_CHILD Or %WS_VISIBLE,440,235,75,22,Wea.hWnd,%BTN_SET_Y_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"static","Get Y Text",%WS_CHILD Or %WS_VISIBLE,10,265,110,20,Wea.hWnd,-1,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(%WS_EX_CLIENTEDGE,"edit","",%WS_CHILD Or %WS_VISIBLE,100,265,320,22,Wea.hWnd,%EDIT_GET_Y_TEXT,Wea.hInst,Byval 0)
    hCtl=CreateWindowEx(0,"button","Get Y Text",%WS_CHILD Or %WS_VISIBLE,440,265,75,22,Wea.hWnd,%BTN_GET_Y_TEXT,Wea.hInst,Byval 0)
    Call ShowWindow(Wea.hWnd, %SW_SHOWNORMAL)
 End If
 Print "  Leaving fnWndProc_OnCreate()"

 fnWndProc_OnCreate=0
End Function


Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
 Local szBuffer As Asciiz*128
 Local strBuffer As String
 Local Vtbl As Dword Ptr
 Local x,y As Long
 
 Vtbl=@pIX
 Select Case As Long Lowrd(Wea.wParam)
   Case %BTN_SET_X_INT
     Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_X_INT),szBuffer,16)
     x=Val(szBuffer)
     Call Dword @Vtbl[3] Using ptrSetInt(pIX,x)
   Case %BTN_GET_X_INT
     Call Dword @Vtbl[4] Using ptrGetInt(pIX,x)
     szBuffer=Str$(x)
     Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_X_INT),szBuffer)  
   Case %BTN_SET_X_TEXT
     Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_X_TEXT),szBuffer,128)
     strBuffer=szBuffer
     strBuffer=UCode$(strBuffer)
     Call Dword @Vtbl[5] Using ptrSetText(pIX, Byval strBuffer)
   Case %BTN_GET_X_TEXT
     Call Dword @Vtbl[6] Using ptrGetText(pIX, Byref strBuffer)
     strBuffer=ACode$(strBuffer)
     Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_X_TEXT),Byval Strptr(strBuffer))
   Case %BTN_SET_Y_INT
     Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_Y_INT),szBuffer,16)
     y=Val(szBuffer)
     Call Dword @Vtbl[3] Using ptrSetInt(pIY,y)
   Case %BTN_GET_Y_INT
     Call Dword @Vtbl[4] Using ptrGetInt(pIY,y)
     szBuffer=Str$(y)
     Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_Y_INT),szBuffer)  
   Case %BTN_SET_Y_TEXT
     Call GetWindowText(GetDlgItem(Wea.hWnd,%EDIT_SET_Y_TEXT),szBuffer,128)
     strBuffer=szBuffer
     strBuffer=UCode$(strBuffer)
     Call Dword @Vtbl[5] Using ptrSetText(pIY, Byval strBuffer)
   Case %BTN_GET_Y_TEXT
     Call Dword @Vtbl[6] Using ptrGetText(pIY, Byref strBuffer)
     strBuffer=ACode$(strBuffer)
     Call SetWindowText(GetDlgItem(Wea.hWnd,%EDIT_GET_Y_TEXT),Byval Strptr(strBuffer))          
 End Select

 fnWndProc_OnCommand=0
End Function


Function fnWndProc_OnPaint(Wea As WndEventArgs) As Long        
 Local ps As PAINTSTRUCT
 Local hDC As Dword

 hDC=BeginPaint(Wea.hWnd, ps)
 MoveToEx(hDC, 20, 155, Byval 0)
 LineTo(hDC, 510, 155)
 EndPaint(Wea.hWnd, ps)

 fnWndProc_OnPaint=0
End Function


Function fnWndProc_OnClose(Wea As WndEventArgs) As Long
 Local Vtbl As Dword Ptr
 Local hr As Long
 
 Print "  Entering fnWndProc_OnClose()"
 Call DestroyWindow(Wea.hWnd)
 Print "    pIX  = " pIX
 Print "    @pIX = " @pIY
 Vtbl=@pIX
 Call DWord @VTbl[2] Using ptrRelease(pIX) To hr
 Print "    pIY  = " pIY
 Print "    @pIY = " @pIY
 Vtbl=@pIY
 Call DWord @VTbl[2] Using ptrRelease(pIY) To hr
 Print "  Leaving fnWndProc_OnClose()"
 
 fnWndProc_OnClose=0
End Function


Function fnWndProc(ByVal hWnd As Long,ByVal wMsg As Long,ByVal wParam As Long,ByVal lParam As Long) As Long
 Static wea As WndEventArgs
 Register iReturn As Long
 Register i As Long

 For i=0 To 3
   If wMsg=MsgHdlr(i).wMessage Then
      wea.hWnd=hWnd: wea.wParam=wParam: wea.lParam=lParam
      Call Dword MsgHdlr(i).dwFnPtr Using FnPtr(wea) To iReturn
      fnWndProc=iReturn
      Exit Function
   End If
 Next i

 fnWndProc=DefWindowProc(hWnd,wMsg,wParam,lParam)
End Function


Sub AttachMessageHandlers()
 ReDim MsgHdlr(3) As MessageHandler  'Associate Windows Message With Message Handlers
 MsgHdlr(0).wMessage=%WM_CREATE   :   MsgHdlr(0).dwFnPtr=CodePtr(fnWndProc_OnCreate)
 MsgHdlr(1).wMessage=%WM_COMMAND  :   MsgHdlr(1).dwFnPtr=CodePtr(fnWndProc_OnCommand)
 MsgHdlr(2).wMessage=%WM_PAINT    :   MsgHdlr(2).dwFnPtr=CodePtr(fnWndProc_OnPaint)
 MsgHdlr(3).wMessage=%WM_CLOSE    :   MsgHdlr(3).dwFnPtr=CodePtr(fnWndProc_OnClose)
End Sub


Sub Terminate(Byval lpCmdLine As Asciiz Ptr, Byref regID As Dword)
 If InStr(@lpCmdLine,"/Embedding") Or InStr(@lpCmdLine,"-Embedding") Then
    Call CoRevokeClassObject(regID)
 End If
End Sub


Function WinMain(ByVal hInstance As Long, ByVal hPrev As Long, ByVal lpCmdLine As Asciiz Ptr, ByVal iShow As Long) As Long
 Local szAppName As Asciiz*8
 Local wc As WndClassEx
 Local regID As Dword
 Local Msg As tagMsg
 Local hr As Long
 
 Print "Entering WinMain()"  
 Print "  lpCmdLine = " lpCmdLine
 Call Initialize()
 Call AttachMessageHandlers()
 If CmdLineProcessing(hInstance, lpCmdLine, regID) Then
    Function=0 :  Exit Function
 End If
 szAppName="CC.Exe"
 wc.cbSize=SizeOf(wc)                              :   wc.style=%CS_HREDRAW Or %CS_VREDRAW
 wc.lpfnWndProc=CodePtr(fnWndProc)                 :   wc.cbClsExtra=0
 wc.cbWndExtra=0                                   :   wc.hInstance=hInstance
 wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION)  :   wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW)
 wc.hbrBackground=%COLOR_BTNFACE+1                 :   wc.lpszMenuName=%NULL
 wc.lpszClassName=VarPtr(szAppName)
 Call RegisterClassEx(wc)
 hMainWnd=CreateWindowEx(0, szAppName, szAppName, %WS_OVERLAPPEDWINDOW, 400, 200, 545, 350, 0, 0, hInstance, ByVal lpCmdLine)
 While GetMessage(Msg,%NULL,0,0)
   TranslateMessage Msg
   DispatchMessage Msg
 Wend
 Call Terminate(lpCmdLine, regID)
 Print "Leaving WinMain()"
 Waitkey$
 
 WinMain=0
End Function


Code Select Expand


'Main.inc

%EDIT_SET_X_INT           = 1500
%BTN_SET_X_INT            = 1505
%EDIT_GET_X_INT           = 1510
%BTN_GET_X_INT            = 1515
%EDIT_SET_X_TEXT          = 1520
%BTN_SET_X_TEXT           = 1525
%EDIT_GET_X_TEXT          = 1530
%BTN_GET_X_TEXT           = 1535

%EDIT_SET_Y_INT           = 1540
%BTN_SET_Y_INT            = 1545
%EDIT_GET_Y_INT           = 1550
%BTN_GET_Y_INT            = 1555
%EDIT_SET_Y_TEXT          = 1560
%BTN_SET_Y_TEXT           = 1565
%EDIT_GET_Y_TEXT          = 1570
%BTN_GET_Y_TEXT           = 1575


Type WndEventArgs
 wParam                  As Long
 lParam                  As Long
 hWnd                    As Dword
 hInst                   As Dword
End Type


Type MessageHandler
 wMessage                As Long
 dwFnPtr                 As Dword
End Type

Declare Function FnPtr(wea As WndEventArgs) As Long
Global MsgHdlr() As MessageHandler


Code Select Expand


'CC.inc

Declare Function CoRegisterClassObjectPtr Lib "OLE32.DLL" Alias "CoRegisterClassObject" _
( _
 Byref rclsid       As Guid, _
 Byval pUnknown     As Dword, _
 Byval dwClsContext As Dword, _
 Byval flags        As Dword, _
 ByRef lpdwRegister As Dword _
) As Long                

                         'IClassFactory1 Interface Function Pointers
Declare Function          ptrCreateInstance (Byval this As Dword, Byval pUnk As Dword, Byref iid As Guid, Byref ppv As Dword) As Long
Declare Function          ptrLockServer     (Byval this As Dword, Byval blnLock As Long                                     ) As Long

                         'IX, IY Interface Function Pointer Prototypes
Declare Function          ptrQueryInterface (Byval this As Dword, Byref iid As Guid, Byref pUnknown As Dword                ) As Long
Declare Function          ptrAddRef         (Byval this As Dword                                                            ) As Dword
Declare Function          ptrRelease        (Byval this As Dword                                                            ) As Dword
Declare Function          ptrSetInt         (Byval this As Dword, Byval iVal As Long                                        ) As Long
Declare Function          ptrGetInt         (Byval this As Dword, Byref pVal As Long                                        ) As Long
Declare Function          ptrSetText        (Byval this As Dword, Byval strText As String                                   ) As Long
Declare Function          ptrGetText        (Byval this As Dword, Byref ptrText As String                                   ) As Long

$IID_IClassFactory        =  Guid$("{00000001-0000-0000-C000-000000000046}")
$IID_IUnknown             =  Guid$("{00000000-0000-0000-C000-000000000046}")
$CLSID_CC                 =  Guid$("{20000000-0000-0000-0000-000000000020}")
$IID_IX                   =  Guid$("{20000000-0000-0000-0000-000000000021}")
$IID_IY                   =  Guid$("{20000000-0000-0000-0000-000000000022}")
$LIBID_CCLibrary          =  Guid$("{20000000-0000-0000-0000-000000000023}")
$CLSID_Junk               =  Guid$("{12345678-9876-5432-1012-345678901234}")
$IID_Junk                 =  Guid$("{12345678-9876-5432-1012-345678901234}")

Type IXVtbl
 QueryInterface          As Dword Ptr
 AddRef                  As Dword Ptr
 Release                 As Dword Ptr
 SetXInt                 As Dword Ptr
 GetXInt                 As Dword Ptr
 SetXText                As Dword Ptr
 GetXText                As Dword Ptr
End Type

Type I_X
 lpIX                    As IXVtbl Ptr
End Type

Type IYVtbl
 QueryInterface          As Dword Ptr
 AddRef                  As Dword Ptr
 Release                 As Dword Ptr
 SetYInt                 As Dword Ptr
 GetYInt                 As Dword Ptr
 SetYText                As Dword Ptr
 GetYText                As Dword Ptr
End Type

Type I_Y
 lpIY                    As IYVtbl Ptr
End Type

Type CC
 lpIX                    As IXVtbl Ptr
 lpIY                    As IYVtbl Ptr
 m_iXInt                 As Long
 m_iYInt                 As Long
 m_XText                 As Dword Ptr
 m_YText                 As Dword Ptr
 m_cRef                  As Long
End Type

Type IClassFactoryVtbl
 QueryInterface          As Dword Ptr
 AddRef                  As Dword Ptr
 Release                 As Dword Ptr
 CreateInstance          As Dword Ptr
 LockServer              As Dword Ptr
End Type

Type IClassFactory1
 lpVtbl                  As IClassFactoryVtbl Ptr
End Type

Global g_szFriendlyName   As Asciiz*64
Global g_szVerIndProgID   As Asciiz*64
Global g_szProgID         As Asciiz*64
Global CCClassFactory     As IClassFactory1     'sizeof() =  4
Global IClassFactory_Vtbl As IClassFactoryVtbl  'sizeof() = 20
Global IX_Vtbl            As IXVtbl             'sizeof() = 28
Global IY_Vtbl            As IYVtbl             'sizeof() = 28
Global g_hModule          As Dword
Global g_lLocks           As Long
Global pIX                As Dword Ptr
Global pIY                As Dword Ptr
Global hMainWnd           As Dword


Sub CCLock()
 Print "  Entering CCLock()"
 Print "    g_lLocks = " g_lLocks
 Call InterlockedIncrement(g_lLocks)
 Print "    g_lLocks = " g_lLocks
 Print "  Leaving CCLock()"
End Sub


Sub CCUnLock()
 If g_lLocks > 0 Then
    Print "Entering CCUnLock()"
    Print "  g_lLocks = " g_lLocks
    Call InterlockedDecrement(g_lLocks)
    Print "  g_lLocks = " g_lLocks
    If g_lLocks=0 Then
       If hMainWnd Then
          Call PostQuitMessage(0)
          Call SendMessage(hMainWnd, %WM_CLOSE, 0, 0)
       End If  
    End If  
 Print "Leaving CCUnLock()"
 End If  
End Sub


Function IX_QueryInterface(ByVal this As I_X Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
 @ppv=%NULL
 Select Case iid
   Case $IID_IUnknown
     Print "  Called IX_QueryInterface() For IID_IUnknown And this=" this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IX
     Print "  Called IX_QueryInterface() For IID_IX And this=" this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IY
     Print "  Called IX_QueryInterface() For IID_IY And this=" this
     Incr this
     @ppv=this
     Call IY_AddRef(this)
     Function=%S_OK
     Exit Function
   Case Else
     Print "Called IX_QueryInterface()"
 End Select

 Function=%E_NoInterface
End Function


Function IX_AddRef(ByVal this As I_X Ptr) As Long
 Local pCC As CC Ptr

 Print "Called IX_AddRef()"
 pCC=this
 Incr @pCC.m_cRef

 IX_AddRef=@pCC.m_cRef
End Function


Function IX_Release(ByVal this As I_X Ptr) As Long
 Local pCC As CC Ptr

 pCC=this
 Decr @pCC.m_cRef
 If @pCC.m_cRef=0 Then
    Call CoTaskMemFree(this)
    Call CCUnLock()
    Print "Called IX_Release() And CC Was Deleted!"
 Else
    Print "Called IX_Release()"
 End If

 Function=@pCC.m_cRef
End Function


Function SetXInt(ByVal this As I_X Ptr, Byval iXVal As Long) As Long
 Local pCC As CC Ptr

 Print "Called SetXInt(" & Trim$(Str$(iXVal)) & ")"
 pCC=this
 @pCC.m_iXInt=iXVal

 Function=%S_OK
End Function


Function GetXInt(ByVal this As I_X Ptr, Byref pXVal As Long) As Long
 Local pCC As CC Ptr

 pCC=this
 pXVal=@pCC.m_iXInt
 Print "Called GetXInt(" & Trim$(Str$(pXVal)) & ")"

 Function=%S_OK
End Function


Function SetXText(ByVal this As I_X Ptr, Byval strXText As String) As Long
 Local pCC As CC Ptr

 Print "Setting IXText To " & strXText
 pCC=this
 If SysReAllocString(@pCC.m_XText, Byval Strptr(strXText)) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
End Function


Function GetXText(ByVal this As I_X Ptr, Byref strXText As String) As Long
 Local pCC As CC Ptr

 pCC=this
 If SysReAllocString(strXText, Byval @pCC.m_XText) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
 Print "IX Text: " & strXText
End Function


Function IY_QueryInterface(ByVal this As I_Y Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
 @ppv=%NULL
 Select Case iid
   Case $IID_IUnknown
     Print "Called IY_QueryInterface() For IID_IUnknown"
     Decr this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IX
     Print "Called IY_QueryInterface() For IID_IX"
     Decr this
     @ppv=this
     Call IX_AddRef(this)
     Function=%S_OK
     Exit Function
   Case $IID_IY
     Print "Called IY_QueryInterface() For IID_IY"
     @ppv=this
     Call IY_AddRef(this)
     Function=%S_OK
     Exit Function
   Case Else
     Print "Called IY_QueryInterface()"
 End Select

 Function=%E_NoInterface
End Function


Function IY_AddRef(ByVal this As I_Y Ptr) As Long
 Local pCC As CC Ptr

 Print "Called IY_AddRef() - this = " this
 Decr this
 pCC=this
 Incr @pCC.m_cRef

 IY_AddRef=@pCC.m_cRef
End Function


Function IY_Release(ByVal this As I_Y Ptr) As Long
 Local pCC As CC Ptr

 Decr this
 pCC=this
 Decr @pCC.m_cRef
 If @pCC.m_cRef=0 Then
    Call CoTaskMemFree(this)
    Call CCUnLock()
    Print "Called IY_Release() And CB Was Deleted!"
 Else
    Print "Called IY_Release()"
 End If

 Function=@pCC.m_cRef
End Function


Function SetYInt(ByVal this As I_Y Ptr, Byval iYVal As Long) As Long
 Local pCC As CC Ptr

 Print "Called SetYInt(" & Trim$(Str$(iYVal)) & ")"
 Decr this
 pCC=this
 @pCC.m_iYInt=iYVal

 Function=%S_OK
End Function


Function GetYInt(ByVal this As I_Y Ptr, Byref pYVal As Long) As Long
 Local pCC As CC Ptr

 Decr this
 pCC=this
 pYVal=@pCC.m_iYInt
 Print "Called GetXInt(" & Trim$(Str$(pYVal)) & ")"

 Function=%S_OK
End Function


Function SetYText(ByVal this As I_Y Ptr, Byval strYText As String) Export As Long
 Local pCC As CC Ptr

 Print "Setting IYText To " & strYText
 Decr this
 pCC=this
 If SysReAllocString(@pCC.m_YText, Byval Strptr(strYText)) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
End Function


Function GetYText(ByVal this As I_Y Ptr, Byref strYText As String) Export As Long
 Local pCC As CC Ptr

 Decr this
 pCC=this
 If SysReAllocString(strYText, Byval @pCC.m_YText) Then
    Function=%S_OK
 Else
    Function=%S_FALSE
 End If
 Print "IY Text: " & strYText
End Function


Function CCClassFactory_QueryInterface(ByVal this As IClassFactory1 Ptr, ByRef RefIID As Guid, ByVal pCF As Dword Ptr) As Long
 Print "Called CCClassFactory_QueryInterface()"
 If RefIID=$IID_IUnknown Or RefIID=$IID_IClassFactory Then
    Call CCClassFactory_AddRef(this)
    @pCF=this
    Print "  Leaving CCClassFactory_QueryInterface()"
    Function=%NOERROR
    Exit Function
 End If

 Function=%E_NoInterface
End Function


Function CCClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
 Print "Called CCClassFactory_AddRef()!"
 'Print "    Leaving CCClassFactory_AddRef()!"
 CCClassFactory_AddRef=10
End Function


Function CCClassFactory_Release(ByVal this As IClassFactory1 Ptr) As Long
 Print "Called CCClassFactory_Release()!"
 'Print "    this=" this
 'Print "  Leaving CCClassFactory_Release()!"
 CCClassFactory_Release=20
End Function


Function CCClassFactory_CreateInstance(ByVal this As IClassFactory1 Ptr, ByVal pUnknown As Dword, ByRef RefIID As Guid, ByVal ppv As Dword Ptr) As Long
 Local strIXStr, strIYStr As String
 Local pIX As I_X Ptr
 Local pCC As CC Ptr
 Local hr  As Long

 Print "Called CCClassFactory_CreateInstance()"
 @ppv=%NULL
 If pUnknown Then
    hr=%CLASS_E_NOAGGREGATION
    Exit Function
 Else
    If RefIID=$IID_IUnknown Or RefIID=$IID_IX Or RefIID=$IID_IY Then
       pCC=CoTaskMemAlloc(SizeOf(CC))
       If pCC Then
          Print "  pCC      ="pCC
          @pCC.lpIX=VarPtr(IX_Vtbl)               :   @pCC.lpIY=VarPtr(IY_Vtbl)
          Print "  @pCC.lpIX=" @pCC.lpIX          :   Print "  @pCC.lpIY=" @pCC.lpIY : Print
          Print " " Varptr(@pCC.lpIX), @pCC.lpIX  :   Print " " Varptr(@pCC.lpIY), @pCC.lpIY  : Print
          strIXStr="Default IX Interface String"  :   strIYStr="Default IY Interface String"
          strIXStr=UCode$(strIXStr)               :   strIYStr=UCode$(strIYStr)
          @pCC.m_XText=SysAllocStringLen(Byval Strptr(strIXStr),Len(strIXStr)+1)
          @pCC.m_YText=SysAllocStringLen(Byval Strptr(strIYStr),Len(strIYStr)+1)
          @pCC.m_iXInt=0     :   @pCC.m_iYInt=0   :    @pCC.m_cRef=0
          pIX=pCC
          hr= IX_QueryInterface(pIX,RefIID,ppv)
          Print "  pCC  = " pCC
          Print "  pIX  = " pIX
          Print "  @ppv = " @ppv
          If SUCCEEDED(hr) Then
             Call CCClassFactory_AddRef(this)
             Call CCLock()
          Else
             Call CoTaskMemFree(pCC)
             CCClassFactory_CreateInstance=%E_FAIL
             Print : Print "CreateInstance Failed!"
             Exit Function
          End If
       Else
          hr=%E_OutOfMemory
          Exit Function
       End If
    Else  
       hr=%E_FAIL
       Exit Function
    End If
 End If  
 Print "Leaving CBClassFactory_CreateInstance()"

 CCClassFactory_CreateInstance=%S_Ok
End Function


Function CCClassFactory_LockServer(ByVal this As IClassFactory1 Ptr, Byval flock As Long) As Long
 Print "Called CCClassFactory_LockServer()"
 If flock Then
    Call CCLock()
 Else
    Call CCUnLock()
 End If

 CCClassFactory_LockServer=%NOERROR
End Function


Function ExeRegisterServer(hInstance As Long) As Long
 Local strAsciPath,strWideCharPath As String
 Local hr,iBytesReturned As Long
 Local szPath As Asciiz*256
 Local pTypeLib As ITypeLib
 
 Print "  Entering ExeRegisterServer()"
 If GetModuleFileName(hInstance, szPath, 256) Then
    Print "    szPath         = " szPath
    strAsciPath=szPath
    strWideCharPath=UCode$(strAsciPath & $Nul)
    hr=LoadTypeLibEx(Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
    If SUCCEEDED(hr) Then
       Print "    LoadTypeLib() Succeeded!"
       'Call pTypeLib.Release()
       Set pTypeLib = Nothing
       hr=RegisterServer(szPath, $CLSID_CC, $LIBID_CCLibrary, g_szFriendlyName, g_szVerIndProgID, g_szProgID)
    Else
       Local dwFlags As Dword
       Local szError As Asciiz*256
       Print "    LoadTypeLib() Failed!"
       iBytesReturned= _
       FormatMessage _
       ( _
         dwFlags, _
         Byval 0, _
         hr, _
         MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), _
         Byval Varptr(szError), _
         256, _
         Byval %NULL _
       )
       Print "    iBytesReturned = " iBytesReturned
       Print "szBuffer           = " szError
    End If
 End If
 Print "  Leaving ExeRegisterServer()"

 Function=hr
End Function

'$LIBID_CCLibrary          =  Guid$("{20000000-0000-0000-0000-000000000023}")

'Function RegisterServer _
'( _
'  Byref szExeName As Asciiz, _
'  Byref ClassId As Guid, _
'  Byref LibId As Guid, _
'  Byref szFriendlyName As Asciiz, _
'  Byref szVerIndProgID As Asciiz, _
'  Byref szProgID As Asciiz _
') As Long


'Function UnregisterServer _
'( _
'  Byref ClassId As Guid, _
'  Byref szVerIndProgID As Asciiz, _
'  Byref szProgID As Asciiz _
') As Long

'DECLARE FUNCTION LoadTypeLibEx LIB "OLEAUT32.DLL" ALIAS "LoadTypeLibEx" ( _
'   BYVAL DWORD _                       ' __in  LPCOLESTR szFile
' , BYVAL LONG _                        ' __in  REGKIND regkind
' , BYREF ITypeLib _                    ' __out ITypeLib** pptlib
' ) AS LONG                             ' HRESULT

'DECLARE FUNCTION UnregisterTypelib LIB "OLEAUT32.DLL" ALIAS "UnregisterTypelib" ( _
'   BYREF GUID _                        ' __in REFGUID libID
' , BYVAL WORD _                        ' __in unsigned short wVerMajor
' , BYVAL WORD _                        ' __in unsigned short wVerMinor
' , BYVAL LONG _                        ' __in LCID lcid
' , BYVAL LONG _                        ' __in SYSKIND syskind
' ) AS LONG                             ' HRESULT

'The procedure entry point UnregisterTypeLib could not be found in the dynamic link library OleAuto32.dll"

Function ExeUnRegisterServer(hInstance As Long) As Long
 Local hr As Long
 
 Print "  Entering ExeUnregisterServer()"
 'hr=UnRegisterTypeLib($LIBID_CCLibrary, 1, 0, %LANG_NEUTRAL, %SYS_WIN32)
 'If SUCCEEDED(hr) Then
 '   Print "    UnRegisterTypeLib() Succeeded!"
 '   hr=UnregisterServer($CLSID_CC, g_szVerIndProgID, g_szProgID)
 'Else
 '   Print "    UnRegisterTypeLib() Failed!"  
 'End If
 Print "  Leaving ExeUnregisterServer()"
 
 Function=hr
End Function

'HRESULT ExeUnregisterServer(HINSTANCE hInstance)  
'{
' void* pMsgBuf=NULL;
' DWORD dwFlags;
' HRESULT hr;

' hr=UnRegisterTypeLib(LIBID_CFLibrary,1,0,LANG_NEUTRAL,SYS_WIN32);
' if(FAILED(hr))
' {
'    dwFlags=FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM;
'    FormatMessage(dwFlags,NULL,hr,MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),(LPTSTR)&pMsgBuf,0,NULL);
'    LocalFree(pMsgBuf);  
' }

' return UnregisterServer(&CLSID_CF,&LIBID_CFLibrary,g_szVerIndProgID,g_szProgID);;
'}


Function CmdLineProcessing(Byval hInstance As Long, Byval lpCmdLine As Asciiz Ptr, Byref regID As Dword) As Long
 Local hr As Long

 Print "Entering blnCmdLineProcessing()"
 If InStr(@lpCmdLine,"/r") Then
    Print "  Calling ExeRegisterServer()"
    hr=ExeRegisterServer(hInstance)
    If SUCCEEDED(hr) Then
       Print "  ExeRegisterServer() Apparently Succeeded!"
    Else
       Print "  ExeRegisterServer() Apparently Failed!"  
    End If  
    Print "Leaving blnCmdLineProcessing()"
    Print
    Function=%TRUE
    Exit Function
 End If
 If InStr(@lpCmdLine,"/u") Then
    Print "  Calling ExeUnregisterServer()"
    hr=ExeUnregisterServer(hInstance)
    If SUCCEEDED(hr) Then
       Print "  ExeUnregisterServer Apparently Succeeded!"
    Else
       Print "  ExeUnregisterServer Apparently Failed!"
    End If    
    Print "Leaving blnCmdLineProcessing()"
    Print
    Function=%TRUE
    Exit Function
 End If
 If InStr(@lpCmdLine,"/Embedding") Or InStr(@lpCmdLine,"-Embedding") Then
    Print "  Was Loaded By COM!"
    hr=CoRegisterClassObjectPtr($CLSID_CC, Varptr(CCClassFactory), %CLSCTX_LOCAL_SERVER, %REGCLS_MULTIPLEUSE, regID)
    If SUCCEEDED(hr) Then
       Print "  CoRegisterClassObject() Succeeded!"
       
    Else
       Print "CoRegisterClassObject() Failed!"
       Local dwFlags As Dword
       Local szError As Asciiz*256
       dwFlags=%FORMAT_MESSAGE_FROM_SYSTEM
       FormatMessage(dwFlags, Byval 0, hr, MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), Byval Varptr(szError), 256, Byval %NULL)
       Print "szBuffer = " szError
   End If
 End If  
 Print "Leaving blnCmdLineProcessing()"
 Print

 Function=%FALSE
End Function


Function Initialize() As Long
 Local pClsFac As Dword Ptr
 Local hr As Long

 Print "Entering Initialize()"
 g_szFriendlyName                           = "Com Object CC"
 g_szProgID                                 = "ComObject.CC.1"
 g_szVerIndProgID                           = "ComObject.CC"
 IClassFactory_Vtbl.QueryInterface          = CodePtr(CCClassFactory_QueryInterface)
 IClassFactory_Vtbl.AddRef                  = CodePtr(CCClassFactory_AddRef)
 IClassFactory_Vtbl.Release                 = CodePtr(CCClassFactory_Release)
 IClassFactory_Vtbl.CreateInstance          = CodePtr(CCClassFactory_CreateInstance)
 IClassFactory_Vtbl.LockServer              = CodePtr(CCClassFactory_LockServer)
 CCClassFactory.lpVtbl                      = VarPtr(IClassFactory_Vtbl)
 Print "  IClassFactory_Vtbl.QueryInterface = " IClassFactory_Vtbl.QueryInterface
 Print "  IClassFactory_Vtbl.AddRef         = " IClassFactory_Vtbl.AddRef
 Print "  IClassFactory_Vtbl.Release        = " IClassFactory_Vtbl.Release
 Print "  IClassFactory_Vtbl.CreateInstance = " IClassFactory_Vtbl.CreateInstance
 Print "  IClassFactory_Vtbl.LockServer     = " IClassFactory_Vtbl.LockServer
 Print
 Print "  Varptr(CCClassFactory)            = " Varptr(CCClassFactory)
 Print "  Varptr(CCClassFactory.lpVtbl)     = " Varptr(CCClassFactory.lpVtbl)
 Print "  Varptr(IClassFactory_Vtbl)        = " Varptr(IClassFactory_Vtbl)
 Print "  CCClassFactory.lpVtbl             = " CCClassFactory.lpVtbl  
 IX_Vtbl.QueryInterface                     = CodePtr(IX_QueryInterface)
 IX_Vtbl.AddRef                             = CodePtr(IX_AddRef)
 IX_Vtbl.Release                            = CodePtr(IX_Release)
 IX_Vtbl.SetXInt                            = CodePtr(SetXInt)
 IX_Vtbl.GetXInt                            = CodePtr(GetXInt)
 IX_Vtbl.SetXText                           = CodePtr(SetXText)
 IX_Vtbl.GetXText                           = CodePtr(GetXText)
 IY_Vtbl.QueryInterface                     = CodePtr(IY_QueryInterface)
 IY_Vtbl.AddRef                             = CodePtr(IY_AddRef)
 IY_Vtbl.Release                            = CodePtr(IY_Release)
 IY_Vtbl.SetYInt                            = CodePtr(SetYInt)
 IY_Vtbl.GetYInt                            = CodePtr(GetYInt)
 IY_Vtbl.SetYText                           = CodePtr(SetYText)
 IY_Vtbl.GetYText                           = CodePtr(GetYText)
 hr=CCClassFactory_QueryInterface(VarPtr(CCClassFactory), $IID_IClassFactory, Varptr(pClsFac))
 If FAILED(hr) Then
    CCClassFactory.lpVTbl=0
    hr=%CLASS_E_CLASSNOTAVAILABLE
    Exit Function
 Else
   
    Print "  pClsFac = " pClsFac
 End If
 Print "Leaving Initialize()" : Print

 Function=hr
End Function


Code Select Expand


'Registry.inc

Function SetKeyAndValue(Byref szKey As Asciiz, Byref szSubKey As Asciiz, Byref szValue As Asciiz) As Long
 Local szKeyBuf As Asciiz*1024
 Local lResult As Long
 Local hKey As Dword

 If szKey<>"" Then
    szKeyBuf=szKey
    If szSubKey<>"" Then
       szKeyBuf=szKeyBuf+"\"+szSubKey
    End If
    lResult=RegCreateKeyEx(%HKEY_CLASSES_ROOT,szKeyBuf,0,Byval %NULL,%REG_OPTION_NON_VOLATILE,%KEY_ALL_ACCESS,Byval %NULL,hKey,%NULL)
    If lResult<>%ERROR_SUCCESS Then
       Function=%FALSE
       Exit Function
    End If
    If szValue<>"" Then
       Call RegSetValueEx(hKey,Byval %NULL, Byval 0, %REG_SZ, szValue, Len(szValue)+1)
    End If
    Call RegCloseKey(hKey)
 Else
    Function=%FALSE
    Exit Function
 End If

 Function=%TRUE
End Function


Function RecursiveDeleteKey(Byval hKeyParent As Dword, Byref lpszKeyChild As Asciiz) As Long
 Local dwSize,hKeyChild As Dword
 Local szBuffer As Asciiz*256
 Local time As FILETIME
 Local lRes As Long

 dwSize=256
 lRes=RegOpenKeyEx(hKeyParent,lpszKeyChild,0,%KEY_ALL_ACCESS,hKeyChild)
 If lRes<>%ERROR_SUCCESS Then
    Function=lRes
    Exit Function
 End If
 While(RegEnumKeyEx(hKeyChild,0,szBuffer,dwSize,0,Byval 0,Byval 0,time)=%S_OK)
   lRes=RecursiveDeleteKey(hKeyChild,szBuffer)  'Delete the decendents of this child.
   If lRes<>%ERROR_SUCCESS Then
      Call RegCloseKey(hKeyChild)
      Function=lRes
      Exit Function
   End If
   dwSize=256
 Loop
 Call RegCloseKey(hKeyChild)

 Function=RegDeleteKey(hKeyParent,lpszKeyChild)  'Delete this child.
End Function


Function RegisterServer(Byref szExeName As Asciiz, Byref ClassId As Guid, Byref LibId As Guid, Byref szFriendlyName As Asciiz, Byref szVerIndProgID As Asciiz, Byref szProgID As Asciiz) As Long
 Local szClsid As Asciiz*48, szLibid As Asciiz*48, szKey As Asciiz*64
 Local iReturn As Long

 Print "    Entering RegisterServer()"
 Print "      szExeName  = " szExeName
 szClsid=GuidTxt$(ClassId)
 szLibid=GuidTxt$(LibId)
 If szClsid <> "" And szLibid <> "" Then
    Print "      szClsid    = " szClsid
    Print "      szLibid    = " szLibid
    szKey="CLSID\" & szClsid
    Print "      szKey      = " szKey
    If IsFalse(SetKeyAndValue(szKey, Byval %NULL, szFriendlyName)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szKey, "LocalServer32", szExeName)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szKey, "ProgID", szProgID)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szKey, "TypeLib", szLibid)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szVerIndProgID,Byval %NULL, szFriendlyName)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szVerIndProgID, "CLSID", szClsid)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szVerIndProgID, "CurVer", szProgID)) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szProgID, Byval %NULL, "A COM Object Of Class C")) Then
       Function=%E_FAIL : Exit Function
    End If
    If IsFalse(SetKeyAndValue(szProgID, "CLSID", szClsid)) Then
       Function=%E_FAIL : Exit Function
    End If
    Function=%S_OK
    Exit Function
 Else
    Function=%E_FAIL
    Exit Function
 End If
 Print "    Leaving RegisterServer()"
End Function


Function UnregisterServer(Byref ClassId As Guid, Byref szVerIndProgID As Asciiz, Byref szProgID As Asciiz) As Long
 Local szClsid As Asciiz*48, szKey As Asciiz*64
 Local lResult As Long

 szClsid=GuidTxt$(ClassId)
 If szClsid<>"" Then
    szKey="CLSID\"+szClsid
    lResult=RecursiveDeleteKey(%HKEY_CLASSES_ROOT,szKey)
    If lResult<>%ERROR_SUCCESS Then
       Function=%E_FAIL
       Exit Function
    End If
    lResult=RecursiveDeleteKey(%HKEY_CLASSES_ROOT, szVerIndProgID)    'Delete the version-independent ProgID Key.
    If lResult<>%ERROR_SUCCESS Then
       Function=%E_FAIL
       Exit Function
    End If
    lResult=recursiveDeleteKey(%HKEY_CLASSES_ROOT, szProgID)          'Delete the ProgID key.
    If lResult<>%ERROR_SUCCESS Then
       Function=%E_FAIL
       Exit Function
    End If
 Else
    Function=%E_FAIL
    Exit Function
 End If

 Function=%S_OK
End Function


[Edwin Knoppert]

Not tested (yet) but thanks!
At some point i may need this stuff.

[Frederick J. Harris]

I'm having one of those bad days today Edwin!  Got through the UnregisterTypeLib problem and all of a sudden everything has stopped working for me!  I think I need a break!  At this point nothing is working for me anymore!!!

[Frederick J. Harris]

I believe I've got things working again!

What had me messed up yesterday was the last parameter to the CoRegisterClassObjectPtr Declare, which needs to be Byref not Byval for the way I'm using it.  I just fixed it in the code above.  If you copied that Edwin I wanted to point that out.  I expect I'll be working on this more today, so I'll update the code again later.  But I think its working now.  Need more testing, naturally.  Another big 'gottcha' is forgetting to embed the Type library in the exe after a compile.  It won't affect running the exe as a stand alone program, but if its loaded by SCM, SCM won't be able to find anything, and a lock up or failure will occur somewhere.

Code Select Expand


Declare Function CoRegisterClassObjectPtr Lib "OLE32.DLL" Alias "CoRegisterClassObject" _
( _
  Byref rclsid       As Guid, _
  Byval pUnknown     As Dword, _
  Byval dwClsContext As Dword, _
  Byval flags        As Dword, _
  ByRef lpdwRegister As Dword _
) As Long               


[Frederick J. Harris]

Well, I think I'm finally more or less satisfied with this.  I'm attaching CCGui1.zip that should have everything in it.  The CC.exe file could be registered directly and run either by just executing it, or through connecting to it once registered by another client app.  What this Gui version does is just provide some text boxes, labels, and buttons to allow you to call the Interface X and Interface Y methods, which methods just set/get an integer value, and set/get a BSTR.  If you look in CC.idl you'll see the descriptions of the interfaces and methods. 

Creating the GUI program with the Console Compiler worked out really well because the console screen that comes up when you launch CC.exe directly, or when the COM Service Control Manager launches it, makes it nice to see what's going on in the innards of the thing.

I really didn't know how best to put the GUI part together and integrate it into the COM object contained in the exe.  You might be able to come up with a better idea.  Basically, here's what happens.

When an external client exe attempts to connect to the object, COM will find out its a Local Server by looking at the ProgID in the registry.  It will also find out that the OLE Automation Marshaller in OleAuto32.dll is being used to marshall method parameters between processes.  It finds this out through the TypeLib and Interface keys in the registry.  Check out...

HKEY_CLASSES_ROOT\Interface\20000000-0000-0000-0000-000000000021

And

HKEY_CLASSES_ROOT\Interface\20000000-0000-0000-0000-000000000022

Which are the IX/IY interface keys.  The ProxyStubClsid32 subkeys for each of these interfaces will have a value of...

00020424-0000-0000-C000-000000000046

which is the CLSID of the Universal Marshaller in OleAuto32.dll.


When SCM starts CC.exe it will pass in the command line string "/Embedding" or "-Embedding".  My code will be testing for that in the proc CmdLineProcessing().  If it finds that string in the command line a call will be made to the critically important function that makes this all work, and that is CoRegisterClassObject().  The critical parameter there is the 2nd which is the address of a class factory object so that COM can create an instance of the object.  When CmdLineProcessing returns initialization of a WndClassEX struct in WinMain() begins.  Right after that is the CreateWindow() call to create the program's window.  Note however there is no ShowWindow() call in WinMain().  I've a regular message pump, and I pass the lpCmdLine parameter through to fnWndProc_OnCreate().  If that message handler finds lpCmdLine pointing to a "/Embedding" or "-Embedding" string then it knows  the program was started by COM so it doesn't need to create a window with child window controls on it or even make the window visible.  However, the window does need to be created and the message pump needs to run so as to keep the CC object in memory.  It is the message pump that keeps the object in memory.  Since there is no window visible for the user to click an 'x' button, the question naturally arises as to how the window is going to be destroyed when the client app is done with it.

The program maintains a global reference counting variable – g_lLocks.  When the lock count in UnLock() reaches zero that procedure fires a PostQuitMessage() and SendMessage()'s a WM_CLOSE to the main WndProc().  Maybe you can come up with a better idea.  If so – let me know and I'll try it.

Note that there are WaitKey$ statements in both the client (CCClient1.exe) and the Server, so you need to hit a key to dismiss both.

Here is what a command line session looks like to register/unregister the component...

Code Select Expand


Example Of Registration of CC.exe.  Use CC.exe /r
=============================================================

C:\Code\PwrBasic\PBCC50\CC>cc.exe /r
Entering WinMain()
  lpCmdLine =  1255787
  Entering Initialize()
    IClassFactory_Vtbl.QueryInterface =  4217242
    IClassFactory_Vtbl.AddRef         =  4217442
    IClassFactory_Vtbl.Release        =  4217527
    IClassFactory_Vtbl.CreateInstance =  4217620
    IClassFactory_Vtbl.LockServer     =  4218718
    Varptr(CCClassFactory)            =  4253684
    Varptr(CCClassFactory.lpVtbl)     =  4253684
    Varptr(IClassFactory_Vtbl)        =  4253688
    CCClassFactory.lpVtbl             =  4253688
    Called CCClassFactory_QueryInterface()
    Called CCClassFactory_AddRef()!
    Leaving CCClassFactory_QueryInterface()
    pClsFac =  4253684
  Leaving Initialize()

  Entering blnCmdLineProcessing()
    Calling ExeRegisterServer()
    Entering ExeRegisterServer()
      szPath         = C:\Code\PwrBasic\PBCC50\CC\CC.EXE
      LoadTypeLib() Succeeded!
      Entering RegisterServer()
        szExeName  = C:\Code\PwrBasic\PBCC50\CC\CC.EXE
        szClsid    = {20000000-0000-0000-0000-000000000020}
        szLibid    = {20000000-0000-0000-0000-000000000023}
        szKey      = CLSID\{20000000-0000-0000-0000-000000000020}
      Leaving ExeRegisterServer()
      ExeRegisterServer() Apparently Succeeded!
  Leaving blnCmdLineProcessing()
Exiting WinMain() Early

C:\Code\PwrBasic\PBCC50\CC>






Example of UnRegistration With /u switch
==================================================================

C:\Code\PwrBasic\PBCC50\CC>CC.exe /u
Entering WinMain()
  lpCmdLine =  1254775
Entering Initialize()
  IClassFactory_Vtbl.QueryInterface =  4217242
  IClassFactory_Vtbl.AddRef         =  4217442
  IClassFactory_Vtbl.Release        =  4217527
  IClassFactory_Vtbl.CreateInstance =  4217620
  IClassFactory_Vtbl.LockServer     =  4218718

  Varptr(CCClassFactory)            =  4253684
  Varptr(CCClassFactory.lpVtbl)     =  4253684
  Varptr(IClassFactory_Vtbl)        =  4253688
  CCClassFactory.lpVtbl             =  4253688
Called CCClassFactory_QueryInterface()
Called CCClassFactory_AddRef()!
  Leaving CCClassFactory_QueryInterface()
  pClsFac =  4253684
Leaving Initialize()

Entering blnCmdLineProcessing()
  Calling ExeUnregisterServer()
  Entering ExeUnregisterServer()
    UnRegisterTypeLib() Succeeded!
  Leaving ExeUnregisterServer()
  ExeUnregisterServer Apparently Succeeded!
Leaving blnCmdLineProcessing()