Author Topic: COM Exe Server With PowerBASIC Console Compiler 5.04  (Read 11506 times)

0 Members and 1 Guest are viewing this topic.

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
COM Exe Server With PowerBASIC Console Compiler 5.04
« on: April 11, 2010, 08:08:41 PM »
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]
#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!
« Last Edit: April 12, 2010, 01:14:00 AM by Frederick J. Harris »

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #1 on: April 11, 2010, 08:10:46 PM »
Here is Registry.inc which is referenced in the includes at top of CC.bas...

Code: [Select]
'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

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #2 on: April 11, 2010, 08:19:49 PM »
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]
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;
 };
};

« Last Edit: April 12, 2010, 01:29:22 AM by Frederick J. Harris »

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #3 on: April 11, 2010, 08:24:22 PM »
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]
#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

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #4 on: April 11, 2010, 08:32:07 PM »
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]
//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
« Last Edit: April 12, 2010, 01:31:55 AM by Frederick J. Harris »

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #5 on: April 11, 2010, 08:34:00 PM »
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]
#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
« Last Edit: April 11, 2010, 08:35:57 PM by Frederick J. Harris »

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #6 on: April 11, 2010, 08:48:48 PM »
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!

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #7 on: April 11, 2010, 09:47:50 PM »
Attached is a zip file with all the code, exes, tlbs, etc.  Let me know if something doesn't work.

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #8 on: April 12, 2010, 01:21:27 AM »
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.

Offline Petr Schreiber

  • Full Member
  • ***
  • Posts: 183
  • User-Rate: +14/-4
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #9 on: April 12, 2010, 08:11:35 AM »
Thanks Frederick,

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

So after using this first:
Quote
CC.exe /r
it worked great.

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


Petr
AMD Sempron 3400+ | 1GB RAM @ 533MHz | GeForce 6200 / GeForce 9500GT | 32bit Windows XP SP3

psch.thinbasic.com

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #10 on: April 13, 2010, 07:23:42 PM »
Work In Progress - GUI Version...

Code: [Select]
'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]
'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]
'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]
'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
« Last Edit: April 14, 2010, 05:40:31 PM by Frederick J. Harris »

Offline Edwin Knoppert

  • Sr. Member
  • ****
  • Posts: 254
  • User-Rate: +11/-4
    • Hellobasic.com
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #11 on: April 13, 2010, 11:48:29 PM »
Not tested (yet) but thanks!
At some point i may need this stuff.

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #12 on: April 13, 2010, 11:56:47 PM »
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!!!

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #13 on: April 14, 2010, 05:46:23 PM »
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]
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               

Offline Frederick J. Harris

  • Hero Member
  • *****
  • Posts: 914
  • User-Rate: +16/-0
    • Frederick J. Harris
Re: COM Exe Server With PowerBASIC Console Compiler 5.04
« Reply #14 on: April 14, 2010, 08:40:09 PM »
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]
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()