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
#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!
Here is Registry.inc which is referenced in the includes at top of CC.bas...
'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
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.
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;
};
};
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...
#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
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...
//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
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....
#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
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!
Attached is a zip file with all the code, exes, tlbs, etc. Let me know if something doesn't work.
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.
Thanks Frederick,
first it GPFed for me, but this was because I forgot to register it.
So after using this first:
QuoteCC.exe /r
it worked great.
Thanks for sharing, I am looking forward to your next experiments.
Petr
Work In Progress - GUI Version...
'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
'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
'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
'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
Not tested (yet) but thanks!
At some point i may need this stuff.
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!!!
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.
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
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...
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()