Below is a work in progress. It is my attempt to create Visual COM controls low level using Microsoft's 'Connectable Objects' interfaces. What I have done is convert my custom control demo from here...
http://www.jose.it-berater.org/smfforum/index.php?topic=2907.0
to a visual COM control. What the control does is create a colored window within a parent container window on the main Form. There are three buttons on the host app which loads the control, and by clicking the 'Blue', 'Green', or 'Red' button COM calls are made to change the color of the control. The direction of communication in this case is the simple case of a host doing a method call on the object. However, when the user clicks on the control, the control fires an event in the client's 'Sink' object, and the client then presents various information obtainable from the COM object such as its window handle, color, and control ID.
I'll present quite a few various clients/hosts to try it on. However, I am having some problems with it. I can't get it to work in Visual Basic 6 no matter what I do, although near as I can tell it is working perfectly using Visual Basic .NET, PowerBASIC 9, and various C++ clients I've tried. The VB6 thing is a real mystery to me. I'll probably not rest 'till I get to the bottom of the problem, but I have to say at this point I'm mystified. What I did was first write this program using low level C without ATL, MFC or anything like that. I wanted to create something I could translate to PowerBASIC as easily as possible, and C code is usually easily converted to PowerBASIC. The program in C works perfectly with Visual Basic 6 and the PowerBASIC one doesn't even though it works perfectly in everything else I've tried. So if you are interested in this and can figure out what my error is, I'd certainly be grateful. At some point I'd like to add explanatory comments to this and perhaps a tutorial, but at this point I consider it a 'work in progress'.
There are piles of console output statements in the dll that will print to a console window if the host creates one. I've typically been doing that.
#if 0
CD.bas produces a Dll containing a visual COM control, or, ActiveX control, if you'll permit me that term.
After compiling it using Jose's includes, embed the type library file CD.tlb (included in CD.zip) into CD.dll
as follows...
C:\.....>PBTyp.exe CD.dll CD.rc
CD.rc is included in the zip but simply comprises this...
1 typelib CD.TLB
After embedding the type library you need to register the dll with Windows with RegSvr32.exe something
like this...
C:\.........YourDir\>RegSvr32 CD.dll
You can unregister it with the /u switch after the 'CD.dll' part. All the code to produce the dll is in
this file for simplicity sake, even the registry code which I usually keep in a seperate file. The only thing
you need not in this file are the CD.rc and CD.tlb files which I'll put in a zip.
#endif
#Compile Dll 'You need Jose's Includes, but I don't think much would have to
#Dim All 'change if the PowerBASIC includes were to be used.
#Include "Win32api.inc"
#Include "ObjBase.inc"
#Resource "CD.pbr"
Declare Function ptrQueryInterface (Byval this As Dword Ptr, Byref iid As Guid, Byval pUnknown As Dword) As Long
Declare Function ptrRelease (Byval this As Dword Ptr) As Long
Declare Function ptrControlEvent (Byval this As Dword Ptr, Byval iMessage As Long) As Long
$IID_IUnknown = Guid$("{00000000-0000-0000-C000-000000000046}")
$IID_IClassFactory = Guid$("{00000001-0000-0000-C000-000000000046}")
$IID_IConnectionPoint = Guid$("{B196B286-BAB4-101A-B69C-00AA00341D07}")
$IID_IConnectionPointContainer = Guid$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
$CLSID_CD = Guid$("{20000000-0000-0000-0000-000000000040}")
$IID_ICOMCtrl = Guid$("{20000000-0000-0000-0000-000000000041}")
$IID_IOutGoing = Guid$("{20000000-0000-0000-0000-000000000042}")
$IID_LIBID_CD = Guid$("{20000000-0000-0000-0000-000000000043}")
Type IComCtrlVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Initialize As Dword Ptr
CreateControl As Dword Ptr
SetColor As Dword Ptr
GetColor As Dword Ptr
GetCtrlId As Dword Ptr
GetHWND As Dword Ptr
End Type
Type IComCtrl
lpVtbl As IComCtrlVtbl Ptr
End Type
Type IConnectionPointContainerVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
EnumConnectionPoints As Dword Ptr
FindConnectionPoint As Dword Ptr
End Type
Type IConnectionPointContainer1
lpVtbl As IConnectionPointContainerVtbl Ptr
End Type
Type IConnectionPointVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
GetConnectionInterface As Dword Ptr
GetConnectionPointContainer As Dword Ptr
Advise As Dword Ptr
Unadvise As Dword Ptr
EnumConnections As Dword Ptr
End Type
Type IConnectionPoint1
lpVtbl As IConnectionPointVtbl Ptr
End Type
Type CD
lpComCtrlVtbl As IComCtrlVtbl Ptr
lpICPCVtbl As IConnectionPointContainerVtbl Ptr
lpICPVtbl As IConnectionPointVtbl Ptr
hContainer As Dword
hControl As Dword
m_cRef As Long
End Type
Type IEnumConnectionPointsVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Next As Dword Ptr
Skip As Dword Ptr
Reset As Dword Ptr
Clone As Dword Ptr
End Type
Type IEnumConnectionPoints1
lpVtbl As IEnumConnectionPointsVtbl Ptr
End Type
Type IEnumConnectionsVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Next As Dword Ptr
Skip As Dword Ptr
Reset As Dword Ptr
Clone As Dword Ptr
End Type
Type IEnumConnections1
lpVtbl As IEnumConnectionsVtbl Ptr
End Type
Type IOutGoingVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
ControlEvent As Dword Ptr
End Type
Type IOutGoing
lpVtbl As IOutGoingVtbl Ptr
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 CDClassFactory As IClassFactory1
Global IClassFactory_Vtbl As IClassFactoryVtbl
Global IComCtrl_Vtbl As IComCtrlVtbl
Global IConnPointContainer As IConnectionPointContainer1
Global IConnPointContainer_Vtbl As IConnectionPointContainerVtbl
Global IConnPoint As IConnectionPoint1
Global IConnPoint_Vtbl As IConnectionPointVtbl
Global g_hModule As Dword
Global g_lLocks As Long
Global g_lObjs As Long
Global g_CtrlId As Long
Global g_ptrOutGoing As Dword Ptr
Sub Prnt(strLn As String)
Local iLen, iWritten As Long
Local hStdOutput As Dword
Local strNew As String
hStdOutput=GetStdHandle(%STD_OUTPUT_HANDLE)
strNew=strLn + $CrLf
iLen = Len(strNew)
WriteConsole(hStdOutput, Byval Strptr(strNew), iLen, iWritten, Byval 0)
End Sub
Function IComCtrl_QueryInterface(ByVal this As IComCtrl Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
Prnt " Entering IComCtrl_QueryInterface()"
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Prnt " Trying To Get IUnknown"
Call IComCtrl_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Prnt " Trying To Get IComCtrl"
Call IComCtrl_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Prnt " Trying To Get IConnectionPointContainer"
Prnt " this = " & Str$(this)
Incr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
Prnt " Trying To Get IConnectionPoint"
Prnt " this = " & Str$(this)
Incr this : Incr this
@ppv=this
Call IConnectionPoint_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case Else
Prnt " Looking For Something I Ain't Got!"
Prnt " Leaving IComCtrl_QueryInterface()"
End Select
Function=%E_NoInterface
End Function
Function IComCtrl_AddRef(ByVal this As IComCtrl Ptr) As Long
Local pCD As CD Ptr
pCD=this
Incr @pCD.m_cRef
IComCtrl_AddRef=@pCD.m_cRef
End Function
Function IComCtrl_Release(ByVal this As IComCtrl Ptr) As Long
Local pCD As CD Ptr
Prnt "Entering IComCtrl_Release()"
pCD=this
Prnt " @pCD.m_cRef = " & Str$(@pCD.m_cRef)
Decr @pCD.m_cRef
If @pCD.m_cRef=0 Then
Call SendMessage(@pCD.hControl,%WM_CLOSE,0,0)
Call CoTaskMemFree(this)
Call InterlockedDecrement(g_lObjs)
Prnt " @pCD.m_cRef = " & Str$(@pCD.m_cRef)
Prnt " CD Was Deleted!"
End If
Prnt "Leaving IComCtrl_Release()"
Function=@pCD.m_cRef
End Function
Function fnWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case As Long Msg
Case %WM_CREATE
Call SetWindowLong(hWnd,0,RGB(255,255,0))
Function=0
Exit Function
Case %WM_PAINT
Local hDC,hNewBrush As Dword
Local ps As PAINTSTRUCT
hDC=BeginPaint(hWnd,ps)
hNewBrush=CreateSolidBrush(GetWindowLong(hWnd,0))
Call FillRect(hDC,ps.rcPaint,hNewBrush)
Call DrawText(hDC, "Click Me!",-1,ps.rcPaint,%DT_SINGLELINE Or %DT_CENTER Or %DT_VCENTER)
Call DeleteObject(hNewBrush)
Call EndPaint(hWnd,ps)
Function=0
Exit Function
Case %WM_LBUTTONDOWN
Local Vtbl As Dword Ptr
Local hr As Long
Prnt "WM_LBUTTONDOWN"
Prnt "g_ptrOutGoing = " & Str$(g_ptrOutGoing)
Vtbl=@g_ptrOutGoing
Prnt "@Vtbl = " & Str$(@Vtbl)
Prnt "@Vtbl[0] = " & Str$(@Vtbl[0])
Call Dword @Vtbl[3] Using ptrControlEvent(g_ptrOutGoing, Msg) To hr
Function=0
Exit Function
End Select
Function=DefWindowProc(hWnd,Msg,wParam,lParam)
End Function
Function IComCtrl_Initialize(ByVal this As IComCtrl Ptr) As Long
Local szClassName As Asciiz*16
Local wc As WndClassEx
Prnt " Entering IComCtrl_Initialize()"
Prnt " this = " & Str$(this)
szClassName="ComCtrl"
wc.cbSize=SizeOf(wc)
wc.style=%CS_GLOBALCLASS
wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0
wc.cbWndExtra=4 'Four extra bytes to store RGB color.
wc.hInstance=g_hModule
wc.hIcon=LoadIcon(Byval %NULL, Byval %IDI_APPLICATION)
wc.hCursor=LoadCursor(%NULL,ByVal %IDC_ARROW)
wc.hbrBackground=GetStockObject(%WHITE_BRUSH)
wc.lpszMenuName=%NULL
wc.lpszClassName=VarPtr(szClassName)
wc.hIconSm=LoadIcon(Byval %NULL, Byval %IDI_APPLICATION)
'wc.hIconSm=%NULL
If RegisterClassEx(wc) Then
Function=%S_OK
Else
Function=%S_FALSE
End If
Prnt " Leaving IComCtrl_Initialize()"
End Function
Function IComCtrl_CreateControl(ByVal this As IComCtrl Ptr, Byval hContainer As Long) As Long
Local pCD As CD Ptr
Local hCtl As Dword
Local rc As RECT
Prnt "Entering IComCtrl_CreateControl()"
Prnt " this = " & Str$(this)
Call GetClientRect(hContainer,rc)
hCtl=CreateWindow("ComCtrl","",%WS_CHILD Or %WS_VISIBLE,0,0,rc.nRight,rc.nBottom,hContainer,g_CtrlId,g_hModule,Byval 0)
Incr g_CtrlId
pCD=this
@pCD.hContainer=hContainer
@pCD.hControl=hCtl
Call ShowWindow(hCtl,%SW_SHOWNORMAL)
Call SetFocus(hCtl)
Prnt "Leaving IComCtrl_CreateControl()"
Function=%S_OK
End Function
Function IComCtrl_SetColor(Byval this As IComCtrl Ptr, Byval iColor As Long) As Long
Local pCD As CD Ptr
pCD=this
Call SetWindowLong(@pCD.hControl,0,iColor)
Call InvalidateRect(@pCD.hControl,Byval %NULL, %TRUE)
Function=%S_OK
End Function
Function IComCtrl_GetColor(Byval this As IComCtrl Ptr, Byref ptrColor As Long) As Long
Local pCD As CD Ptr
pCD=this
ptrColor=GetWindowLong(@pCD.hControl,0)
Function=%S_OK
End Function
Function IComCtrl_GetCtrlId(Byval this As IComCtrl Ptr, Byref ptrCtrlId As Long) As Long
Local pCD As CD Ptr
pCD=this
ptrCtrlId=GetDlgCtrlId(@pCD.hControl)
Function=%S_OK
End Function
Function IComCtrl_GetHWND(Byval this As IComCtrl Ptr, Byref ptrWindowHandle As Long) As Long
Local pCD As CD Ptr
pCD=this
ptrWindowHandle=@pCD.hControl
Function=%S_OK
End Function
Function IConnectionPointContainer_QueryInterface(ByVal this As IConnectionPointContainer1 Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Call IConnectionPointContainer_AddRef(this)
@ppv=this
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
Incr this
@ppv=this
Call IConnectionPoint_AddRef(this)
Function=%S_OK
Exit Function
End Select
Function=%E_NOINTERFACE
End Function
Function IConnectionPointContainer_AddRef(ByVal this As IConnectionPointContainer1 Ptr) As Long
Local pCD As CD Ptr
Decr this
pCD=this
Incr @pCD.m_cRef
Function=@pCD.m_cRef
End Function
Function IConnectionPointContainer_Release(ByVal this As IConnectionPointContainer1 Ptr) As Long
Local pCD As CD Ptr
Prnt " Entering IConnectionPointContainer_Release()"
Decr this
pCD=this
Decr @pCD.m_cRef
If @pCD.m_cRef=0 Then
Prnt " @pCD.m_cRef = 0 And Will Now Delete pCD!"
Call CoTaskMemFree(this)
Call InterlockedDecrement(g_lObjs)
End If
Prnt " Leaving IConnectionPointContainer_Release()"
Function=@pCD.m_cRef
End Function
Function IConnectionPointContainer_EnumConnectionPoints(ByVal this As IConnectionPointContainer1 Ptr, Byval ppEnum As IEnumConnectionPoints1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPointContainer_FindConnectionPoint(ByVal this As IConnectionPointContainer1 Ptr, ByRef iid As Guid, ByVal ppCP As Dword Ptr) As Long
Local hr As Long
Prnt " Entering IConnectionPointContainer_FindConnectionPoint()"
If iid=$IID_IOutGoing Then
Prnt " this = " & Str$(this)
Prnt " @ppCP = " & Str$(@ppCP)
hr=IConnectionPointContainer_QueryInterface(this, $IID_IConnectionPoint, ppCP)
Prnt " @ppCP = " & Str$(@ppCP)
Prnt " Leaving IConnectionPointContainer_FindConnectionPoint()"
Function=hr
Exit Function
End If
Function=%E_NOINTERFACE
End Function
Function IConnectionPoint_QueryInterface(ByVal this As IConnectionPoint1 Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Decr this : Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Decr this : Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Decr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
@ppv=this
Call IConnectionPoint_AddRef(this)
Function=%S_OK
Exit Function
End Select
Function=%E_NOINTERFACE
End Function
Function IConnectionPoint_AddRef(ByVal this As IConnectionPoint1 Ptr) As Long
Local pCD As CD Ptr
Decr this : Decr this
pCD=this
Incr @pCD.m_cRef
Function=@pCD.m_cRef
End Function
Function IConnectionPoint_Release(ByVal this As IConnectionPoint1 Ptr) As Long
Local pCD As CD Ptr
Prnt " Entering IConnectionPoint_Release()"
Decr this : Decr this
pCD=this
Decr @pCD.m_cRef
If @pCD.m_cRef=0 Then
Prnt " @pCD.m_cRef = 0 And Will Now Delete pCD!"
Call CoTaskMemFree(this)
Call InterlockedDecrement(g_lObjs)
End If
Prnt " Leaving IConnectionPoint_Release()"
Function=@pCD.m_cRef
End Function
Function IConnectionPoint_GetConnectionInterface(Byval this As IConnectionPoint1 Ptr, Byref iid As Guid) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPoint_GetConnectionPointContainer(Byval this As IConnectionPoint1 Ptr, Byval ppCPC As IConnectionPointContainer1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPoint_Advise(Byval this As IConnectionPoint1 Ptr, Byval pUnkSink As Dword Ptr, Byval pdwCookie As Dword Ptr) As Long
Local Vtbl As Dword Ptr
Local hr As Long
Prnt " Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!"
Prnt " pUnkSink = " & Str$(pUnkSink)
Prnt " @pUnkSink = " & Str$(@pUnkSink)
Vtbl=@pUnkSink
Prnt " Vtbl = " & Str$(Vtbl)
Prnt " @Vtbl[0] = " & Str$(@Vtbl[0])
Prnt " g_ptrOutGoing = " & Str$(g_ptrOutGoing) & " << Before Call Of QueryInterface() On Sink"
Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IOutGoing,Varptr(g_ptrOutGoing)) To hr
Prnt " g_ptrOutGoing = " & Str$(g_ptrOutGoing) & " << After Call Of QueryInterface() On Sink"
If SUCCEEDED(hr) Then
Prnt " Call Dword Succeeded!"
@pdwCookie=1
Else
@pdwCookie=0
End If
Prnt " Leaving IConnectionPoint_Advise() And Still In One Piece!"
Function=hr
End Function
Function IConnectionPoint_Unadvise(Byval this As IConnectionPoint1 Ptr, Byval dwCookie As Dword) As Long
Local Vtbl As Dword Ptr
Local iReturn As Long
Prnt "Entering IConnectionPoint_Unadvise()"
VTbl=@g_ptrOutGoing
Call Dword @Vtbl[2] Using ptrRelease(g_ptrOutGoing) To iReturn
Prnt " Release() Returned " & Str$(iReturn)
Prnt "Leaving IConnectionPoint_Unadvise()"
g_ptrOutGoing=0
Function=%NOERROR
End Function
Function IConnectionPoint_EnumConnections(Byval this As IConnectionPoint1 Ptr, Byval ppEnum As IEnumConnections1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
Call InterlockedIncrement(g_lObjs)
IClassFactory_AddRef=g_lObjs
End Function
Function IClassFactory_Release(ByVal this As IClassFactory1 Ptr) As Long
Call InterlockedDecrement(g_lObjs)
IClassFactory_Release=g_lObjs
End Function
Function IClassFactory_QueryInterface(ByVal this As IClassFactory1 Ptr, ByRef RefIID As Guid, ByVal pCF As Dword Ptr) As Long
Prnt " Entering IClassFactory_QueryInterface()"
Prnt " this = " & Str$(this)
@pCF=0
If RefIID=$IID_IUnknown Or RefIID=$IID_IClassFactory Then
Prnt " Somebody's Looking For IID_IUnknown Or IID_IClassFactory!"
Call IClassFactory_AddRef(this)
@pCF=this
Prnt " Leaving IClassFactory_QueryInterface()"
Function=%NOERROR
Exit Function
End If
Prnt " Whatever It Was They Were Looking For, We Ain't Got It!"
Prnt " Leaving IClassFactory_QueryInterface()"
Function=%E_NoInterface
End Function
Function IClassFactory_CreateInstance(ByVal this As IClassFactory1 Ptr, ByVal pUnknown As Dword, ByRef RefIID As Guid, Byval ppv As Dword Ptr) As Long
Local pComCtrl As IComCtrl Ptr
Local pCD As CD Ptr
Local hr As Long
Prnt " Entering IClassFactory_CreateInstance()"
@ppv=%NULL
If pUnknown Then
hr=%CLASS_E_NOAGGREGATION
Else
pCD=CoTaskMemAlloc(SizeOf(CD))
Prnt " pCD = " & Str$(pCD)
If pCD Then
@pCD.lpComCtrlVtbl = VarPtr(IComCtrl_Vtbl)
@pCD.lpICPCVtbl = VarPtr(IConnPointContainer_Vtbl)
@pCD.lpICPVtbl = Varptr(IConnPoint_Vtbl)
Prnt " Varptr(@pCD.lpComCtrlVtbl) = " & Str$(Varptr(@pCD.lpComCtrlVtbl))
Prnt " Varptr(@pCD.lpICPCVtbl) = " & Str$(Varptr(@pCD.lpICPCVtbl))
Prnt " Varptr(@pCD.lpICPVtbl) = " & Str$(Varptr(@pCD.lpICPVtbl))
@pCD.m_cRef=0
@pCD.hContainer=0 : @pCD.hControl=0
pComCtrl=pCD
Prnt " @ppv = " & Str$(@ppv) & " << Before QueryInterface() Call"
hr= IComCtrl_QueryInterface(pComCtrl,RefIID,ppv)
Prnt " @ppv = " & Str$(@ppv) & " << After QueryInterface() Call"
If SUCCEEDED(hr) Then
Call InterlockedIncrement(g_lObjs)
Else
Call CoTaskMemFree(pCD)
End If
Else
hr=%E_OutOfMemory
End If
End If
Prnt " Leaving IClassFactory_CreateInstance()"
IClassFactory_CreateInstance=hr
End Function
Function IClassFactory_LockServer(ByVal this As IClassFactory1 Ptr, Byval flock As Long) As Long
If flock Then
Call InterlockedIncrement(g_lLocks)
Else
Call InterlockedDecrement(g_lLocks)
End If
IClassFactory_LockServer=%NOERROR
End Function
Function DllCanUnloadNow Alias "DllCanUnloadNow" () Export As Long
Prnt "Entering DllCanUnloadNow()"
If g_lObjs = 0 And g_lLocks = 0 Then
Prnt " I'm Outta Here!"
Function=%S_OK
Else
Prnt " The System Wants Rid Of Me But I Won't Go!"
Function=%S_FALSE
End If
Prnt "Leaving DllCanUnloadNow()"
End Function
Function DllGetClassObjectImpl Alias "DllGetClassObject" (ByRef RefClsid As Guid, ByRef iid As Guid, ByVal pClassFactory As Dword Ptr) Export As Long
Local hr As Long
Prnt "Entering DllGetClassObjectImpl()"
If RefClsid=$CLSID_CD Then
IClassFactory_Vtbl.QueryInterface = CodePtr(IClassFactory_QueryInterface)
IClassFactory_Vtbl.AddRef = CodePtr(IClassFactory_AddRef)
IClassFactory_Vtbl.Release = CodePtr(IClassFactory_Release)
IClassFactory_Vtbl.CreateInstance = CodePtr(IClassFactory_CreateInstance)
IClassFactory_Vtbl.LockServer = CodePtr(IClassFactory_LockServer)
CDClassFactory.lpVtbl = VarPtr(IClassFactory_Vtbl)
Prnt " Varptr(CDClassFactory) = " & Str$(Varptr(CDClassFactory))
hr=IClassFactory_QueryInterface(VarPtr(CDClassFactory),iid,pClassFactory)
If SUCCEEDED(hr) Then
IComCtrl_Vtbl.QueryInterface = CodePtr(IComCtrl_QueryInterface)
IComCtrl_Vtbl.AddRef = CodePtr(IComCtrl_AddRef)
IComCtrl_Vtbl.Release = CodePtr(IComCtrl_Release)
IComCtrl_Vtbl.Initialize = CodePtr(IComCtrl_Initialize)
IComCtrl_Vtbl.CreateControl = CodePtr(IComCtrl_CreateControl)
IComCtrl_Vtbl.SetColor = CodePtr(IComCtrl_SetColor)
IComCtrl_Vtbl.GetColor = CodePtr(IComCtrl_GetColor)
IComCtrl_Vtbl.GetCtrlId = CodePtr(IComCtrl_GetCtrlId)
IComCtrl_Vtbl.GetHWND = CodePtr(IComCtrl_GetHWND)
IConnPointContainer_Vtbl.QueryInterface = CodePtr(IConnectionPointContainer_QueryInterface)
IConnPointContainer_Vtbl.AddRef = CodePtr(IConnectionPointContainer_AddRef)
IConnPointContainer_Vtbl.Release = CodePtr(IConnectionPointContainer_Release)
IConnPointContainer_Vtbl.EnumConnectionPoints = CodePtr(IConnectionPointContainer_EnumConnectionPoints)
IConnPointContainer_Vtbl.FindConnectionPoint = CodePtr(IConnectionPointContainer_FindConnectionPoint)
IConnPoint_Vtbl.QueryInterface = CodePtr(IConnectionPoint_QueryInterface)
IConnPoint_Vtbl.AddRef = CodePtr(IConnectionPoint_AddRef)
IConnPoint_Vtbl.Release = CodePtr(IConnectionPoint_Release)
IConnPoint_Vtbl.GetConnectionInterface = CodePtr(IConnectionPoint_GetConnectionInterface)
IConnPoint_Vtbl.GetConnectionPointContainer = CodePtr(IConnectionPoint_GetConnectionPointContainer)
IConnPoint_Vtbl.Advise = CodePtr(IConnectionPoint_Advise)
IConnPoint_Vtbl.Unadvise = CodePtr(IConnectionPoint_Unadvise)
IConnPoint_Vtbl.EnumConnections = CodePtr(IConnectionPoint_EnumConnections)
Prnt " IClassFactory_QueryInterface() Succeeded!"
Else
@pClassFactory=0
hr=%CLASS_E_CLASSNOTAVAILABLE
Prnt " IClassFactory_QueryInterface() Failed!"
End If
End If
Prnt "Leaving DllGetClassObjectImpl()"
Function=hr
End Function
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 szFileName 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
szClsid=GuidTxt$(ClassId)
szLibid=GuidTxt$(LibId)
If szClsid <> "" And szLibid <> "" Then
szKey="CLSID\" & szClsid
If IsFalse(SetKeyAndValue(szKey, Byval %NULL, szFriendlyName)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szKey, "InprocServer32", szFileName)) 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, szFriendlyName)) 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
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
Function DllRegisterServer Alias "DllRegisterServer" () Export As Long
Local strAsciPath,strWideCharPath,strPath As String
Local hr,iBytesReturned As Long
Local szPath As Asciiz*256
Local pTypeLib As ITypeLib
'Local fp As Integer
'fp=Freefile
'Open "C:\Code\PwrBasic\PBWin90\CD\Output.txt" For Output As #fp
'Print #fp, " Entering ExeRegisterServer()"
If GetModuleFileName(g_hModule, szPath, 256) Then
strPath=szPath
'Print #fp, " szPath = " strPath
strAsciPath=szPath
strWideCharPath=UCode$(strAsciPath & $Nul)
hr=LoadTypeLibEx(Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
If SUCCEEDED(hr) Then
'Print #fp, " LoadTypeLib() Succeeded!"
Set pTypeLib = Nothing
hr=RegisterServer(szPath, $CLSID_CD, $IID_LIBID_CD, g_szFriendlyName, g_szVerIndProgID, g_szProgID)
Else
Local dwFlags As Dword
Local szError As Asciiz*256
Local strError As String
'Print #fp, " LoadTypeLib() Failed!"
iBytesReturned= _
FormatMessage _
( _
dwFlags, _
Byval 0, _
hr, _
MAKELANGID(%LANG_NEUTRAL, %SUBLANG_DEFAULT), _
Byval Varptr(szError), _
256, _
Byval %NULL _
)
If iBytesReturned=0 Then
iBytesReturned=MsgBox("...And That Is To Use PBTyp.exe To Embed The Type Library In The Exe!", %MB_ICONWARNING, "I Know What You Forgot...")
End If
strError=szError
'Print #fp, " iBytesReturned = " iBytesReturned
'Print #fp, "szBuffer = " strError
End If
End If
'Print #fp, " Leaving ExeRegisterServer()"
'Close #fp
Function=hr
End Function
Function DllUnregisterServer Alias "DllUnregisterServer" () Export As Long
Local hr As Long
hr=UnRegisterTypeLib($IID_LIBID_CD, 1, 0, %LANG_NEUTRAL, %SYS_WIN32)
If SUCCEEDED(hr) Then
hr=UnregisterServer($CLSID_CD, g_szVerIndProgID, g_szProgID)
Else
MsgBox("UnRegisterTypeLib() Failed!")
End If
Function=hr
End Function
Function DllMain(ByVal hInstance As Long, ByVal fwdReason As Long, ByVal lpvReserved As Long) Export As Long
If fwdReason=%DLL_PROCESS_ATTACH Then
g_szFriendlyName = "Com Control CD"
g_szVerIndProgID = "ComCtrl.CD"
g_szProgID = "ComCtrl.CD.1"
g_hModule = hInstance
g_CtrlId = 1500
Call DisableThreadLibraryCalls(hInstance)
End If
DllMain=%TRUE
End Function
Added Later (9/21/2010):
Fixed problem with VB6, so ignore comments relating to that above.
Here is CD.zip which includes the above code as well as CD.tlb (needed to embed type library) and a PB9 client you can use once you've registered the CD.dll.
Here is a VB.NET project that seems to work perfectly. That amazed me. I expected problems due to the VB6 thing but at least for me this is working perfectly. I might even stop bad mouthing .NET at this point.
Hopefully you'll be able to recreate my project with only the attached several files. If you must recreate the project from scratch, the important thing is to bring up the 'References' dialog box where you'll have to select the 'COM' tab and find a reference to "COM Ctrl Typelib CD" or something like that.
Here's the VB6 project that doesn't work. What happens is the program starts completely normal and the control appears just like its supposed to in the picture box container I created for it. When you interact with the program in any way, even moving your mouse over the app, you'll get an immediate crash. I thought the problem might be something I did in the connection point code, but just today I removed the WithEvents keyword from the Dim statement that created the object in the VB program, figuring with the capacity removed to create a sink and receive events from the control, it might work. However, to my surprise, that didn't change anything. That gave me the idea that perhaps my error was somewhere in the more basic code involving the class factory or creating the object, so I studied that real close today without finding anything.
Added Later:
That problem was fixed (see several posts down in this thread). The above VB6 project works fine with the updated zip file code.
And here is an SDK style C++ host that I originally did in VC6 but just compiled using GNU CodeBlocks in the hope it would crash like the VB6 program, but no luck. It works perfect too. I'll also include the console window output from this where I clicked on he control once then closed out.
//C++
//Main.cpp
#include <windows.h>
#include <tchar.h>
#include <fcntl.h>
#include <io.h>
#include <stdio.h>
#include <ocidl.h>
#include "Main.h"
#include "CSink.h"
extern "C" const CLSID CLSID_CD ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x40}};
extern "C" const IID IID_ICOMCtrl ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x41}};
extern "C" const IID IID_IOutGoing ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x42}};
IConnectionPointContainer* pConnectionPointContainer=NULL;
IConnectionPoint* pConnectionPoint=NULL;
EVENTHANDLER EventHandler[3];
ICOMCtrl* pComCtrl=NULL;
DWORD dwCookie=NULL;
CSink* mySink=NULL;
long fnWndProc_OnCreate(lpWndEventArgs Wea)
{
HWND hButton,hContainer;
IUnknown* pUnk=0;
HRESULT hr;
FILE* hf;
int hCrt;
Wea->hIns=((LPCREATESTRUCT)Wea->lParam)->hInstance;
AllocConsole();
hCrt=_open_osfhandle((long)GetStdHandle(STD_OUTPUT_HANDLE),_O_TEXT);
hf = _fdopen( hCrt, "w" );
_iob[1]=*hf;
printf(_T("Entering fnWndProc_OnCreate()\n"));
hr=CoInitialize(NULL);
if(SUCCEEDED(hr))
{
printf(" CoInitialize() Succeeded!\n");
hr=CoCreateInstance(CLSID_CD,NULL,CLSCTX_INPROC_SERVER,IID_ICOMCtrl,(void**)&pComCtrl);
if(SUCCEEDED(hr))
{
printf(" CoCreateInstance() Succeeded! -- pComCtrl = %u\n",(unsigned)pComCtrl);
hr=pComCtrl->Initialize();
if(SUCCEEDED(hr))
{
printf(" pComCtrl->Initialize() Succeeded!\n");
hButton=CreateWindowEx(0,"button","Blue",WS_CHILD|WS_VISIBLE,8,10,80,25,Wea->hWnd,(HMENU)IDC_BUTTON1,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Green",WS_CHILD|WS_VISIBLE,8,40,80,25,Wea->hWnd,(HMENU)IDC_BUTTON2,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Red",WS_CHILD|WS_VISIBLE,8,70,80,25,Wea->hWnd,(HMENU)IDC_BUTTON3,Wea->hIns,0);
//hButton=CreateWindowEx(0,"button","Kill COM Control",WS_CHILD|WS_VISIBLE,203,100,120,25,Wea->hWnd,(HMENU)IDC_KILL_CD,Wea->hIns,0);
hContainer=CreateWindowEx(WS_EX_CLIENTEDGE,_T("static"),_T(""),WS_CHILD|WS_VISIBLE|WS_THICKFRAME,100,12,325,80,Wea->hWnd,(HMENU)1600,Wea->hIns,0);
hr=pComCtrl->QueryInterface(IID_IUnknown,(void**)&pUnk);
if(SUCCEEDED(hr))
{
printf(" Got IUnknown From CLSID_CD! -- pUnk = %u\n",(unsigned)pUnk);
hr = pUnk->QueryInterface(IID_IConnectionPointContainer, (void**)&pConnectionPointContainer);
if(SUCCEEDED(hr))
{
printf(" Got pConnectionPointContainer = %u\n",(unsigned)pConnectionPointContainer);
hr = pConnectionPointContainer->FindConnectionPoint(IID_IOutGoing, &pConnectionPoint);
if(SUCCEEDED(hr))
{
printf(" Got pConnectionPoint = %u\n",(unsigned)pConnectionPoint);
mySink = new CSink;
printf(" mySink = %u\n",(unsigned)mySink);
hr=pConnectionPoint->Advise((IUnknown*)mySink, &dwCookie);
if(SUCCEEDED(hr))
{
printf(" pConnectionPoint->Advise() Succeeded!\n");
hr=pComCtrl->CreateControl((int)hContainer);
if(SUCCEEDED(hr))
printf(" pComCtrl->CreateControl(hContainer) Succeeded!\n");
else
printf(" pComCtrl->CreateControl(hContainer) Failed!\n");
}
else
puts(" pConnectionPoint->Advise() Failed!");
}
else
printf(" Failed To Get pConnectionPoint!\n");
}
else
printf(" Failed To Get IConnectionPointContainer*\n");
pUnk->Release();
}
else
printf("QueryInterface(IUnknown) Failed!\n");
}
else
printf("pComCtrl->Initialize() Failed!\n");
}
else
printf(_T(" CoCreateInstance() Failed!\n"));
}
else
printf(_T(" CoInitialize() Failed!\n"));
printf(_T("Leaving fnWndProc_OnCreate()\n\n"));
return 0;
}
long fnWndProc_OnCommand(lpWndEventArgs Wea)
{
switch(LOWORD(Wea->wParam))
{
case IDC_BUTTON1:
pComCtrl->SetColor((int)RGB(0,0,255));
break;
case IDC_BUTTON2:
pComCtrl->SetColor((int)RGB(0,255,0));
break;
case IDC_BUTTON3:
pComCtrl->SetColor((int)RGB(255,0,0));
break;
}
return 0;
}
long fnWndProc_OnClose(lpWndEventArgs Wea)
{
printf(_T("Entering fnWndProc_OnClose()\n"));
if(dwCookie && pConnectionPoint)
pConnectionPoint->Unadvise(dwCookie);
if(pConnectionPoint)
pConnectionPoint->Release();
if(pConnectionPointContainer)
pConnectionPointContainer->Release();
if(pComCtrl)
pComCtrl->Release();
delete mySink;
CoUninitialize();
printf(_T("Leaving fnWndProc_OnClose()\n\n"));
MessageBox
(
Wea->hWnd,
_T("Have Just Released Object! You Can Copy The Output From The Console If You Want Though!"),
_T("Will Close App!"),
MB_OK
);
DestroyWindow(Wea->hWnd);
PostQuitMessage(0);
return 0;
}
void AttachEventHandlers(void) //This procedure maps windows messages to the
{ //procedure which handles them.
EventHandler[0].Code=WM_CREATE, EventHandler[0].fnPtr=fnWndProc_OnCreate;
EventHandler[1].Code=WM_COMMAND, EventHandler[1].fnPtr=fnWndProc_OnCommand;
EventHandler[2].Code=WM_CLOSE, EventHandler[2].fnPtr=fnWndProc_OnClose;
}
long __stdcall fnWndProc(HWND hwnd, unsigned int msg, WPARAM wParam,LPARAM lParam)
{
WndEventArgs Wea; //This procedure loops through the EVENTHANDER array
//of structs to try to make a match with the msg parameter
for(unsigned int i=0; i<3; i++) //of the WndProc. If a match is made the event handling
{ //procedure is called through a function pointer -
if(EventHandler[i].Code==msg) //(EventHandler[i].fnPtr). If no match is found the
{ //msg is passed onto DefWindowProc().
Wea.hWnd=hwnd, Wea.lParam=lParam, Wea.wParam=wParam;
return (*EventHandler[i].fnPtr)(&Wea);
}
}
return (DefWindowProc(hwnd, msg, wParam, lParam));
}
int __stdcall WinMain(HINSTANCE hIns, HINSTANCE hPrevIns, LPSTR lpszArgument, int iShow)
{
TCHAR szClassName[]=_T("C++ Visual COM Control Demo");
WNDCLASSEX wc;
MSG messages;
HWND hWnd;
AttachEventHandlers();
wc.lpszClassName=szClassName; wc.lpfnWndProc=fnWndProc;
wc.cbSize=sizeof (WNDCLASSEX); wc.style=CS_DBLCLKS;
wc.hIcon=LoadIcon(NULL,IDI_APPLICATION); wc.hInstance=hIns;
wc.hIconSm=LoadIcon(NULL, IDI_APPLICATION); wc.hCursor=LoadCursor(NULL,IDC_ARROW);
wc.hbrBackground=(HBRUSH)COLOR_BTNSHADOW; wc.cbWndExtra=0;
wc.lpszMenuName=NULL; wc.cbClsExtra=0;
RegisterClassEx(&wc);
hWnd=CreateWindowEx(0,szClassName,szClassName,WS_OVERLAPPEDWINDOW,400,550,440,140,HWND_DESKTOP,0,hIns,0);
ShowWindow(hWnd,iShow);
while(GetMessage(&messages,NULL,0,0))
{
TranslateMessage(&messages);
DispatchMessage(&messages);
}
return messages.wParam;
}
Main.h
//Main.h
#define IDC_BUTTON1 1300 //Control ID For Blue' Button
#define IDC_BUTTON2 1305 //Control ID For Green' Button
#define IDC_BUTTON3 1310 //Control ID For Red' Button
#define IDC_KILL_CD 1315 //Control ID For Kill CD
interface ICOMCtrl : IUnknown
{
virtual HRESULT __stdcall Initialize ( )=0;
virtual HRESULT __stdcall CreateControl (const int)=0;
virtual HRESULT __stdcall SetColor (int )=0;
virtual HRESULT __stdcall GetColor (int* )=0;
virtual HRESULT __stdcall GetCtrlId (int* )=0;
virtual HRESULT __stdcall GetHWND (int* )=0;
};
typedef struct WindowsEventArguments
{
HWND hWnd;
WPARAM wParam;
LPARAM lParam;
HINSTANCE hIns;
}WndEventArgs, *lpWndEventArgs;
struct EVENTHANDLER
{
unsigned int Code;
long (*fnPtr)(lpWndEventArgs);
};
//CSink.h
#ifndef CSINK_H
#define CSINK_H
interface IOutGoing : IUnknown //IOutGoing
{
virtual HRESULT __stdcall ControlEvent(int) = 0;
};
class CSink : public IOutGoing //CSink
{
public:
CSink();
~CSink() { }
HRESULT __stdcall QueryInterface(REFIID iid, void** ppv);
ULONG __stdcall AddRef(); //IUnknown
ULONG __stdcall Release();
HRESULT __stdcall ControlEvent(int Message); //IOutGoing
private:
long m_cRef;
};
#endif
//CSink.cpp
#include <windows.h>
#include <tchar.h>
#include <stdio.h>
#include <ocidl.h>
#include "Main.h"
#include "CSink.h"
extern ICOMCtrl* pComCtrl;
extern "C" const IID IID_IOutGoing;
CSink::CSink() : m_cRef(0)
{
printf(_T("Entering CSink Constructor!\n"));
printf(_T(" this = %u\n"),this);
printf(_T("Leaving CSink Constructor!\n"));
}
ULONG CSink::AddRef()
{
return ++m_cRef;
}
ULONG CSink::Release()
{
printf("Entering CSink::Release()\n");
printf(_T(" this = %u\n"),this);
if(--m_cRef != 0)
{
printf(" m_cRef != 0 : m_cRef=%u\n",m_cRef);
return m_cRef;
}
else
{
printf(" m_cRef == 0 And Will Now Delete CSink!\n");
//delete this;
}
printf("Leaving CSink::Release()\n");
return 0;
}
HRESULT CSink::QueryInterface(REFIID riid, void** ppv)
{
printf(" Entering CSink::QueryInterface() -- this = %u\n",this);
if(riid == IID_IUnknown)
{
*ppv = (IUnknown*)this;
}
else if(riid == IID_IOutGoing)
{
printf(" Client: CSink::QueryInterface() for IOutGoing -- this = %u\n", (IOutGoing*)this);
*ppv = (IOutGoing*)this;
printf(" *ppv = %u\n", *ppv);
}
else
{
*ppv = NULL;
return E_NOINTERFACE;
}
AddRef();
printf(" Leaving CSink::QueryInterface()\n");
return S_OK;
}
HRESULT CSink::ControlEvent(int Message)
{
TCHAR szBuffer[256],szTmp[64];
int iColor,iCtlId,iWndHdl;
HWND hContainer,hMain;
_tprintf(_T("\nEntering CSink::ControlEvent()\n"));
printf(" CSink::ControlEvent is %u\n", Message);
switch(Message)
{
case WM_CREATE:
printf(" WM_CREATE\n");
break;
case WM_CHAR:
printf(" WM_CHAR\n");
break;
case WM_LBUTTONDOWN:
printf(" WM_LBUTTONDOWN\n");
pComCtrl->GetColor(&iColor);
pComCtrl->GetCtrlId(&iCtlId);
pComCtrl->GetHWND(&iWndHdl);
hContainer=GetParent((HWND)iWndHdl);
hMain=GetParent(hContainer);
_tprintf(_T(" hContainer = %u\n"),hContainer);
_tprintf(_T(" hMain = %u\n"),hMain);
if(iColor==(int)RGB(0,0,255))
_tcscpy(szBuffer,_T("The COM Control Is Blue! Its Control ID Is\r\n"));
if(iColor==(int)RGB(255,255,0))
_tcscpy(szBuffer,_T("The COM Control Is Yellow! Its Control ID Is\r\n"));
if(iColor==(int)RGB(0,255,0))
_tcscpy(szBuffer,_T("The COM Control Is Green! Its Control ID Is\r\n"));
if(iColor==(int)RGB(255,0,0))
_tcscpy(szBuffer,_T("The COM Control Is Red! Its Control ID Is\r\n"));
_stprintf(szTmp,_T("%u"),iCtlId);
_tcscat(szBuffer,szTmp);
_tcscat(szBuffer,_T(" And Its HWND Is "));
_stprintf(szTmp,_T("%u"),iWndHdl);
_tcscat(szBuffer,szTmp);
_tcscat(szBuffer,_T("."));
MessageBox(hMain,szBuffer,_T("Report From Control!"),MB_OK);
break;
case WM_CLOSE:
printf(" WM_CLOSE\n");
break;
}
printf("Leaving CSink::GotMessage()\n\n");
return S_OK;
}
Here is the output from the console window from above...
Entering fnWndProc_OnCreate()
CoInitialize() Succeeded!
Entering DllGetClassObjectImpl()
Varptr(CDClassFactory) = 10860532
Entering IClassFactory_QueryInterface()
this = 10860532
Somebody's Looking For IID_IUnknown Or IID_IClassFactory!
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pCD = 2446624
Varptr(@pCD.lpComCtrlVtbl) = 2446624
Varptr(@pCD.lpICPCVtbl) = 2446628
Varptr(@pCD.lpICPVtbl) = 2446632
@ppv = 0 << Before QueryInterface() Call
Entering IComCtrl_QueryInterface()
Trying To Get IComCtrl
this = 2446624
Leaving IComCtrl_QueryInterface()
@ppv = 2446624 << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Entering IComCtrl_QueryInterface()
Trying To Get IComCtrl
this = 2446624
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
CoCreateInstance() Succeeded! -- pComCtrl = 2446624
Entering IComCtrl_Initialize()
this = 2446624
Leaving IComCtrl_Initialize()
pComCtrl->Initialize() Succeeded!
Entering IComCtrl_QueryInterface()
Trying To Get IUnknown
this = 2446624
Leaving IComCtrl_QueryInterface()
Got IUnknown From CLSID_CD! -- pUnk = 2446624
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPointContainer
this = 2446624
this = 2446628
Leaving IComCtrl_QueryInterface()
Got pConnectionPointContainer = 2446628
Entering IConnectionPointContainer_FindConnectionPoint()
this = 2446628
@ppCP = 0
@ppCP = 2446632
Leaving IConnectionPointContainer_FindConnectionPoint()
Got pConnectionPoint = 2446632
Entering CSink Constructor!
this = 9775280
Leaving CSink Constructor!
mySink = 9775280
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
pUnkSink = 9775280
@pUnkSink = 4226576
Vtbl = 4226576
@Vtbl[0] = 4202364
g_ptrOutGoing = 0 << Before Call Of QueryInterface() On Sink
Entering CSink::QueryInterface() -- this = 9775280
Client: CSink::QueryInterface() for IOutGoing -- this = 9775280
*ppv = 9775280
Leaving CSink::QueryInterface()
g_ptrOutGoing = 9775280 << After Call Of QueryInterface() On Sink
Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!
pConnectionPoint->Advise() Succeeded!
Entering IComCtrl_CreateControl()
this = 2446624
Leaving IComCtrl_CreateControl()
pComCtrl->CreateControl(hContainer) Succeeded!
Entering IComCtrl_Release()
@pCD.m_cRef = 4
Leaving IComCtrl_Release()
Leaving fnWndProc_OnCreate()
WM_LBUTTONDOWN
g_ptrOutGoing = 9775280
@Vtbl = 4202364
@Vtbl[0] = 4202364
Entering CSink::ControlEvent()
CSink::ControlEvent is 513
WM_LBUTTONDOWN
hContainer = 329166
hMain = 853550
Leaving CSink::GotMessage()
Entering fnWndProc_OnClose()
Entering IConnectionPoint_Unadvise()
Entering CSink::Release()
this = 9775280
m_cRef == 0 And Will Now Delete CSink!
Leaving CSink::Release()
Release() Returned 0
Leaving IConnectionPoint_Unadvise()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IComCtrl_Release()
@pCD.m_cRef = 1
@pCD.m_cRef = 0
CD Was Deleted!
Leaving IComCtrl_Release()
Leaving fnWndProc_OnClose()
Finally, I'll attach my entire Visual Studio 6 C project that I did before the PowerBASIC project. The PowerBASIC project is an exact translation of this one, although this one works perfect in Visual Basic 6. Also, these both can be registered because it uses different CLSIDs and program IDs than the PB project's numbers. This is CE not CD. The code in Main.c is pretty much what's in CD.bas.
On the way home from work today a thought occurred to me. I had been studying the console output from the COM object when VB6 crashes, and I noted two QueryInterface calls VB was making for interfaces I didn't support in my object. It wouldn't surprise me if those calls related to some of the IEnumConnectionPoint functionality I wasn't supporting, but was returning E_NOTIMPL. However, pointers to those interfaces appear as parameters in my various IConnectionPointContainer and IConnectionPoint interfaces. I got off easy with my C program and had to do nothing to support those data types because they are in various C headers included anyway. However, in my PowerBASIC code I had to deal with them even though I wasn't using those variable types. At first I thought I'd try to get away with just defining them as pointers figuring it didn't much matter what they were pointing to since I was returning E_NOTIMPL from the functions, but when I started getting the VB6 crashes I translated the Interfaces and made pointers to them. Perhaps I messed that up somehow. I'm not going to have much time to work with this over the next couple days, but as soon as I can I'm gonna put calls for those interfaces in the C++ program and see if that is causing the problem. Here is the console output from VB 6 when it goes belly up...
Entering DllGetClassObjectImpl()
Varptr(CDClassFactory) = 20101108
Entering IClassFactory_QueryInterface()
this = 20101108
Somebody's Looking For IID_IUnknown Or IID_IClassFactory!
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pCD = 1343400
Varptr(@pCD.lpComCtrlVtbl) = 1343400
Varptr(@pCD.lpICPCVtbl) = 1343404
Varptr(@pCD.lpICPVtbl) = 1343408
@ppv = 0 << Before QueryInterface() Call
Entering IComCtrl_QueryInterface()
Trying To Get IUnknown
this = 1343400
Leaving IComCtrl_QueryInterface()
@ppv = 1343400 << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Entering IComCtrl_QueryInterface()
Trying To Get IUnknown
this = 1343400
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_QueryInterface()
Trying To Get IComCtrl
this = 1343400
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_QueryInterface()
Looking For Something I Ain't Got!
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_QueryInterface()
Looking For Something I Ain't Got!
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 3
Leaving IComCtrl_Release()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPointContainer
this = 1343400
this = 1343404
Leaving IComCtrl_QueryInterface()
Entering IConnectionPointContainer_FindConnectionPoint()
this = 1343404
@ppCP = 0
@ppCP = 1343408
Leaving IConnectionPointContainer_FindConnectionPoint()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
pUnkSink = 1283888
@pUnkSink = 4201212
Vtbl = 4201212
@Vtbl[0] = 4198916
g_ptrOutGoing = 0 << Before Call Of QueryInterface() On Sink
g_ptrOutGoing = 1283888 << After Call Of QueryInterface() On Sink
Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Entering IComCtrl_Initialize()
this = 1343400
Leaving IComCtrl_Initialize()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Entering IComCtrl_CreateControl()
this = 1343400
Leaving IComCtrl_CreateControl()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Quote
Looking For Something I Ain't Got!
Leaving IComCtrl_QueryInterface()
It is very easy to find out what intefaces it is looking for. Just record the Guid and look it up.
It is probably an interface that is optional or IMarshalXXX. If it, however, is an interface that
was once required, you will have to implement it.
I have not yet found the time to look at your code, but are the intefaces in your control dual?
If they are not, then they should be.
The interfaces are not dual but I'm not completely opposed to adding that support, even though I have no use for it. This is the idl...
// CD.idl
import "unknwn.idl";
[object, uuid(20000000-0000-0000-0000-000000000041), oleautomation]
interface IComCtrl : IUnknown
{
HRESULT Initialize ( );
HRESULT CreateControl([in] int hParent );
HRESULT SetColor ([in] int iColor );
HRESULT GetColor ([out, retval] int* iColor );
HRESULT GetCtrlId ([out, retval] int* iCtrlId);
HRESULT GetHWND ([out, retval] int* hWnd );
}
[object, uuid(20000000-0000-0000-0000-000000000042), oleautomation]
interface IOutGoing : IUnknown
{
HRESULT ControlEvent(int Message);
}
[uuid(20000000-0000-0000-0000-000000000043), helpstring("COM Ctrl TypeLib CD"), version(1.0)]
library CDLibrary
{
importlib("stdole32.tlb");
interface IComCtrl;
interface IOutGoing;
[uuid(20000000-0000-0000-0000-000000000040)]
coclass CD
{
interface IComCtrl;
[source] interface IOutGoing;
}
};
I chose not to implement IDispatch because my understanding is that even though it is highly recommended to support it, it is not an absolute necessity (I have sources supporting that view). My goal in creating this code was to explore alternate vehicles besides custom controls for encapsulating functionality in my Windows programming. I don't do anything with scripting languages or the internet. What I learned about this stuff came from an example not closely related at all to my code here. It was an example using connectable objects that used two Exe out of process servers that pumped characters between the consoles. It did work with Visual Basic though, and it didn't support IDispatch either. That's why I didn't fool with it.
Having said that though, if implementing IDispatch would solve my VB6 crash problem, I'd likely get at it 1st thing Monday morning. I don't think that's the problem though, because my C program works perfectly with everything I've tested it with, and it doesn't implement dual interfaces. Nope, I've made a mistake somewhere in the C to PB conversion, thinks I.
FUNCTION XXX_QueryInterface(...)
...
SELECT CASE iid
...
CASE $IID_ICONNECTIONPOINT
...
FUNCTION=%S_OK
EXIT FUNCTION
END SELECT
...
END FUNCTION
Remove all occurrences of QueryInterface on IConnectionPoint in your code, the server should
not allow a QueryInterface on an outgoing interface. Did you read the Bible on OLE?
Remember this call by the client?
IConnectionPointContainer::FindConnectionPoint
FUNCTION DllGetClassObjectImpl ALIAS "DllGetClassObject" ...
LOCAL hr AS LONG
...
Prnt "Entering DllGetClassObjectImpl()"
IF RefClsid=$CLSID_CD OR RefClsid=$IID_ICLASSFACTORY THEN
Under what circumstances would you see the value of RefClsid being IID_ICLASSFACTORY in here?
In my opinion, this stuff
IComCtrl_Vtbl.QueryInterface = CODEPTR(IComCtrl_QueryInterface)
IComCtrl_Vtbl.AddRef = CODEPTR(IComCtrl_AddRef)
IComCtrl_Vtbl.Release = CODEPTR(IComCtrl_Release)
IComCtrl_Vtbl.Initialize = CODEPTR(IComCtrl_Initialize)
should be done in IClassFactory::CreateInstance.
I think DllGetClassObject should be concentrating on returning a class factory for the requested class
and not be bothered with setting up virtual tables. Where was IComCtrl created?
Thanks for taking the time to examine this Dominic! I appreciate it. Since I posted it all last Friday (9/1) I havn't had much time to work with it due to some family matters needing to be attended to, but tomorrow I want to get once more back at it. About your last comment though about where I had initialized the VTables in DllGetClassObject(), I wasn't sure the best place to do that, but it occurred to me that any client would likely only call DllGetClassObject() once (or COM would do it on behalf of a client once), whereas if that code was in IClassFactory::CreateInstance(), this initialization could occur every time a client created an instance of the control. This wouldn't hurt anything because none of those addresses would change, but it just seemed to me to be unnecessary extra effort if that scenerio occurred.
I'll be thinking about your other comments and will get back tomorrow.
Well, I solved the problem completely and with 100% certainty. I now know why the VB6 crash was occurring, and in truth its surprising the others weren't too. Like I suspected, it was a dumb error on my part and I was right when I said I'm going to take a beating solving this. I did. My guess is it cost me 14 hours, and that doesn't include musing on the problem while not directly working on it.
Since I'm relatively new to using Connection Points I was figuring the problem was there somewhere, but it wasn't. I wasted a lot of time making absolutely certain my Call Dword stuff in Advise() and Unadvise() was right. It all was. What finally got me to suspecting that the problem was elsewhere was when I removed the WithEvents part of the Dim statement in the VB6 app that instantiated the ComCtrl, and it still crashed. I thought it would work once I removed that term and there was no more exchange of pointers.
Seeing that it was still crashing I decided to strip the code down to a bare nothing to see how far I had to rip stuff out until it finally worked. I ripped out all the connection point code, the window procedure for the COM Control, everything. It was still crashing. At that point the code bulk was down to about half and I realized the problem must be in the boilerplate COM Dll setup code involving the Class Factory and the exported functions. For quite some time I had been casting an evil eyeball on DllCanUnloadNow(), and I even put output statements in it to see when it was being called. The crashes I was getting made me wonder in COM was unloading the Dll prematurely. Here is the code for DllCanUnloadNow()...
Function DllCanUnloadNow Alias "DllCanUnloadNow" () Export As Long
If g_lObjs Or g_lLocks Then
Prnt " The System Wants Rid Of Me But I Won't Go!"
Function=%FALSE
Else
Prnt " I'm Outta Here!"
Function=%TRUE
End If
End Function
Well, here is what I have in CD.c which works...
HRESULT __stdcall DllCanUnloadNow()
{
if(g_lObjs||g_lLocks)
return S_FALSE;
else
return S_OK;
}
Not exactly the same, but close. Close until you check out the values of those equates with this little PB CC program...
'#Compile Exe
'#Dim All
'#Include "Win32Api.inc"
'Function PBMain() As Long
' Print "%TRUE = " %TRUE
' Print "%S_OK = " %S_OK
' Print "%FALSE = " %FALSE
' Print "%S_FALSE = " %S_FALSE
' Waitkey$
' PBMain=0
'End Function
'%TRUE = 1
'%S_OK = 0
'%FALSE = 0
'%S_FALSE = 1
How 'bout that!
So the fixed procedure should be something like this...
Function DllCanUnloadNow Alias "DllCanUnloadNow" () Export As Long
Prnt "Entering DllCanUnloadNow()"
If g_lObjs = 0 And g_lLocks = 0 Then
Prnt " I'm Outta Here!"
Function=%S_OK
Else
Prnt " The System Wants Rid Of Me But I Won't Go!"
Function=%S_FALSE
End If
Prnt "Leaving DllCanUnloadNow()"
End Function
Hi Dominic!
Thanks for spotting that $IID_IClassFactory in DllGetClassObjectImpl(). You're right of course. It shouldn't be there.
In terms of this comment though...
Quote
Remove all occurrences of QueryInterface on IConnectionPoint in your code, the server should
not allow a QueryInterface on an outgoing interface. Did you read the Bible on OLE?
I can't do that. According to the 'Transitive Rule' of QueryInterface, if one has an interface
pointer on an object supporting multiple interfaces, one should be able to navigate to any other interface
supported by the object. My object contains three interfaces, i.e., IComCtrl, IConnectionPointContainer,
and IConnectionPoint. I need QueryInterface functionality on all those interfaces so as to navigate between
them. What am I not understanding, or am I not understanding your comment?
I made those corrections discussed above and re-attached the corrected code in the original CD.zip in the 2nd post of this thread. There had been three downloads of the original zip, so those who downloaded it might want the updated files.
So at this point it looks like its working with PB 9, C++, VB6 and VB.NET.
Quote
I can't do that. According to the 'Transitive Rule' of QueryInterface, if one has an interface
pointer on an object supporting multiple interfaces, one should be able to navigate to any other interface
supported by the object.
That does not apply to outgoing interfaces. The object should ignore QueryInteface calls for
outgoing interfaces.
Why do you think the following method exists?
IConnectionPointContainer::FindConnectionPoint
Anyway, each object can have as many outgoing interfaces as it sees fit.
Each one of those outgoing interfaces is managed by an IConnectionPoint interface.
So, for example, given the following scenario for an object:
$DIID_ITREEEVENTS $IID_IPROPERTYNOTIFYSINK
| |
IConnectionPoint 1 IConnectionPoint 2
Can you explain to me how QueryInterface(IID_ICONNECTIONPOINT) on this control will return a meaningful value?
Also, your class factory code is raising a lot of red flags for me. I will have to take a closer look at it.
Ahh! It just sank in what you are saying Dominic. Perhaps I didn't get it right away because I wasn't doing in my clients what you are saying my COM object is allowing, that is, making a direct QueryInterface for IConnectionPoint from perhaps the initial IUnknown or IComControl interfaces. In my fifth post is the only low level client I posted and that is the C++ program and there I got my initial IUnknown/IComControl pointer, queried for IConnectionPointContainer off of it, called IConnectionPointContainer::FindConnectionPoint, then called IConnectionPoint::Advise, just like its supposed to be I believe. But the setup as I have it now would allow for a QueryInterface for IConnectionPoint right off the initial IUnknown pointer. I've gotta go to bed now as its late here, but tomorrow I'll look at that and can probably easily fix it. That will actually reduce the code bulk I believe.
Well, I tried to do what Dominic is recommending but it isn't working. Before I get into the details, let me first describe what my understanding is of what Dominic is recommending. He is saying that an object should not support a QueryInterface() call for IID_IConnectionPoint because the IConnectionPointContainer::FindConnectionPoint() method was designed to produce that interface pointer. I agree with that so I commented out the Case clause of my IComCtrl_QueryInterface() function containing the code to return a IConnectionPoint pointer so that E_NOINTERFACE would be returned if that request was made (see below)....
Function IComCtrl_QueryInterface(ByVal this As IComCtrl Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
Prnt " Entering IComCtrl_QueryInterface()"
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Prnt " Trying To Get IUnknown"
Call IComCtrl_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Prnt " Trying To Get IComCtrl"
Call IComCtrl_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Prnt " Trying To Get IConnectionPointContainer"
Prnt " this = " & Str$(this)
Incr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
'Case $IID_IConnectionPoint
' Prnt " Trying To Get IConnectionPoint"
' Prnt " this = " & Str$(this)
' Incr this : Incr this
' @ppv=this
' Call IConnectionPoint_AddRef(this)
' Prnt " this = " & Str$(this)
' Prnt " Leaving IComCtrl_QueryInterface()"
' Function=%S_OK
' Exit Function
Case Else
Prnt " Looking For Something I Ain't Got!"
Prnt " Leaving IComCtrl_QueryInterface()"
End Select
Function=%E_NoInterface
End Function
When I recompiled and attempted to run the VB.NET program it crashed, and here is the error report it gave me...
An unhandled exception of type 'System.InvalidOperationException' occurred in prjCD.exe
Additional information: An error occurred creating the form. See Exception.InnerException for details.
The error is: Unable to cast COM object of type 'CDLibrary.CDClass' to interface type
'System.Runtime.InteropServices.ComTypes.IConnectionPoint'.
This operation failed because the QueryInterface call on the COM component for the interface with IID
'{B196B286-BAB4-101A-B69C-00AA00341D07}' failed due to the following error: No such interface supported
(Exception from HRESULT: 0x80004002 (E_NOINTERFACE)).
So I uncommented those lines back 'in', recompiled, and ran the .NET program again. Below is the rather lengthy output from that run. Check out about 55% of the way down in this output where I have several method calls blocked out with five spaces on either side so as to highlight them. What is really odd is that .NET is making that IComCtrl_QueryInterface(IID_IConnectionPoint) call after it has already called IConnectionPointContainer::FindConnectionPoint() and already has a IConnectionPoint pointer from that!
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 53196788
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_AddRef()
g_lObjs = 2
Leaving IClassFactory_AddRef()
Entering IClassFactory_Release()
g_lObjs = 1
Leaving IClassFactory_Release()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 2
Leaving IClassFactory_AddRef()
this = 53196788
Leaving IClassFactory_QueryInterface()
Entering IClassFactory_Release()
g_lObjs = 1
Leaving IClassFactory_Release()
Entering IClassFactory_QueryInterface()
Leaving IClassFactory_QueryInterface() Empty Handed!
Entering IClassFactory_CreateInstance()
pCD = 1667768
Varptr(@pCD.lpComCtrlVtbl) = 1667768
Varptr(@pCD.lpICPCVtbl) = 1667772
Varptr(@pCD.lpICPVtbl) = 1667776
@ppv = 0 << Before QueryInterface() Call
Entering IComCtrl_QueryInterface()
Trying To Get IUnknown
Entering IComCtrl_AddRef()
@pCD.m_cRef = 1
Leaving IComCtrl_AddRef()
this = 1667768
Leaving IComCtrl_QueryInterface()
@ppv = 1667768 << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()
Entering IComCtrl_QueryInterface()
Trying To Get IUnknown
Entering IComCtrl_AddRef()
@pCD.m_cRef = 2
Leaving IComCtrl_AddRef()
this = 1667768
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_QueryInterface()
Looking For Something I Ain't Got!
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 3
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Looking For Something I Ain't Got!
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 4
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Looking For Something I Ain't Got!
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 4
Leaving IComCtrl_Release()
Entering IComCtrl_Release()
@pCD.m_cRef = 3
Leaving IComCtrl_Release()
Entering IClassFactory_Release()
g_lObjs = 1
Leaving IClassFactory_Release()
Entering IComCtrl_Release()
@pCD.m_cRef = 2
Leaving IComCtrl_Release()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 2
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPointContainer
this = 1667768
this = 1667772
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 3
Leaving IComCtrl_Release()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 3
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPointContainer
this = 1667768
this = 1667772
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 4
Leaving IComCtrl_Release()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IConnectionPointContainer_FindConnectionPoint()
this = 1667772
@ppCP = 0
Entering IConnectionPointContainer_QueryInterface()
Looking For IID_IConnectionPoint
Leaving IConnectionPointContainer_QueryInterface()
@ppCP = 1667776
Leaving IConnectionPointContainer_FindConnectionPoint()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 5
Leaving IComCtrl_AddRef()
Entering IComCtrl_Release()
@pCD.m_cRef = 5
Leaving IComCtrl_Release()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 5
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPoint
this = 1667768
this = 1667776
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 6
Leaving IComCtrl_Release()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 6
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPoint
this = 1667768
this = 1667776
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 7
Leaving IComCtrl_Release()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
pUnkSink = 53280812
@pUnkSink = 3548000
Vtbl = 3548000
@Vtbl[0] = 2046397480
g_ptrOutGoing = 0 << Before Call Of QueryInterface() On Sink
g_ptrOutGoing = 53280816 << After Call Of QueryInterface() On Sink
Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 4
Leaving IComCtrl_AddRef()
Entering IComCtrl_QueryInterface()
Trying To Get IComCtrl
Entering IComCtrl_AddRef()
@pCD.m_cRef = 5
Leaving IComCtrl_AddRef()
this = 1667768
Leaving IComCtrl_QueryInterface()
Entering IComCtrl_Release()
@pCD.m_cRef = 5
Leaving IComCtrl_Release()
Entering IComCtrl_AddRef()
@pCD.m_cRef = 5
Leaving IComCtrl_AddRef()
Entering IComCtrl_Initialize()
this = 1667768
Leaving IComCtrl_Initialize()
Entering IComCtrl_Release()
@pCD.m_cRef = 5
Leaving IComCtrl_Release()
Entering IComCtrl_CreateControl()
this = 1667768
Leaving IComCtrl_CreateControl()
Entering IComCtrl_SetColor()
Leaving IComCtrl_SetColor()
WM_LBUTTONDOWN
g_ptrOutGoing = 53280816
This problem only occurred with .NET. VB6 tolerated it as well as my PowerBASIC and C++ clients.
After Dominic made his comment about this and it finally dawned on me what he was saying I thought back to the Connection Points example I had followed in Guy And Henry Eddon's book "Inside Distributed COM" from Microsoft Press, and I realized that example probably didn't provide a IConnectionPoint* either in its QueryInterface, and I had provided it in my CD.bas just through over zealousness and wanting to support all interface calls. When I looked, however, I found that IID_IConnectionPoint was supported in that example, although due to the way C++ sets up Vtables its not entirely or even partially analogous to my code. Here is that C++ code...
//local.cpp -- Compile: cl local.cpp component_i.c registry.cpp /FeComponent.exe UUID.lib Advapi32.lib Ole32.lib oleaut32.lib component.obj
#define _WIN32_DCOM
#include <stdio.h>
#include <olectl.h>
#include "component.h" // Generated by MIDL
#include "registry.h" // Add This!!!
long g_cComponents = 0;
long g_cServerLocks = 0;
HANDLE g_hEvent;
IOutGoing* g_pOutGoing = 0;
class CInsideDCOM : public ISum, IConnectionPointContainer, IConnectionPoint
{
public:
//IUnknown
ULONG __stdcall AddRef();
ULONG __stdcall Release();
HRESULT __stdcall QueryInterface(REFIID iid, void** ppv);
//ISum
HRESULT __stdcall Sum(int x, int y, int* retval);
//IConnectionPointContainer
HRESULT __stdcall EnumConnectionPoints(IEnumConnectionPoints** ppEnum);
HRESULT __stdcall FindConnectionPoint(REFIID riid, IConnectionPoint** ppCP);
//IConnectionPoint
HRESULT __stdcall GetConnectionInterface(IID* pIID);
HRESULT __stdcall GetConnectionPointContainer(IConnectionPointContainer** ppCPC);
HRESULT __stdcall Advise(IUnknown* pUnknown, DWORD* pdwCookie);
HRESULT __stdcall Unadvise(DWORD dwCookie);
HRESULT __stdcall EnumConnections(IEnumConnections** ppEnum);
CInsideDCOM() : m_cRef(0) { g_cComponents++; }
~CInsideDCOM()
{
puts("Component: CInsideDCOM::~CInsideDCOM()\n");
g_cComponents--;
}
private:
long m_cRef;
};
ULONG CInsideDCOM::AddRef()
{
printf("Component: CInsideDCOM::AddRef() m_cRef = %u\n", m_cRef + 1);
return ++m_cRef;
}
ULONG CInsideDCOM::Release()
{
printf("Component: CInsideDCOM::Release() m_cRef = %u\n", m_cRef - 1);
if(--m_cRef != 0)
return m_cRef;
SetEvent(g_hEvent);
delete this;
return 0;
}
HRESULT CInsideDCOM::QueryInterface(REFIID riid, void** ppv)
{
if(riid == IID_IUnknown)
{
*ppv = reinterpret_cast<IUnknown*>(this);
printf("CInsideDCOM::QueryInterface(IID_IUnknown) = %u\n",*ppv);
}
else if(riid == IID_ISum)
{
*ppv = (ISum*)this;
printf("CInsideDCOM::QueryInterface(IID_ISum) = %u\n",*ppv);
}
else if(riid == IID_IConnectionPointContainer)
{
*ppv = (IConnectionPointContainer*)this;
printf("CInsideDCOM::QueryInterface(IID_IConnectionPointContainer) = %u\n",*ppv);
}
else if(riid == IID_IConnectionPoint)
{
*ppv = (IConnectionPoint*)this;
printf("CInsideDCOM::QueryInterface(IID_IConnectionPoint) = %u\n",*ppv);
}
else
{
*ppv = NULL;
return E_NOINTERFACE;
}
AddRef();
return S_OK;
}
HRESULT CInsideDCOM::Sum(int x, int y, int* retval)
{
*retval = x + y;
return S_OK;
}
HRESULT CInsideDCOM::EnumConnectionPoints(IEnumConnectionPoints** ppEnum)
{
return E_NOTIMPL;
}
HRESULT CInsideDCOM::FindConnectionPoint(REFIID riid, IConnectionPoint** ppCP)
{
if(riid == IID_IOutGoing)
{
printf("Component: CInsideDCOM::FindConnectionPoint() for IID_IOutGoing\n");
return QueryInterface(IID_IConnectionPoint, (void**)ppCP);
}
return E_NOINTERFACE;
}
HRESULT CInsideDCOM::GetConnectionInterface(IID* pIID)
{
return E_NOTIMPL;
}
HRESULT CInsideDCOM::GetConnectionPointContainer(IConnectionPointContainer** ppCPC)
{
return E_NOTIMPL;
}
HRESULT CInsideDCOM::Advise(IUnknown* pUnknown, DWORD* pdwCookie) //HRESULT CInsideDCOM::Advise(IUnknown* pUnknown, DWORD* pdwCookie)
{ //{
HRESULT hr; // printf("Entering CInsideDCOM::Advise\n");
// *pdwCookie=1;
printf("\nEntering CInsideDCOM::Advise\n"); // return pUnknown->QueryInterface(IID_IOutGoing, (void**)&g_pOutGoing);
printf(" pUnknown = %u\n",pUnknown); //}
printf(" g_pOutGoing = %u\n",g_pOutGoing);
*pdwCookie=1;
hr=pUnknown->QueryInterface(IID_IOutGoing, (void**)&g_pOutGoing);
printf(" &g_pOutGoing = %u\n",&g_pOutGoing);
printf(" g_pOutGoing = %u\n",g_pOutGoing);
printf("Leaving CInsideDCOM::Advise()\n\n");
return hr;
}
HRESULT CInsideDCOM::Unadvise(DWORD dwCookie)
{
printf("Unadvise\n");
g_pOutGoing->Release();
return NOERROR;
}
HRESULT CInsideDCOM::EnumConnections(IEnumConnections** ppEnum)
{
return E_NOTIMPL;
}
If I want the program to run in .NET it looks like it has to stay.
FUNCTION IConnectionPointContainer_FindConnectionPoint(BYVAL this AS IConnectionPointContainer1 PTR, BYREF iid AS GUID, BYVAL ppCP AS DWORD PTR) AS LONG
LOCAL hr AS LONG
Prnt " Entering IConnectionPointContainer_FindConnectionPoint()"
IF iid=$IID_IOUTGOING THEN
Prnt " this = " & STR$(this)
Prnt " @ppCP = " & STR$(@ppCP)
hr=IConnectionPointContainer_QueryInterface(this, $IID_ICONNECTIONPOINT, ppCP)
Prnt " @ppCP = " & STR$(@ppCP)
Prnt " Leaving IConnectionPointContainer_FindConnectionPoint()"
FUNCTION=hr
EXIT FUNCTION
END IF
Isn't it your implementation of IConnectionPointContainer::FindConnectionPoint that is doing
QueryInterface(IID_ICONNECTIONPOINT) rather than .NET?
The way I would implement this method, is to just simply return an AddRef'ed pointer to the requested interface.
By the way, why are you using global variables? Try creating five controls on a form, deleting three of them and
interacting with the remaining two.
Quote
Isn't it your implementation of IConnectionPointContainer::FindConnectionPoint that is doing
QueryInterface(IID_ICONNECTIONPOINT) rather than .NET?
No. The whole ::FindConnectionPoint() thing seems to me to be just a wrapper around a QueryInterface()
call for IConnectionPoint off the IConnectionPointContainer interface. At least that is what I gathered
from studying the implementation from my book which I essentially just copied to my specific control
I'm building here. If there is more to it than that I simply havn't gotten that far yet.
What caused the VB.NET crash after I commented out the IConnectionPoint Case from IComCtrl_QueryInterface()
is that VB.NET made that call after it had already obtained an IConnectionPoint pointer from
::FindConnectionPoint() in the customary manner, and it made the call off the IComCtrl interface which you
have been stating all along shouldn't support a direct call for the IConnectionPoint interface. I can
assure you that that IComCtrl_QueryInterface($IID_IConnectionPoint) call revealed and explained in the below
notes was not made by my dll but rather by .NET...
Entering IComCtrl_QueryInterface() 'At this point VB.NET is calling the
Trying To Get IConnectionPointContainer 'base or 'default' interface to get
this = 1667768 'an IConnectionPointContainer pointer.
this = 1667772 'The way I have the object built is
Leaving IComCtrl_QueryInterface() 'that IComCtrl is the 1st interface
'pointer stored at the base allocation
Entering IComCtrl_Release() 'of COM Object CD - here 1667768. The
@pCD.m_cRef = 4 'next pointer occupying bytes 1667772
Leaving IComCtrl_Release() 'through 1667775 would be the
'IConnectionPointContainer VTable Ptr.
Entering IConnectionPointContainer_Release() 'The 3rd slot in CD - 1667776 through
Leaving IConnectionPointContainer_Release() '1667779 would be the IConnectionPoint
'pointer
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IConnectionPointContainer_FindConnectionPoint() 'Here you see that VB.NET is using its
this = 1667772 'just acquired IConnectionPointContainer
@ppCP = 0 'pointer to call ::FindConnectionPoint(),
Entering IConnectionPointContainer_QueryInterface() 'and of course it got it, which would be
Looking For IID_IConnectionPoint 'the number 1667776.
Leaving IConnectionPointContainer_QueryInterface()
@ppCP = 1667776
Leaving IConnectionPointContainer_FindConnectionPoint()
Entering IComCtrl_AddRef() 'Now here's the strange part: As you can see above VB.NET
@pCD.m_cRef = 5 'successfully obtained its IConnectionPoint pointer in that it
Leaving IComCtrl_AddRef() 'would have gotten both an address and a successful HRESULT
'from its FindConnectionPoint() call off the
Entering IComCtrl_Release() 'IConnectionPointContainer Interface. Nontheless just below and
@pCD.m_cRef = 5 'left you can see an 'Entering IComCtrl_QueryInterface() call trying
Leaving IComCtrl_Release() 'to get another IConnectionPoint pointer. This is the call that
'raised the VB.NET exception when I commented out the
Entering IComCtrl_AddRef() 'IConnectionPoint Case in IComCtrl_QueryInterface(). Here is
@pCD.m_cRef = 5 'the exact error message generated by that which specifically
Leaving IComCtrl_AddRef() 'states...
Entering IComCtrl_QueryInterface() 'Unable to cast COM object of type 'CDLibrary.CDClass' to interface type
Trying To Get IConnectionPoint 'type 'System.Runtime.InteropServices.ComTypes.IConnectionPoint'. This
this = 1667768 'operation failed because the QueryInterface call on the COM component for
this = 1667776 'the interface with IID {B196B286-BAB4-101A-B69C-00AA00341D07} failed due
Leaving IComCtrl_QueryInterface() 'due to the following error: No such interface supported Exception from
'HRESULT: 0x80004002 (E_NOINTERFACE)).
'The E_NOINTERFACE referred to above came from the bottom of my
'IComCtrl_QueryInterface() call after I commented out the IConnectionPoint
'Case.
All I can think of why .NET would call my IComCtrl_QueryInterface() for IConnectionPoint after it already
successfully got one in the customary fashion of using FindConnectionPoint() is that it is wanting to
compare the values and that the result of that comparison is in some way meaningful to the algorithm it
is running. If they match then maybe its algorithm thinks to itself "Hey! Here's a component with a real
high regard to the 'Transitive Rule' Of QueryInterface." I don't know. All I know is that if I don't
return a valid IConnectionPoint interface pointer off the default interface .NET will crash.
Quote
The way I would implement this method, is to just simply return an AddRef'ed pointer to the requested interface.
Wow! Why didn't I think of that!
Incr this
@ppCP=this
Too easy I guess! All kidding aside, I just copied from my Eddon "Inside Distributed COM" book, and that's
what they did.
I'll address your other comments in a bit, because they raise some important issues. Thanks again for looking at this Dominic. Your input is
valuable to me.
Quote
By the way, why are you using global variables?
I hate globals and don't use them at all in my GUI Windows programming. My typical protocol is to allocate memory for a type and stash the variables I need to persist across function calls in that type, then stash a pointer to it in .cbWndExtra bytes, properties, or something like that. However, it seems with this COM programming all the book authors use a good number of globals, and I've just got in the habit of trying to ignore them and look the other way, kind of like what a policeman might do if he sees someone running a stop sign, then realizes its his wife's brother and in the interests of domestic tranquility decides to do nothing about it.
I did try to eliminate some though and met with a modicum of success. I got rid of the three Asciiz string variables containing ProgIds and such, and two object variables that were never even instantiated but needed to be declared due to their presence in function parameter lists. However, the VTables themselves simply seem to have to persist. So I don't know what else to do with them. I'll shortly post an updated version of the program, and if anyone has any ideas as to how to eliminate any of the remaining globals, why, I'm all ears!
Quote
By the way, why are you using global variables? Try creating five controls on a form, deleting three of them and
interacting with the remaining two.
Up to this point I had been more interested in just getting the thing to work at all even in the simplest case of just one object being instantiated. However, I don't think I was completely oblivious to the issue of multiple instantiations. Every time IClassFactory_CreateInstance() gets called CoTaskMemAlloc() was used to obtain a new and independent allocation for a CD object. In the CreateControl() method I incremented the global g_CtrlId variable so each window would get a unique Control ID. However, I hadn't really given it any concerted thought until you mentioned it, and upon examining the situation I found I had to make a couple very minor changes.
First off, in the FindConnectionPoint::Unadvise() method I had this little nasty...
@g_ptrOutGoing=0
Don't know where or how exactly I came up with that but its now gone. Also, in the Window Procedure that services any/all controls created I passed the message parameter back to the sink. If one is interested in which one of several windows the message is coming from that bit of information isn't particularly useful. So I changed the Call Dword function there to pass the hWnd instead. Other than that, I believe those were the only changes I made to the control. Here is the updated control as it now stands...
#Compile Dll
#Dim All
#Include "Win32api.inc"
#Include "ObjBase.inc"
#Resource "CD.pbr"
Declare Function ptrQueryInterface (Byval this As Dword Ptr, Byref iid As Guid, Byval pUnknown As Dword) As Long
Declare Function ptrRelease (Byval this As Dword Ptr) As Long
Declare Function ptrControlEvent (Byval this As Dword Ptr, Byval iMessage As Long) As Long
$IID_IUnknown = Guid$("{00000000-0000-0000-C000-000000000046}")
$IID_IClassFactory = Guid$("{00000001-0000-0000-C000-000000000046}")
$IID_IConnectionPoint = Guid$("{B196B286-BAB4-101A-B69C-00AA00341D07}")
$IID_IConnectionPointContainer = Guid$("{B196B284-BAB4-101A-B69C-00AA00341D07}")
$CLSID_CD = Guid$("{20000000-0000-0000-0000-000000000040}")
$IID_ICOMCtrl = Guid$("{20000000-0000-0000-0000-000000000041}")
$IID_IOutGoing = Guid$("{20000000-0000-0000-0000-000000000042}")
$IID_LIBID_CD = Guid$("{20000000-0000-0000-0000-000000000043}")
Type IComCtrlVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Initialize As Dword Ptr
CreateControl As Dword Ptr
SetColor As Dword Ptr
GetColor As Dword Ptr
GetCtrlId As Dword Ptr
GetHWND As Dword Ptr
End Type
Type IComCtrl
lpVtbl As IComCtrlVtbl Ptr
End Type
Type IConnectionPointContainerVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
EnumConnectionPoints As Dword Ptr
FindConnectionPoint As Dword Ptr
End Type
Type IConnectionPointContainer1
lpVtbl As IConnectionPointContainerVtbl Ptr
End Type
Type IConnectionPointVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
GetConnectionInterface As Dword Ptr
GetConnectionPointContainer As Dword Ptr
Advise As Dword Ptr
Unadvise As Dword Ptr
EnumConnections As Dword Ptr
End Type
Type IConnectionPoint1
lpVtbl As IConnectionPointVtbl Ptr
End Type
Type CD
lpComCtrlVtbl As IComCtrlVtbl Ptr
lpICPCVtbl As IConnectionPointContainerVtbl Ptr
lpICPVtbl As IConnectionPointVtbl Ptr
hContainer As Dword
hControl As Dword
m_cRef As Long
End Type
Type IEnumConnectionPointsVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Next As Dword Ptr
Skip As Dword Ptr
Reset As Dword Ptr
Clone As Dword Ptr
End Type
Type IEnumConnectionPoints1
lpVtbl As IEnumConnectionPointsVtbl Ptr
End Type
Type IEnumConnectionsVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Next As Dword Ptr
Skip As Dword Ptr
Reset As Dword Ptr
Clone As Dword Ptr
End Type
Type IEnumConnections1
lpVtbl As IEnumConnectionsVtbl Ptr
End Type
Type IOutGoingVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
ControlEvent As Dword Ptr
End Type
Type IOutGoing
lpVtbl As IOutGoingVtbl Ptr
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 CDClassFactory As IClassFactory1 'Function Addresses
Global IClassFactory_Vtbl As IClassFactoryVtbl
Global IComCtrl_Vtbl As IComCtrlVtbl
Global IConnPointContainer_Vtbl As IConnectionPointContainerVtbl
Global IConnPoint_Vtbl As IConnectionPointVtbl
Global g_hModule As Dword 'Actual Variables
Global g_lLocks As Long
Global g_lObjs As Long
Global g_CtrlId As Long
Global g_ptrOutGoing As Dword Ptr
Sub Prnt(strLn As String)
Local iLen, iWritten As Long
Local hStdOutput As Dword
Local strNew As String
hStdOutput=GetStdHandle(%STD_OUTPUT_HANDLE)
strNew=strLn + $CrLf
iLen = Len(strNew)
WriteConsole(hStdOutput, Byval Strptr(strNew), iLen, iWritten, Byval 0)
End Sub
Function IComCtrl_QueryInterface(ByVal this As IComCtrl Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
Prnt " Entering IComCtrl_QueryInterface()"
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Prnt " Trying To Get IUnknown"
Call IComCtrl_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Prnt " Trying To Get IComCtrl"
Call IComCtrl_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Prnt " Trying To Get IConnectionPointContainer"
Prnt " this = " & Str$(this)
Incr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
Prnt " Trying To Get IConnectionPoint"
Prnt " this = " & Str$(this)
Incr this : Incr this
@ppv=this
Call IConnectionPoint_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case Else
Prnt " Looking For Something I Ain't Got!"
Prnt " Leaving IComCtrl_QueryInterface()"
End Select
Function=%E_NoInterface
End Function
Function IComCtrl_AddRef(ByVal this As IComCtrl Ptr) As Long
Local pCD As CD Ptr
Prnt " Entering IComCtrl_AddRef()"
pCD=this
Incr @pCD.m_cRef
Prnt " @pCD.m_cRef = " & Str$(@pCD.m_cRef)
Prnt " Leaving IComCtrl_AddRef()"
IComCtrl_AddRef=@pCD.m_cRef
End Function
Function IComCtrl_Release(ByVal this As IComCtrl Ptr) As Long
Local pCD As CD Ptr
Prnt " Entering IComCtrl_Release()"
pCD=this
Prnt " @pCD.m_cRef = " & Str$(@pCD.m_cRef)
Decr @pCD.m_cRef
If @pCD.m_cRef=0 Then
Call SendMessage(@pCD.hControl,%WM_CLOSE,0,0)
Call CoTaskMemFree(this)
Call InterlockedDecrement(g_lObjs)
Prnt " @pCD.m_cRef = " & Str$(@pCD.m_cRef)
Prnt " CD Was Deleted!"
End If
Prnt " Leaving IComCtrl_Release()"
Function=@pCD.m_cRef
End Function
Function fnWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case As Long Msg
Case %WM_CREATE
Call SetWindowLong(hWnd,0,RGB(255,255,0))
Function=0
Exit Function
Case %WM_PAINT
Local hDC,hNewBrush As Dword
Local ps As PAINTSTRUCT
Local rc As RECT
hDC=BeginPaint(hWnd,ps)
hNewBrush=CreateSolidBrush(GetWindowLong(hWnd,0))
Call FillRect(hDC,ps.rcPaint,hNewBrush)
Call GetClientRect(hWnd,rc)
Call DrawText(hDC, "Click Me!",-1,rc,%DT_SINGLELINE Or %DT_CENTER Or %DT_VCENTER)
Call DeleteObject(hNewBrush)
Call EndPaint(hWnd,ps)
Function=0
Exit Function
Case %WM_LBUTTONDOWN
Local Vtbl As Dword Ptr
Local hr As Long
Prnt "WM_LBUTTONDOWN"
Prnt "g_ptrOutGoing = " & Str$(g_ptrOutGoing)
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[3] Using ptrControlEvent(g_ptrOutGoing, hWnd) To hr
Function=0
Exit Function
End Select
Function=DefWindowProc(hWnd,Msg,wParam,lParam)
End Function
Function IComCtrl_Initialize(ByVal this As IComCtrl Ptr) As Long
Local szClassName As Asciiz*16
Local wc As WndClassEx
Prnt " Entering IComCtrl_Initialize()"
Prnt " this = " & Str$(this)
szClassName="ComCtrl"
wc.cbSize=SizeOf(wc)
wc.style=%CS_PARENTDC
wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0
wc.cbWndExtra=4 'Four extra bytes to store RGB color.
wc.hInstance=g_hModule
wc.hIcon=LoadIcon(Byval %NULL, Byval %IDI_APPLICATION)
wc.hCursor=LoadCursor(%NULL,ByVal %IDC_ARROW)
wc.hbrBackground=GetStockObject(%WHITE_BRUSH)
wc.lpszMenuName=%NULL
wc.lpszClassName=VarPtr(szClassName)
wc.hIconSm=%NULL
If RegisterClassEx(wc) Then
Function=%S_OK
Else
Function=%S_FALSE
End If
Prnt " Leaving IComCtrl_Initialize()"
End Function
Function IComCtrl_CreateControl(ByVal this As IComCtrl Ptr, Byval hContainer As Long) As Long
Local pCD As CD Ptr
Local hCtl As Dword
Local rc As RECT
Prnt "Entering IComCtrl_CreateControl()"
Prnt " this = " & Str$(this)
Call GetClientRect(hContainer,rc)
hCtl=CreateWindow("ComCtrl","",%WS_CHILD Or %WS_VISIBLE,0,0,rc.nRight,rc.nBottom,hContainer,g_CtrlId,g_hModule,Byval 0)
Incr g_CtrlId
pCD=this
@pCD.hContainer=hContainer
@pCD.hControl=hCtl
Call ShowWindow(hCtl,%SW_SHOWNORMAL)
Call SetFocus(hCtl)
Prnt "Leaving IComCtrl_CreateControl()"
Function=%S_OK
End Function
Function IComCtrl_SetColor(Byval this As IComCtrl Ptr, Byval iColor As Long) As Long
Local pCD As CD Ptr
Prnt "Entering IComCtrl_SetColor()"
pCD=this
Call SetWindowLong(@pCD.hControl,0,iColor)
Call InvalidateRect(@pCD.hControl,Byval %NULL, %TRUE)
Prnt "Leaving IComCtrl_SetColor()"
Function=%S_OK
End Function
Function IComCtrl_GetColor(Byval this As IComCtrl Ptr, Byref ptrColor As Long) As Long
Local pCD As CD Ptr
pCD=this
ptrColor=GetWindowLong(@pCD.hControl,0)
Function=%S_OK
End Function
Function IComCtrl_GetCtrlId(Byval this As IComCtrl Ptr, Byref ptrCtrlId As Long) As Long
Local pCD As CD Ptr
pCD=this
ptrCtrlId=GetDlgCtrlId(@pCD.hControl)
Function=%S_OK
End Function
Function IComCtrl_GetHWND(Byval this As IComCtrl Ptr, Byref ptrWindowHandle As Long) As Long
Local pCD As CD Ptr
pCD=this
ptrWindowHandle=@pCD.hControl
Function=%S_OK
End Function
Function IConnectionPointContainer_QueryInterface(ByVal this As IConnectionPointContainer1 Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
Prnt " Entering IConnectionPointContainer_QueryInterface()"
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Call IConnectionPointContainer_AddRef(this)
@ppv=this
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
Prnt " Looking For IID_IConnectionPoint"
Incr this
@ppv=this
Call IConnectionPoint_AddRef(this)
Prnt " Leaving IConnectionPointContainer_QueryInterface()"
Function=%S_OK
Exit Function
End Select
Function=%E_NOINTERFACE
End Function
Function IConnectionPointContainer_AddRef(ByVal this As IConnectionPointContainer1 Ptr) As Long
Local pCD As CD Ptr
Decr this
pCD=this
Incr @pCD.m_cRef
Function=@pCD.m_cRef
End Function
Function IConnectionPointContainer_Release(ByVal this As IConnectionPointContainer1 Ptr) As Long
Local pCD As CD Ptr
Prnt " Entering IConnectionPointContainer_Release()"
Decr this
pCD=this
Decr @pCD.m_cRef
If @pCD.m_cRef=0 Then
Prnt " @pCD.m_cRef = 0 And Will Now Delete pCD!"
Call CoTaskMemFree(this)
Call InterlockedDecrement(g_lObjs)
End If
Prnt " Leaving IConnectionPointContainer_Release()"
Function=@pCD.m_cRef
End Function
Function IConnectionPointContainer_EnumConnectionPoints(ByVal this As IConnectionPointContainer1 Ptr, Byval ppEnum As IEnumConnectionPoints1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPointContainer_FindConnectionPoint(ByVal this As IConnectionPointContainer1 Ptr, ByRef iid As Guid, ByVal ppCP As Dword Ptr) As Long
Local hr As Long
Prnt " Entering IConnectionPointContainer_FindConnectionPoint()"
If iid=$IID_IOutGoing Then
Prnt " this = " & Str$(this)
Prnt " @ppCP = " & Str$(@ppCP)
hr=IConnectionPointContainer_QueryInterface(this, $IID_IConnectionPoint, ppCP)
Prnt " @ppCP = " & Str$(@ppCP)
Prnt " Leaving IConnectionPointContainer_FindConnectionPoint()"
Function=hr
Exit Function
End If
Function=%E_NOINTERFACE
End Function
Function IConnectionPoint_QueryInterface(ByVal this As IConnectionPoint1 Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Decr this : Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_ICOMCtrl
Decr this : Decr this
@ppv=this
Call IComCtrl_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Decr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
@ppv=this
Call IConnectionPoint_AddRef(this)
Function=%S_OK
Exit Function
End Select
Function=%E_NOINTERFACE
End Function
Function IConnectionPoint_AddRef(ByVal this As IConnectionPoint1 Ptr) As Long
Local pCD As CD Ptr
Decr this : Decr this
pCD=this
Incr @pCD.m_cRef
Function=@pCD.m_cRef
End Function
Function IConnectionPoint_Release(ByVal this As IConnectionPoint1 Ptr) As Long
Local pCD As CD Ptr
Prnt " Entering IConnectionPoint_Release()"
Decr this : Decr this
pCD=this
Decr @pCD.m_cRef
If @pCD.m_cRef=0 Then
Prnt " @pCD.m_cRef = 0 And Will Now Delete pCD!"
Call CoTaskMemFree(this)
Call InterlockedDecrement(g_lObjs)
End If
Prnt " Leaving IConnectionPoint_Release()"
Function=@pCD.m_cRef
End Function
Function IConnectionPoint_GetConnectionInterface(Byval this As IConnectionPoint1 Ptr, Byref iid As Guid) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPoint_GetConnectionPointContainer(Byval this As IConnectionPoint1 Ptr, Byval ppCPC As IConnectionPointContainer1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPoint_Advise(Byval this As IConnectionPoint1 Ptr, Byval pUnkSink As Dword Ptr, Byval pdwCookie As Dword Ptr) As Long
Local Vtbl As Dword Ptr
Local hr As Long
Prnt " Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!"
Prnt " pUnkSink = " & Str$(pUnkSink)
Prnt " @pUnkSink = " & Str$(@pUnkSink)
Vtbl=@pUnkSink
Prnt " Vtbl = " & Str$(Vtbl)
Prnt " @Vtbl[0] = " & Str$(@Vtbl[0])
Prnt " g_ptrOutGoing = " & Str$(g_ptrOutGoing) & " << Before Call Of QueryInterface() On Sink"
Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IOutGoing,Varptr(g_ptrOutGoing)) To hr
Prnt " g_ptrOutGoing = " & Str$(g_ptrOutGoing) & " << After Call Of QueryInterface() On Sink"
If SUCCEEDED(hr) Then
Prnt " Call Dword Succeeded!"
@pdwCookie=1
Else
@pdwCookie=0
End If
Prnt " Leaving IConnectionPoint_Advise() And Still In One Piece!"
Function=hr
End Function
Function IConnectionPoint_Unadvise(Byval this As IConnectionPoint1 Ptr, Byval dwCookie As Dword) As Long
Local Vtbl As Dword Ptr
Local iReturn As Long
Prnt "Entering IConnectionPoint_Unadvise()"
VTbl=@g_ptrOutGoing
Call Dword @Vtbl[2] Using ptrRelease(g_ptrOutGoing) To iReturn
Prnt " Release() Returned " & Str$(iReturn)
Prnt "Leaving IConnectionPoint_Unadvise()"
'@g_ptrOutGoing=0 'this is poison! get rid of it!
Function=%NOERROR
End Function
Function IConnectionPoint_EnumConnections(Byval this As IConnectionPoint1 Ptr, Byval ppEnum As IEnumConnections1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
Prnt " Entering IClassFactory_AddRef()"
Call InterlockedIncrement(g_lObjs)
Prnt " g_lObjs = " & Str$(g_lObjs)
Prnt " Leaving IClassFactory_AddRef()"
IClassFactory_AddRef=g_lObjs
End Function
Function IClassFactory_Release(ByVal this As IClassFactory1 Ptr) As Long
Prnt " Entering IClassFactory_Release()"
Call InterlockedDecrement(g_lObjs)
Prnt " g_lObjs = " & Str$(g_lObjs)
Prnt " Leaving IClassFactory_Release()"
IClassFactory_Release=g_lObjs
End Function
Function IClassFactory_QueryInterface(ByVal this As IClassFactory1 Ptr, ByRef RefIID As Guid, ByVal pCF As Dword Ptr) As Long
Prnt " Entering IClassFactory_QueryInterface()"
@pCF=0
If RefIID=$IID_IUnknown Or RefIID=$IID_IClassFactory Then
Call IClassFactory_AddRef(this)
@pCF=this
Prnt " this = " & Str$(this)
Prnt " Leaving IClassFactory_QueryInterface()"
Function=%NOERROR
Exit Function
End If
Prnt " Leaving IClassFactory_QueryInterface() Empty Handed!"
Function=%E_NoInterface
End Function
Function IClassFactory_CreateInstance(ByVal this As IClassFactory1 Ptr, ByVal pUnknown As Dword, ByRef RefIID As Guid, Byval ppv As Dword Ptr) As Long
Local pComCtrl As IComCtrl Ptr
Local pCD As CD Ptr
Local hr As Long
Prnt " Entering IClassFactory_CreateInstance()"
@ppv=%NULL
If pUnknown Then
hr=%CLASS_E_NOAGGREGATION
Else
pCD=CoTaskMemAlloc(SizeOf(CD))
Prnt " pCD = " & Str$(pCD)
If pCD Then
@pCD.lpComCtrlVtbl = VarPtr(IComCtrl_Vtbl)
@pCD.lpICPCVtbl = VarPtr(IConnPointContainer_Vtbl)
@pCD.lpICPVtbl = Varptr(IConnPoint_Vtbl)
Prnt " Varptr(@pCD.lpComCtrlVtbl) = " & Str$(Varptr(@pCD.lpComCtrlVtbl))
Prnt " Varptr(@pCD.lpICPCVtbl) = " & Str$(Varptr(@pCD.lpICPCVtbl))
Prnt " Varptr(@pCD.lpICPVtbl) = " & Str$(Varptr(@pCD.lpICPVtbl))
@pCD.m_cRef=0
@pCD.hContainer=0 : @pCD.hControl=0
pComCtrl=pCD
Prnt " @ppv = " & Str$(@ppv) & " << Before QueryInterface() Call"
hr= IComCtrl_QueryInterface(pComCtrl,RefIID,ppv)
Prnt " @ppv = " & Str$(@ppv) & " << After QueryInterface() Call"
If SUCCEEDED(hr) Then
Call InterlockedIncrement(g_lObjs)
Else
Call CoTaskMemFree(pCD)
End If
Else
hr=%E_OutOfMemory
End If
End If
Prnt " Leaving IClassFactory_CreateInstance()"
IClassFactory_CreateInstance=hr
End Function
Function IClassFactory_LockServer(ByVal this As IClassFactory1 Ptr, Byval flock As Long) As Long
If flock Then
Call InterlockedIncrement(g_lLocks)
Else
Call InterlockedDecrement(g_lLocks)
End If
IClassFactory_LockServer=%NOERROR
End Function
Function DllCanUnloadNow Alias "DllCanUnloadNow" () Export As Long
Prnt "Entering DllCanUnloadNow()"
If g_lObjs = 0 And g_lLocks = 0 Then
Prnt " I'm Outta Here!"
Function=%S_OK
Else
Prnt " The System Wants Rid Of Me But I Won't Go!"
Function=%S_FALSE
End If
Prnt "Leaving DllCanUnloadNow()"
End Function
Function DllGetClassObjectImpl Alias "DllGetClassObject" (ByRef RefClsid As Guid, ByRef iid As Guid, ByVal pClassFactory As Dword Ptr) Export As Long
Local hr As Long
Prnt "Entering DllGetClassObjectImpl()"
If RefClsid=$CLSID_CD Then
IClassFactory_Vtbl.QueryInterface = CodePtr(IClassFactory_QueryInterface)
IClassFactory_Vtbl.AddRef = CodePtr(IClassFactory_AddRef)
IClassFactory_Vtbl.Release = CodePtr(IClassFactory_Release)
IClassFactory_Vtbl.CreateInstance = CodePtr(IClassFactory_CreateInstance)
IClassFactory_Vtbl.LockServer = CodePtr(IClassFactory_LockServer)
CDClassFactory.lpVtbl = VarPtr(IClassFactory_Vtbl)
IComCtrl_Vtbl.QueryInterface = CodePtr(IComCtrl_QueryInterface)
IComCtrl_Vtbl.AddRef = CodePtr(IComCtrl_AddRef)
IComCtrl_Vtbl.Release = CodePtr(IComCtrl_Release)
IComCtrl_Vtbl.Initialize = CodePtr(IComCtrl_Initialize)
IComCtrl_Vtbl.CreateControl = CodePtr(IComCtrl_CreateControl)
IComCtrl_Vtbl.SetColor = CodePtr(IComCtrl_SetColor)
IComCtrl_Vtbl.GetColor = CodePtr(IComCtrl_GetColor)
IComCtrl_Vtbl.GetCtrlId = CodePtr(IComCtrl_GetCtrlId)
IComCtrl_Vtbl.GetHWND = CodePtr(IComCtrl_GetHWND)
IConnPointContainer_Vtbl.QueryInterface = CodePtr(IConnectionPointContainer_QueryInterface)
IConnPointContainer_Vtbl.AddRef = CodePtr(IConnectionPointContainer_AddRef)
IConnPointContainer_Vtbl.Release = CodePtr(IConnectionPointContainer_Release)
IConnPointContainer_Vtbl.EnumConnectionPoints = CodePtr(IConnectionPointContainer_EnumConnectionPoints)
IConnPointContainer_Vtbl.FindConnectionPoint = CodePtr(IConnectionPointContainer_FindConnectionPoint)
IConnPoint_Vtbl.QueryInterface = CodePtr(IConnectionPoint_QueryInterface)
IConnPoint_Vtbl.AddRef = CodePtr(IConnectionPoint_AddRef)
IConnPoint_Vtbl.Release = CodePtr(IConnectionPoint_Release)
IConnPoint_Vtbl.GetConnectionInterface = CodePtr(IConnectionPoint_GetConnectionInterface)
IConnPoint_Vtbl.GetConnectionPointContainer = CodePtr(IConnectionPoint_GetConnectionPointContainer)
IConnPoint_Vtbl.Advise = CodePtr(IConnectionPoint_Advise)
IConnPoint_Vtbl.Unadvise = CodePtr(IConnectionPoint_Unadvise)
IConnPoint_Vtbl.EnumConnections = CodePtr(IConnectionPoint_EnumConnections)
hr=IClassFactory_QueryInterface(VarPtr(CDClassFactory),iid,pClassFactory)
If FAILED(hr) Then
pClassFactory=0
hr=%CLASS_E_CLASSNOTAVAILABLE
Else
Prnt " IClassFactory_QueryInterface() For iid Succeeded!"
End If
End If
Prnt "Leaving DllGetClassObjectImpl()"
Function=hr
End Function
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 szFileName 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
szClsid=GuidTxt$(ClassId)
szLibid=GuidTxt$(LibId)
If szClsid <> "" And szLibid <> "" Then
szKey="CLSID\" & szClsid
If IsFalse(SetKeyAndValue(szKey, Byval %NULL, szFriendlyName)) Then
Function=%E_FAIL : Exit Function
End If
If IsFalse(SetKeyAndValue(szKey, "InprocServer32", szFileName)) 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, szFriendlyName)) 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
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
Function DllRegisterServer Alias "DllRegisterServer" () Export As Long
Local szFriendlyName As Asciiz*16, szVerIndProgID As Asciiz*16, szProgID As Asciiz*16
Local strAsciPath,strWideCharPath,strPath As String
Local hr,iBytesReturned As Long
Local szPath As Asciiz*256
Local pTypeLib As ITypeLib
If GetModuleFileName(g_hModule, szPath, 256) Then
strPath=szPath
strAsciPath=szPath
strWideCharPath=UCode$(strAsciPath & $Nul)
hr=LoadTypeLibEx(Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
If SUCCEEDED(hr) Then
Set pTypeLib = Nothing
szFriendlyName = "Com Control CD"
szVerIndProgID = "ComCtrl.CD"
szProgID = "ComCtrl.CD.1"
hr=RegisterServer(szPath, $CLSID_CD, $IID_LIBID_CD, szFriendlyName, szVerIndProgID, szProgID)
Else
Local dwFlags As Dword
Local szError As Asciiz*256
Local strError As String
iBytesReturned=FormatMessage(dwFlags,Byval 0,hr,MAKELANGID(%LANG_NEUTRAL,%SUBLANG_DEFAULT),Byval Varptr(szError),256,Byval %NULL)
If iBytesReturned=0 Then
iBytesReturned=MsgBox("...And That Is To Use PBTyp.exe To Embed The Type Library In The Exe!", %MB_ICONWARNING, "I Know What You Forgot...")
End If
strError=szError
End If
End If
Function=hr
End Function
Function DllUnregisterServer Alias "DllUnregisterServer" () Export As Long
Local szVerIndProgID As Asciiz*16, szProgID As Asciiz*16
Local hr As Long
hr=UnRegisterTypeLib($IID_LIBID_CD, 1, 0, %LANG_NEUTRAL, %SYS_WIN32)
If SUCCEEDED(hr) Then
szVerIndProgID = "ComCtrl.CD"
szProgID = "ComCtrl.CD.1"
hr=UnregisterServer($CLSID_CD, szVerIndProgID, szProgID)
Else
MsgBox("UnRegisterTypeLib() Failed!")
End If
Function=hr
End Function
Function DllMain(ByVal hInstance As Long, ByVal fwdReason As Long, ByVal lpvReserved As Long) Export As Long
If fwdReason=%DLL_PROCESS_ATTACH Then
Call DisableThreadLibraryCalls(hInstance)
g_hModule = hInstance
g_CtrlId = 1500
End If
DllMain=%TRUE
End Function
In terms of that code, the first client I coded to test it was a C++ one and I modified my earlier C++ example I believe in post #5 of this thread to contain two controls, one under the other. So I made the parent form higher and wider. Associated with each control on the left were the three buttons to turn it blue, green, or red. Then on the right of each control I put another button to kill that particular control. What I wanted to test was what would happen if I killed one control and attempted to interact with its buttons or the other control. I trust that whatever ill would result from your example of creating five controls, deleting three, then interacting with the remaining two would occur by creating two and deleting one. I did have a fair bit of trouble with it but the trouble all involved my client/host - not the control. I used the same sink for both controls. Anyway, here is that C++ code followed by the console screen output. I particularly like the C++ version because I'm picking up all the events right from entering my WM_CREATE handler in the client to the DllUnload event in the COM object. The output is right after this Main.cpp code, and reflects a scenerio where I destroyed one of the controls, interacted with what's left, then x'ed out...
//Main.cpp
#include <windows.h>
#include <tchar.h>
#include <fcntl.h>
#include <io.h>
#include <stdio.h>
#include <ocidl.h>
#include "Main.h"
#include "CSink.h"
extern "C" const CLSID CLSID_CD ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x40}};
extern "C" const IID IID_ICOMCtrl ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x41}};
extern "C" const IID IID_IOutGoing ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x42}};
IConnectionPointContainer* pConnectionPointContainer1=NULL;
IConnectionPointContainer* pConnectionPointContainer2=NULL;
IConnectionPoint* pConnectionPoint1=NULL;
IConnectionPoint* pConnectionPoint2=NULL;
EVENTHANDLER EventHandler[3];
ICOMCtrl* pComCtrl1=NULL;
ICOMCtrl* pComCtrl2=NULL;
DWORD dwCookie1=NULL;
DWORD dwCookie2=NULL;
CSink* mySink=NULL;
long fnWndProc_OnCreate(lpWndEventArgs Wea)
{
HWND hButton,hContainer1,hContainer2;
IClassFactory* pCF=NULL;
HRESULT hr;
FILE* hf;
int hCrt;
Wea->hIns=((LPCREATESTRUCT)Wea->lParam)->hInstance;
AllocConsole();
hCrt=_open_osfhandle((long)GetStdHandle(STD_OUTPUT_HANDLE),_O_TEXT);
hf = _fdopen( hCrt, "w" );
_iob[1]=*hf;
printf(_T("Entering fnWndProc_OnCreate()\n"));
hr=CoInitialize(NULL);
if(SUCCEEDED(hr))
{
printf(" CoInitialize() Succeeded!\n");
hr=CoGetClassObject(CLSID_CD,CLSCTX_INPROC_SERVER,NULL,IID_IClassFactory,(void**)&pCF);
if(SUCCEEDED(hr))
{
printf(" CoGetClassObject() Succeeded! We Now Have A IClassFactory Pointer!\n");
hr=pCF->CreateInstance(NULL,IID_ICOMCtrl,(void**)&pComCtrl1);
if(SUCCEEDED(hr))
{
printf(" pCF->CreateInstance() Succeeded!\n");
hr=pComCtrl1->Initialize();
if(SUCCEEDED(hr))
{
printf(" pComCtrl->Initialize() Succeeded!\n");
hButton=CreateWindowEx(0,"button","Blue",WS_CHILD|WS_VISIBLE,8,10,80,25,Wea->hWnd,(HMENU)IDC_BUTTON1,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Green",WS_CHILD|WS_VISIBLE,8,40,80,25,Wea->hWnd,(HMENU)IDC_BUTTON2,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Red",WS_CHILD|WS_VISIBLE,8,70,80,25,Wea->hWnd,(HMENU)IDC_BUTTON3,Wea->hIns,0);
hContainer1=CreateWindowEx(WS_EX_CLIENTEDGE,_T("static"),_T(""),WS_CHILD|WS_VISIBLE|WS_THICKFRAME,100,12,275,80,Wea->hWnd,(HMENU)1600,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Kill #1",WS_CHILD|WS_VISIBLE,385,40,80,25,Wea->hWnd,(HMENU)IDC_KILL_CTL1,Wea->hIns,0);
hr=pComCtrl1->QueryInterface(IID_IConnectionPointContainer,(void**)&pConnectionPointContainer1);
if(SUCCEEDED(hr))
{
printf(" Got pConnectionPointContainer1 = %u\n",pConnectionPointContainer1);
hr = pConnectionPointContainer1->FindConnectionPoint(IID_IOutGoing, &pConnectionPoint1);
if(SUCCEEDED(hr))
{
printf(" Got pConnectionPoint1 = %u\n",pConnectionPoint1);
mySink = new CSink;
printf(" mySink = %u\n",mySink);
hr=pConnectionPoint1->Advise((IUnknown*)mySink, &dwCookie1);
if(SUCCEEDED(hr))
{
printf(" pConnectionPoint1->Advise() Succeeded!\n");
hr=pComCtrl1->CreateControl((int)hContainer1);
if(SUCCEEDED(hr))
printf(" pComCtrl1->CreateControl(hContainer) Succeeded!\n");
else
{
printf(" pComCtrl1->CreateControl(hContainer) Failed!\n");
return 0;
}
}
else
{
puts(" pConnectionPoint1->Advise() Failed!");
return 0;
}
}
else
{
printf(" Failed To Get pConnectionPoint1!\n");
return 0;
}
}
else
{
printf(" Failed To Get IConnectionPointContainer*\n");
return 0;
}
}
else
{
printf("pComCtrl1->Initialize() Failed!\n");
return 0;
}
}
else
{
printf(" pCF->CreateInstance() Failed!\n");
return 0;
}
hContainer2=CreateWindowEx(WS_EX_CLIENTEDGE,_T("static"),_T(""),WS_CHILD|WS_VISIBLE|WS_THICKFRAME,100,110,275,80,Wea->hWnd,(HMENU)1605,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Blue",WS_CHILD|WS_VISIBLE,8,110,80,25,Wea->hWnd,(HMENU)IDC_BUTTON4,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Green",WS_CHILD|WS_VISIBLE,8,140,80,25,Wea->hWnd,(HMENU)IDC_BUTTON5,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Red",WS_CHILD|WS_VISIBLE,8,170,80,25,Wea->hWnd,(HMENU)IDC_BUTTON6,Wea->hIns,0);
hButton=CreateWindowEx(0,"button","Kill #2",WS_CHILD|WS_VISIBLE,385,140,80,25,Wea->hWnd,(HMENU)IDC_KILL_CTL2,Wea->hIns,0);
hr=pCF->CreateInstance(NULL,IID_ICOMCtrl,(void**)&pComCtrl2);
if(SUCCEEDED(hr))
{
printf(" pCF->CreateInstance() For pComCtrl2 Succeeded!\n");
hr=pComCtrl2->CreateControl((int)hContainer2);
if(SUCCEEDED(hr))
{
printf(" pComCtrl2->CreateControl((int)hContainer2) Succeeded!\n");
hr=pComCtrl2->QueryInterface(IID_IConnectionPointContainer,(void**)&pConnectionPointContainer2);
if(SUCCEEDED(hr))
{
printf(" Got pConnectionPointContainer2 = %u\n",pConnectionPointContainer2);
hr = pConnectionPointContainer2->FindConnectionPoint(IID_IOutGoing, &pConnectionPoint2);
if(SUCCEEDED(hr))
{
printf(" Got pConnectionPoint2 = %u\n",pConnectionPoint2);
hr=pConnectionPoint2->Advise((IUnknown*)mySink, &dwCookie2);
if(SUCCEEDED(hr))
{
printf(" pConnectionPoint2->Advise() Succeeded!\n");
}
else
{
puts(" pConnectionPoint1->Advise() Failed!");
return 0;
}
}
else
{
printf(" Couldn't Get pConnectionPoint2!\n");
}
}
else
{
printf(" Failed To Get pConnectionPointContainer2!\n");
}
}
else
{
printf(" pComCtrl2->CreateControl((int)hContainer2) Failed!\n");
}
}
else
{
printf(" pCF->CreateInstance() For pComCtrl2 Failed!\n");
}
pCF->Release();
}
else
printf(" CoGetClassObject() Failed!\n");
}
else
printf(_T(" CoInitialize() Failed!\n"));
printf(_T("Leaving fnWndProc_OnCreate()\n\n"));
return 0;
}
long fnWndProc_OnCommand(lpWndEventArgs Wea)
{
switch(LOWORD(Wea->wParam))
{
case IDC_BUTTON1: //Blue
if(pComCtrl1)
pComCtrl1->SetColor((int)RGB(0,0,255));
break;
case IDC_BUTTON2: //Green
if(pComCtrl1)
pComCtrl1->SetColor((int)RGB(0,255,0));
break;
case IDC_BUTTON3: //Red
if(pComCtrl1)
pComCtrl1->SetColor((int)RGB(255,0,0));
break;
case IDC_KILL_CTL1:
printf("\nEntering fnWndProc_OnCommand() : Case IDC_KILL_CTL1\n");
if(pComCtrl1)
{
printf(" pComCtrl1 = %u\n",(unsigned)pComCtrl1);
printf(" The Control Apparently Exists, And Will ow Be Destroyed!\n");
if(dwCookie1 && pConnectionPoint1)
{
pConnectionPoint1->Unadvise(dwCookie1);
dwCookie1=0;
}
if(pConnectionPoint1)
{
pConnectionPoint1->Release();
pConnectionPoint1=0;
}
if(pConnectionPointContainer1)
{
pConnectionPointContainer1->Release();
pConnectionPointContainer1=0;
}
pComCtrl1->Release();
pComCtrl1=0;
}
printf("Leaving fnWndProc_OnCommand() : Case IDC_KILL_CTL1\n\n");
break;
case IDC_BUTTON4: //Blue
if(pComCtrl2)
pComCtrl2->SetColor((int)RGB(0,0,255));
break;
case IDC_BUTTON5: //Green
if(pComCtrl2)
pComCtrl2->SetColor((int)RGB(0,255,0));
break;
case IDC_BUTTON6: //Red
if(pComCtrl2)
pComCtrl2->SetColor((int)RGB(255,0,0));
break;
case IDC_KILL_CTL2:
printf("\nEntering fnWndProc_OnCommand() : Case IDC_KILL_CTL2\n");
if(pComCtrl2)
{
printf(" pComCtrl2 = %u\n",(unsigned)pComCtrl2);
printf(" The Control Apparently Exists, And Will ow Be Destroyed!\n");
if(dwCookie2 && pConnectionPoint2)
{
pConnectionPoint2->Unadvise(dwCookie2);
dwCookie2=0;
}
if(pConnectionPoint2)
{
pConnectionPoint2->Release();
pConnectionPoint2=0;
}
if(pConnectionPointContainer2)
{
pConnectionPointContainer2->Release();
pConnectionPointContainer2=0;
}
pComCtrl2->Release();
pComCtrl2=0;
}
printf("Leaving fnWndProc_OnCommand() : Case IDC_KILL_CTL2\n\n");
break;
}
return 0;
}
long fnWndProc_OnClose(lpWndEventArgs Wea)
{
printf(_T("Entering fnWndProc_OnClose()\n"));
//1st Deal With 1st Object...
if(dwCookie1 && pConnectionPoint1)
{
pConnectionPoint1->Unadvise(dwCookie1);
dwCookie1=0;
}
if(pConnectionPoint1)
pConnectionPoint1->Release();
if(pConnectionPointContainer1)
pConnectionPointContainer1->Release();
if(pComCtrl1)
{
printf("\n\nGot In Where pComCtrl Is True!!!\n\n");
pComCtrl1->Release();
}
else
{
printf("\n\npComCtrl Is FALSE!!!!!!!!!!!!!!\n\n");
}
//...Then With 2nd...
if(dwCookie2 && pConnectionPoint2)
{
pConnectionPoint2->Unadvise(dwCookie2);
dwCookie2=0;
}
if(pConnectionPoint2)
pConnectionPoint2->Release();
if(pConnectionPointContainer2)
pConnectionPointContainer2->Release();
if(pComCtrl2)
{
printf("\n\nGot In Where pComCtr2 Is True!!!\n\n");
pComCtrl2->Release();
}
else
{
printf("\n\npComCtr2 Is FALSE!!!!!!!!!!!!!!\n\n");
}
printf(_T("Leaving fnWndProc_OnClose()\n\n"));
CoUninitialize();
MessageBox
(
Wea->hWnd,
_T("Have Just Released Object! You Can Copy The Output From The Console If You Want Though!"),
_T("Will Close App!"),
MB_OK
);
DestroyWindow(Wea->hWnd);
PostQuitMessage(0);
return 0;
}
void AttachEventHandlers(void) //This procedure maps windows messages to the
{ //procedure which handles them.
EventHandler[0].Code=WM_CREATE, EventHandler[0].fnPtr=fnWndProc_OnCreate;
EventHandler[1].Code=WM_COMMAND, EventHandler[1].fnPtr=fnWndProc_OnCommand;
EventHandler[2].Code=WM_CLOSE, EventHandler[2].fnPtr=fnWndProc_OnClose;
}
long __stdcall fnWndProc(HWND hwnd, unsigned int msg, WPARAM wParam,LPARAM lParam)
{
WndEventArgs Wea; //This procedure loops through the EVENTHANDER array
//of structs to try to make a match with the msg parameter
for(unsigned int i=0; i<3; i++) //of the WndProc. If a match is made the event handling
{ //procedure is called through a function pointer -
if(EventHandler[i].Code==msg) //(EventHandler[i].fnPtr). If no match is found the
{ //msg is passed onto DefWindowProc().
Wea.hWnd=hwnd, Wea.lParam=lParam, Wea.wParam=wParam;
return (*EventHandler[i].fnPtr)(&Wea);
}
}
return (DefWindowProc(hwnd, msg, wParam, lParam));
}
int __stdcall WinMain(HINSTANCE hIns, HINSTANCE hPrevIns, LPSTR lpszArgument, int iShow)
{
TCHAR szClassName[]=_T("Form1");
WNDCLASSEX wc;
MSG messages;
HWND hWnd;
AttachEventHandlers();
wc.lpszClassName=szClassName; wc.lpfnWndProc=fnWndProc;
wc.cbSize=sizeof (WNDCLASSEX); wc.style=CS_DBLCLKS;
wc.hIcon=LoadIcon(NULL,IDI_APPLICATION); wc.hInstance=hIns;
wc.hIconSm=LoadIcon(NULL, IDI_APPLICATION); wc.hCursor=LoadCursor(NULL,IDC_ARROW);
wc.hbrBackground=(HBRUSH)COLOR_BTNSHADOW; wc.cbWndExtra=0;
wc.lpszMenuName=NULL; wc.cbClsExtra=0;
RegisterClassEx(&wc);
hWnd=CreateWindowEx(0,szClassName,szClassName,WS_OVERLAPPEDWINDOW,400,550,500,240,HWND_DESKTOP,0,hIns,0);
ShowWindow(hWnd,iShow);
while(GetMessage(&messages,NULL,0,0))
{
TranslateMessage(&messages);
DispatchMessage(&messages);
}
return messages.wParam;
}
/*
Entering fnWndProc_OnCreate()
CoInitialize() Succeeded!
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 9746228
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_AddRef()
g_lObjs = 2
Leaving IClassFactory_AddRef()
Entering IClassFactory_Release()
g_lObjs = 1
Leaving IClassFactory_Release()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 2
Leaving IClassFactory_AddRef()
this = 9746228
Leaving IClassFactory_QueryInterface()
Entering IClassFactory_Release()
g_lObjs = 1
Leaving IClassFactory_Release()
CoGetClassObject() Succeeded! We Now Have A IClassFactory Pointer!
Entering IClassFactory_CreateInstance()
pCD = 1396744
Varptr(@pCD.lpComCtrlVtbl) = 1396744
Varptr(@pCD.lpICPCVtbl) = 1396748
Varptr(@pCD.lpICPVtbl) = 1396752
@ppv = 0 << Before QueryInterface() Call
Entering IComCtrl_QueryInterface()
Trying To Get IComCtrl
Entering IComCtrl_AddRef()
@pCD.m_cRef = 1
Leaving IComCtrl_AddRef()
this = 1396744
Leaving IComCtrl_QueryInterface()
@ppv = 1396744 << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()
pCF->CreateInstance() Succeeded!
Entering IComCtrl_Initialize()
this = 1396744
Leaving IComCtrl_Initialize()
pComCtrl->Initialize() Succeeded!
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPointContainer
this = 1396744
this = 1396748
Leaving IComCtrl_QueryInterface()
Got pConnectionPointContainer1 = 1396748
Entering IConnectionPointContainer_FindConnectionPoint()
this = 1396748
@ppCP = 0
Entering IConnectionPointContainer_QueryInterface()
Looking For IID_IConnectionPoint
Leaving IConnectionPointContainer_QueryInterface()
@ppCP = 1396752
Leaving IConnectionPointContainer_FindConnectionPoint()
Got pConnectionPoint1 = 1396752
Entering CSink Constructor!
this = 8849240
Leaving CSink Constructor!
mySink = 8849240
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
pUnkSink = 8849240
@pUnkSink = 4227344
Vtbl = 4227344
@Vtbl[0] = 4198656
g_ptrOutGoing = 0 << Before Call Of QueryInterface() On Sink
Called CSink::QueryInterface() -- this = 8849240
Client: CSink::QueryInterface() for IOutGoing -- this = 8849240
*ppv = 8849240
Entering CSink::AddRef()
this->m_cRef = 1
Leaving CSink::AddRef()
g_ptrOutGoing = 8849240 << After Call Of QueryInterface() On Sink
Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!
pConnectionPoint1->Advise() Succeeded!
Entering IComCtrl_CreateControl()
this = 1396744
Leaving IComCtrl_CreateControl()
pComCtrl1->CreateControl(hContainer) Succeeded!
Entering IClassFactory_CreateInstance()
pCD = 1400160
Varptr(@pCD.lpComCtrlVtbl) = 1400160
Varptr(@pCD.lpICPCVtbl) = 1400164
Varptr(@pCD.lpICPVtbl) = 1400168
@ppv = 0 << Before QueryInterface() Call
Entering IComCtrl_QueryInterface()
Trying To Get IComCtrl
Entering IComCtrl_AddRef()
@pCD.m_cRef = 1
Leaving IComCtrl_AddRef()
this = 1400160
Leaving IComCtrl_QueryInterface()
@ppv = 1400160 << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()
pCF->CreateInstance() For pComCtrl2 Succeeded!
Entering IComCtrl_CreateControl()
this = 1400160
Leaving IComCtrl_CreateControl()
pComCtrl2->CreateControl((int)hContainer2) Succeeded!
Entering IComCtrl_QueryInterface()
Trying To Get IConnectionPointContainer
this = 1400160
this = 1400164
Leaving IComCtrl_QueryInterface()
Got pConnectionPointContainer2 = 1400164
Entering IConnectionPointContainer_FindConnectionPoint()
this = 1400164
@ppCP = 0
Entering IConnectionPointContainer_QueryInterface()
Looking For IID_IConnectionPoint
Leaving IConnectionPointContainer_QueryInterface()
@ppCP = 1400168
Leaving IConnectionPointContainer_FindConnectionPoint()
Got pConnectionPoint2 = 1400168
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
pUnkSink = 8849240
@pUnkSink = 4227344
Vtbl = 4227344
@Vtbl[0] = 4198656
g_ptrOutGoing = 8849240 << Before Call Of QueryInterface() On Sink
Called CSink::QueryInterface() -- this = 8849240
Client: CSink::QueryInterface() for IOutGoing -- this = 8849240
*ppv = 8849240
Entering CSink::AddRef()
this->m_cRef = 2
Leaving CSink::AddRef()
g_ptrOutGoing = 8849240 << After Call Of QueryInterface() On Sink
Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!
pConnectionPoint2->Advise() Succeeded!
Entering IClassFactory_Release()
g_lObjs = 2
Leaving IClassFactory_Release()
Leaving fnWndProc_OnCreate()
Entering IComCtrl_SetColor()
Leaving IComCtrl_SetColor()
Entering IComCtrl_SetColor()
Leaving IComCtrl_SetColor()
Entering fnWndProc_OnCommand() : Case IDC_KILL_CTL1
pComCtrl1 = 1396744
The Control Apparently Exists, And Will ow Be Destroyed!
Entering IConnectionPoint_Unadvise()
Entering CSink::Release()
this = 8849240
m_cRef != 0 : m_cRef=1
Release() Returned 1
Leaving IConnectionPoint_Unadvise()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Entering IComCtrl_Release()
@pCD.m_cRef = 1
@pCD.m_cRef = 0
CD Was Deleted!
Leaving IComCtrl_Release()
Leaving fnWndProc_OnCommand() : Case IDC_KILL_CTL1
WM_LBUTTONDOWN
g_ptrOutGoing = 8849240
Entering CSink::ControlEvent()
CSink::ControlEvent From hWnd 1115418
Leaving CSink::GotMessage()
Entering IComCtrl_SetColor()
Leaving IComCtrl_SetColor()
Entering fnWndProc_OnClose()
pComCtrl Is FALSE!!!!!!!!!!!!!!
Entering IConnectionPoint_Unadvise()
Entering CSink::Release()
this = 8849240
m_cRef == 0 And Will Now Delete CSink!
Leaving CSink::Release()
Release() Returned 0
Leaving IConnectionPoint_Unadvise()
Entering IConnectionPoint_Release()
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
Leaving IConnectionPointContainer_Release()
Got In Where pComCtr2 Is True!!!
Entering IComCtrl_Release()
@pCD.m_cRef = 1
@pCD.m_cRef = 0
CD Was Deleted!
Leaving IComCtrl_Release()
Leaving fnWndProc_OnClose()
Entering DllCanUnloadNow()
I'm Outta Here!
Leaving DllCanUnloadNow()
*/
Here is Main.h
//Main.h
#define IDC_BUTTON1 1300 //Control ID For Blue' Button
#define IDC_BUTTON2 1305 //Control ID For Green' Button
#define IDC_BUTTON3 1310 //Control ID For Red' Button
#define IDC_KILL_CTL1 1315 //Control ID For Kill CD
#define IDC_BUTTON4 1320 //Control ID For Blue' Button
#define IDC_BUTTON5 1325 //Control ID For Green' Button
#define IDC_BUTTON6 1330 //Control ID For Red' Button
#define IDC_KILL_CTL2 1335 //Control ID For Kill COM Ctrl2
interface ICOMCtrl : IUnknown
{
virtual HRESULT __stdcall Initialize ( )=0;
virtual HRESULT __stdcall CreateControl (const int)=0;
virtual HRESULT __stdcall SetColor (int )=0;
virtual HRESULT __stdcall GetColor (int* )=0;
virtual HRESULT __stdcall GetCtrlId (int* )=0;
virtual HRESULT __stdcall GetHWND (int* )=0;
};
typedef struct WindowsEventArguments
{
HWND hWnd;
WPARAM wParam;
LPARAM lParam;
HINSTANCE hIns;
}WndEventArgs, *lpWndEventArgs;
struct EVENTHANDLER
{
unsigned int Code;
long (*fnPtr)(lpWndEventArgs);
};
Here is CSink.cpp
//CSink.cpp
#include <windows.h>
#include <tchar.h>
#include <stdio.h>
#include <ocidl.h>
#include "Main.h"
#include "CSink.h"
extern ICOMCtrl* pComCtrl1;
extern ICOMCtrl* pComCtrl2;
extern "C" const IID IID_IOutGoing;
CSink::CSink() : m_cRef(0)
{
printf(_T("Entering CSink Constructor!\n"));
printf(_T(" this = %u\n"),this);
printf(_T("Leaving CSink Constructor!\n"));
}
ULONG CSink::AddRef()
{
printf("Entering CSink::AddRef()\n");
this->m_cRef++;
printf(_T(" this->m_cRef = %u\n"),this->m_cRef);
printf(_T("Leaving CSink::AddRef()\n"));
return m_cRef;
}
ULONG CSink::Release()
{
printf("Entering CSink::Release()\n");
printf(_T(" this = %u\n"),this);
if(--m_cRef != 0)
{
printf(" m_cRef != 0 : m_cRef=%u\n",m_cRef);
return m_cRef;
}
else
{
printf(" m_cRef == 0 And Will Now Delete CSink!\n");
delete this;
}
printf("Leaving CSink::Release()\n");
return 0;
}
HRESULT CSink::QueryInterface(REFIID riid, void** ppv)
{
printf("Called CSink::QueryInterface() -- this = %u\n",this);
if(riid == IID_IUnknown)
{
*ppv = (IUnknown*)this;
}
else if(riid == IID_IOutGoing)
{
printf("Client: CSink::QueryInterface() for IOutGoing -- this = %u\n", (IOutGoing*)this);
*ppv = (IOutGoing*)this;
printf("*ppv = %u\n", *ppv);
}
else
{
*ppv = NULL;
return E_NOINTERFACE;
}
AddRef();
return S_OK;
}
HRESULT CSink::ControlEvent(int hWindow)
{
TCHAR szBuffer[256]; //,szTmp[64];
int iWndHdl1=0,iWndHdl2=0; //iColor,iCtlId,
HWND hContainer=0,hMain=0;
_tprintf(_T("\nEntering CSink::ControlEvent()\n"));
printf(" CSink::ControlEvent From hWnd %u\n", hWindow);
if(pComCtrl1)
pComCtrl1->GetHWND(&iWndHdl1);
if(pComCtrl2)
pComCtrl2->GetHWND(&iWndHdl2);
if(iWndHdl1)
{
hContainer=GetParent((HWND)iWndHdl1);
hMain=GetParent(hContainer);
}
else
{
if(iWndHdl2)
{
hContainer=GetParent((HWND)iWndHdl1);
hMain=GetParent(hContainer);
}
else
hMain=0;
}
if(iWndHdl1==hWindow)
{
_tcscpy(szBuffer,_T("You Clicked On The Top COM Control!"));
MessageBox(hMain,szBuffer,_T("Report From Control #1!"),MB_OK);
}
if(iWndHdl2==hWindow)
{
_tcscpy(szBuffer,_T("You Clicked On The Bottom COM Control!"));
MessageBox(hMain,szBuffer,_T("Report From Control #2!"),MB_OK);
}
printf("Leaving CSink::GotMessage()\n\n");
return S_OK;
}
And finally CSink.h
//CSink.h
#ifndef CSINK_H
#define CSINK_H
interface IOutGoing : IUnknown //IOutGoing
{
virtual HRESULT __stdcall ControlEvent(int) = 0;
};
class CSink : public IOutGoing //CSink
{
public:
CSink();
~CSink() { }
HRESULT __stdcall QueryInterface(REFIID iid, void** ppv);
ULONG __stdcall AddRef(); //IUnknown
ULONG __stdcall Release();
HRESULT __stdcall ControlEvent(int Message); //IOutGoing
private:
long m_cRef;
};
#endif
One thing I might point out about that code is that since I was creating two controls I first called CoGetClassObject() instead of CoCreateInstance() and used that instead to create both controls. Now here is a PowerBASIC PB9 version that seems to be working but I'm pretty certain isn't quite right, simply because I'm not very good yet with handling sinks and sink interfaces in PowerBASIC. You can see some commented out code down in the WM_CLOSE handler that causes a crash after one x's out. If I kill one or the other of the controls then x out I'll get a crash if I try to disconnect the sink. However, the program works fine otherwise. You can kill one or the other of the controls, interact with it however you want, etc., but something still isn't right.
'CDClient2.inc
%IDC_CONTAINER1 = 1300 'Container For Top COM Control
%IDC_BUTTON1 = 1305 'Control ID For Blue' Button
%IDC_BUTTON2 = 1310 'Control ID For Green' Button
%IDC_BUTTON3 = 1315 'Control ID For Red' Button
%IDC_KILL_CTL1 = 1320 'Releases COM Control CD
%IDC_CONTAINER2 = 1400 'Container For Bottom COM Control
%IDC_BUTTON4 = 1405 'Control ID For Blue' Button
%IDC_BUTTON5 = 1410 'Control ID For Green' Button
%IDC_BUTTON6 = 1415 'Control ID For Red' Button
%IDC_KILL_CTL2 = 1420 'Releases COM Control CD
Interface IComCtrl $IID_IComCtrl : Inherit IAutomation
Method Initialize()
Method CreateControl(Byval hParent As Long)
Method SetColor(Byval iColor As Long)
Method GetColor() As Long
Method GetCtrlId() As Long
Method GetHWND() As Long
End Interface
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
'CDClient2.bas
#Compile Exe
#Include "Win32api.inc"
$CLSID_CE = GUID$("{20000000-0000-0000-0000-000000000040}")
$IID_ICOMCtrl = GUID$("{20000000-0000-0000-0000-000000000041}")
$IID_IOutGoing = GUID$("{20000000-0000-0000-0000-000000000042}")
#Include "CDClient2.inc"
Global MsgHdlr() As MessageHandler
Global pComCtrl1 As IComCtrl
Global pComCtrl2 As IComCtrl
Class EventClass As Event
Interface IOutGoing $IID_IOutGoing As Event : Inherit IAutomation
Method ControlEvent(Byval iHandle As Long)
Local iCtrlId1, iWndHdl1,iCtrlId2,iWndHdl2 As Long
Local strMessage As String
If IsObject(pComCtrl1) Then
iWndHdl1=pComCtrl1.GetHWND()
End If
If IsObject(pComCtrl2) Then
iWndHdl2=pComCtrl2.GetHWND()
End If
If iHandle=iWndHdl1 Then
Select Case As Long pComCtrl1.GetColor()
Case RGB(255,255,0)
strMessage = "The Top COM Control Is Yellow! Its Control ID Is" & $CrLf
Case RGB(0,0,255)
strMessage = "The Top COM Control Is Blue! Its Control ID Is" & $CrLf
Case RGB(0,255,0)
strMessage = "The Top COM Control Is Green! Its Control ID Is" & $CrLf
Case RGB(255,0,0)
strMessage = "The Top COM Control Is Red! Its Control ID Is" & $CrLf
End Select
iCtrlId1=pComCtrl1.GetCtrlId()
strMessage = strMessage & Str$(iCtrlId1) & " And Its hWnd Is " & Str$(iWndHdl1) & "."
MsgBox(strMessage)
End If
If iHandle=iWndHdl2 Then
Select Case As Long pComCtrl2.GetColor()
Case RGB(255,255,0)
strMessage = "The Bottom COM Control Is Yellow! Its Control ID Is" & $CrLf
Case RGB(0,0,255)
strMessage = "The Bottom COM Control Is Blue! Its Control ID Is" & $CrLf
Case RGB(0,255,0)
strMessage = "The Bottom COM Control Is Green! Its Control ID Is" & $CrLf
Case RGB(255,0,0)
strMessage = "The Bottom COM Control Is Red! Its Control ID Is" & $CrLf
End Select
iCtrlId2=pComCtrl2.GetCtrlId()
strMessage = strMessage & Str$(iCtrlId2) & " And Its hWnd Is " & Str$(iWndHdl2) & "."
MsgBox(strMessage)
End If
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long
Local hContainer1,hContainer2,hButton,dwStyle As Dword
Local pCreateStruct As CREATESTRUCT Ptr
Global pSink As IOutGoing
pCreateStruct=wea.lParam
wea.hInst=@pCreateStruct.hInstance
dwStyle=%WS_CHILD Or %WS_VISIBLE Or %WS_THICKFRAME
hButton=CreateWindowEx(0,"button","Blue",%WS_CHILD Or %WS_VISIBLE,8,10,80,25,wea.hWnd,%IDC_BUTTON1,wea.hInst,ByVal 0)
hButton=CreateWindowEx(0,"button","Green",%WS_CHILD Or %WS_VISIBLE,8,40,80,25,wea.hWnd,%IDC_BUTTON2,wea.hInst,ByVal 0)
hButton=CreateWindowEx(0,"button","Red",%WS_CHILD Or %WS_VISIBLE,8,70,80,25,wea.hWnd,%IDC_BUTTON3,wea.hInst,ByVal 0)
hButton=CreateWindowEx(0,"button","Kill #1",%WS_CHILD Or %WS_VISIBLE,385,40,80,25,wea.hWnd,%IDC_KILL_CTL1,wea.hInst,ByVal 0)
hContainer1=CreateWindowEx(%WS_EX_CLIENTEDGE,"static","",dwStyle,100,12,275,80,Wea.hWnd,%IDC_CONTAINER1,Wea.hInst,Byval 0)
hButton=CreateWindowEx(0,"button","Blue",%WS_CHILD Or %WS_VISIBLE,8,110,80,25,wea.hWnd,%IDC_BUTTON4,wea.hInst,ByVal 0)
hButton=CreateWindowEx(0,"button","Green",%WS_CHILD Or %WS_VISIBLE,8,140,80,25,wea.hWnd,%IDC_BUTTON5,wea.hInst,ByVal 0)
hButton=CreateWindowEx(0,"button","Red",%WS_CHILD Or %WS_VISIBLE,8,170,80,25,wea.hWnd,%IDC_BUTTON6,wea.hInst,ByVal 0)
hButton=CreateWindowEx(0,"button","Kill #2",%WS_CHILD Or %WS_VISIBLE,385,140,80,25,wea.hWnd,%IDC_KILL_CTL2,wea.hInst,ByVal 0)
hContainer2=CreateWindowEx(%WS_EX_CLIENTEDGE,"static","",dwStyle,100,110,275,80,Wea.hWnd,%IDC_CONTAINER2,Wea.hInst,Byval 0)
Call AllocConsole()
Let pComCtrl1 = NewCom "ComCtrl.CD"
Let pComCtrl2 = NewCom "ComCtrl.CD"
Let pSink = Class "EventClass"
Events From pComCtrl1 Call pSink
Events From pComCtrl2 Call pSink
pComCtrl1.Initialize()
pComCtrl1.CreateControl(hContainer1)
pComCtrl2.CreateControl(hContainer2)
fnWndProc_OnCreate=0
End Function
Function fnWndProc_OnCommand(wea As WndEventArgs) As Long
Select Case As Long LoWrd(Wea.wParam)
Case %IDC_BUTTON1 'Blue
If IsObject(pComCtrl1) Then
pComCtrl1.SetColor(RGB(0,0,255))
End If
Case %IDC_BUTTON2 'Green
If IsObject(pComCtrl1) Then
pComCtrl1.SetColor(RGB(0,255,0))
End If
Case %IDC_BUTTON3 'Red
If IsObject(pComCtrl1) Then
pComCtrl1.SetColor(RGB(255,0,0))
End If
Case %IDC_KILL_CTL1
If IsObject(pComCtrl1) Then
pComCtrl1.Release()
Set pComCtrl1=Nothing
Events End pComCtrl1
End If
Case %IDC_BUTTON4 'Blue
If IsObject(pComCtrl2) Then
pComCtrl2.SetColor(RGB(0,0,255))
End If
Case %IDC_BUTTON5 'Green
If IsObject(pComCtrl2) Then
pComCtrl2.SetColor(RGB(0,255,0))
End If
Case %IDC_BUTTON6 'Red
If IsObject(pComCtrl2) Then
pComCtrl2.SetColor(RGB(255,0,0))
End If
Case %IDC_KILL_CTL2
If IsObject(pComCtrl2) Then
pComCtrl2.Release()
Set pComCtrl2=Nothing
Events End pComCtrl2
End If
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnClose(wea As WndEventArgs) As Long
'If IsObject(pComCtrl1) Then
' Events End pComCtrl1
' Set pComCtrl1=Nothing
'End If
'If IsObject(pComCtrl2) Then
' Events End pComCtrl2
' Set pComCtrl2=Nothing
'End If
''Events End pSink
''Set pSink=Nothing
MsgBox("Just Released COM Control")
Call DestroyWindow(Wea.hWnd)
Call PostQuitMessage(0)
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
Local wea As WndEventArgs
Register iReturn As Long
Register i As Long
For i=0 To 2
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(2) 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_CLOSE : MsgHdlr(2).dwFnPtr=CodePtr(fnWndProc_OnClose)
End Sub
Function WinMain(ByVal hIns As Long,ByVal hPrev As Long,ByVal lpCL As Asciiz Ptr,ByVal iShow As Long) As Long
Local szAppName As Asciiz*16
Local wc As WndClassEx
Local hWnd As Dword
Local Msg As tagMsg
Call AttachMessageHandlers() : szAppName="CEClient2"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbSize=SizeOf(wc) : wc.style=%CS_HREDRAW Or %CS_VREDRAW
wc.cbClsExtra=0 : wc.cbWndExtra=0
wc.hInstance=hIns : wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION)
wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW) : wc.hbrBackground=%COLOR_BTNFACE+1
wc.lpszMenuName=%NULL
Call RegisterClassEx(wc)
hWnd=CreateWindow(szAppName,"Visual COM Control Example",%WS_OVERLAPPEDWINDOW Xor %WS_MAXIMIZEBOX,400,550,500,240,0,0,hIns,ByVal 0)
Call ShowWindow(hWnd,iShow)
While GetMessage(Msg,%NULL,0,0)
TranslateMessage Msg
DispatchMessage Msg
Wend
Function=msg.wParam
End Function