• Welcome to Jose's Read Only Forum 2023.
 

Visual COM Control Work In Progress

Started by Frederick J. Harris, September 17, 2010, 09:53:44 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

Frederick J. Harris

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.

Frederick J. Harris

#1
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.

Frederick J. Harris

#2
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.

Frederick J. Harris

#3
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.

Frederick J. Harris

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()



Frederick J. Harris

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.

Frederick J. Harris

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()

Dominic Mitchell

#7
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.
Dominic Mitchell
Phoenix Visual Designer
http://www.phnxthunder.com

Frederick J. Harris

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. 

Frederick J. Harris

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.

Dominic Mitchell

#10

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?
Dominic Mitchell
Phoenix Visual Designer
http://www.phnxthunder.com

Frederick J. Harris

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.

Frederick J. Harris

#12
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



Frederick J. Harris

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?

Frederick J. Harris

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