Grid Custom Control Project - Converting It To COM

[Frederick J. Harris]

    Obviously, I've been working with this code for some time, and my usual testing sequence is to start the client, and when the grid becomes visible, I'll scroll it vertically one line so that cell ( 3, 2 ) is on the second line - not the third.  Then I'll WM_LBUTTONDOWN and click in cell ( 3, 2 ) to get the cursor blinking there (that creates an edit control there), and I'll delete the contents of that cell.  Then I type my name "Fred" into it, being careful to leave the edit control cursor blinking in cell 3, 2.  After that I click the button "Retrieve Cell (3,2)" beneath the grid on the client.  If the GUI isn't overtop of the console you should be getting various outputs within the console screen on these various interactions with the grid.  These are created by various Call Dword statements on the client's sink.  Finally, I'll click either the "Unload Grid" button, or the x button to end the app.  You'll then receive a blocking message box to tell you that you can copy the output from the console window if you like.  You need to use the console system menu to do that (right click in title bar).  As an aside, the whole reason I go through this little routine I described above is that for years and years I suffered through the SIGrid control's inability to successfully retrieve cell contents under that usage scenario, and its essentially why I wrote my own grid.

     Hopefully you've managed to get all this working.  If you are having problems contact me in Jose's Forum or the PowerBASIC Forum or at fharris@evenlink.com.

     Having presented all that, I think its time for me to state a problem with this first iteration of the grid COM control.  The issue concerns connection points.  In fact, I think its time I delve pretty deeply into connection points, because they are difficult, to say the least.  Some readers may recall quite some time ago I presented a simple version of a visual COM based control here at Jose's Forum. Here is the link....

http://www.jose.it-berater.org/smfforum/index.php?topic=3872.0

     Actually, I started this grid COM control with that code as a basis because I found out it successfully worked perfectly as far as I could tell with every client language I'm capable of programming with which includes C, C++, PowerBASIC, Visual Basic 6, and Visual Basic .NET. 

     That code was really an extreme over-simplification of the full 'by the books' connection point COM specification.  Fact is, it didn't really pass muster as being 'on spec' because, among other things, it didn't implement all the enumerators as required by the COM specification.  If you look at that code or the code for this grid you'll see many of the IConnectionPointContainer and IConnectionPoint members returning E_NOTIMPL.  This is specifically disallowed by the COM Specification (for connection points).  Having said that I'd like to point out a few facts.  All the books one might acquire on COM or Atl take this route of introducing the Connection Point topic by presenting first this stripped down and simplified version similar to what I presented.  The various authors state up front that while it may not exactly match the COM Specification, it might nonetheless be adequate in many or most instances.  Then, some authors will present a fully implemented connection point example, and others will state its simply to complicated to get into without framework support by tools from Microsoft such as ATL or MFC that auto-generate wizard produced code for the coder.  My personal belief is that this somewhat simplified connection point code is adequate in the case of ActiveX controls or COM controls as I am presenting them here.  They represent a special case situation.  Allow me to elaborate.

     In a full implementation of the connection point technology, an object might support multiple connection points, and each connection point might support multiple connections. Just what does that mean?   

     Lets take an example.  I'm just making this up, so please bear with me.  Say you have a Wall Street type firm that has many stock traders and the firm has some piece of software on a server perhaps that continually monitors incoming feeds of DOW stocks, NASDAQ stock companies, and perhaps companies trading in other exchanges, for example, foreign or S & P 500 stocks.  Lets say this piece of software is not a dll but an exe server.  The Connection Point technology works with both in process and out of process servers – both local and remote.  OK, lets further assume that the server maintains a connection point for each of these categories of stocks, i.e., one connection point for DOW stocks, another for NASDAQ, still another for S & P 500 stocks, etc.  Now, this trading house is full of traders and all kinds of financial wheeling and dealing folks, and each has a desk with one or more desktops or laptops on it.  These computers all run client software programs which connect with the services provided by this COM object which is monitoring the incoming feed on stock prices.  Some of the traders are only interested in DOW stocks, others only NASDAQ stocks, some both, etc.  In any case the main server which is monitoring the incoming financial feed for ALL stocks is keeping track of each client computer implementing an outgoing interface connected to it, and its connection points are actually wrapping an array of sink objects on these various computers.  For example, at one particular moment it might have five clients wanting to be notified through its DOW connection point of a change to a DOW stock's value.  Maybe it has 10 computers connected to its NASDAQ connection point wanting to be notified of a change to a NASDAQ stock price.  When it determines through its external feed that some stock changed in value it has to fire out event notifications to all the various computers wanting to be notified of an event for that specific connection point.  Its holding pointers to all these computers in an array, so it does this by looping through the array calling each external sink currently active. Of course, it has to also implement logic to disconnect a sink when a client closes a connection down.

     To give you just an idea of how a connection point might be set up to handle multiple connections (I didn't implement it here), a class might be created like so...

Code Select Expand


%MAX_CONNECTIONS                               = 16

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 CConnectionPointImpl
  lpICPVtbl                                       As IConnectionPointVtbl Ptr
  m_ref                                           As Dword
  m_cookie                                        As Dword
  m_position                                      As Long
  m_unkArray(%MAX_CONNECTIONS-1)                  As Dword Ptr                            <<<<Note Array Declaration!!!
  m_pConnectionPointContainer                     As IConnectionPointContainer1 Ptr
End Type

...
...

Type Grid
  lpIGridVtbl                                     As IGridVtbl Ptr
  lpICPCVtbl                                      As IConnectionPointContainerVtbl Ptr
  lpCPImpl                                        As CConnectionPointImpl Ptr
  hContainer                                      As Dword
  hControl                                        As Dword
  m_cRef                                          As Long
End Type


     In the above code snippet note I have a UDT named CConnectionPointImpl, and that class has a member m_unkArray(), which is an array the class maintains to hold all the addresses of the sink objects sent into it through the IConnectionPoint::Advise() method.  A pointer to this class is a member of the Grid class (see Grid::lpCPImpl above).   

     OK, I think I've made the point of showing some ways in which this connection point technology can become complicated because of its flexibility.  All kinds of topologies are supported by it.  You can have scenarios where you have one server firing event notifications to multiple clients, or you can have a situation where one client sink is being fired upon by multiple servers.  Or, you can also have a simple topology where there is only one server and one sink to be notified by it.  Unless I am mistaken in my reasoning, this later simplified case is the likely scenario or topology of an in process connectable COM object that is in fact some type of visual control or component such as a grid.  How could it really be otherwise?  Think for a moment of the typical messaging that goes on in the Window Procedure of an application involving the WM_COMMAND message and buttons.  Lets assume you have two buttons on a Form with separate procedures to carry out whatever processing needs to be done for each respective button click.  If the user clicks button #1, is it really useful that button #2 be informed of it in a separate message?  Well, in some cases maybe, but in those cases doesn't it make more sense for that logic to be in the client app rather than the server?  Doesn't it make more sense for Windows to send one WM_COMMAND message and as part of that message include the identifier of the button that was clicked, rather than sending a separate message to both buttons that button #1 was clicked?  This is essentially what is made possible by a full implementation of the connection point architecture.  In the case of our grid control, lets assume we have a client with four instantiations of the grid control on a form, i.e., some form has four grids on it, each with different data in it.  You then set focus on one of these grids and edit some data in a cell.  This activity would of course generate WM_KEYPRESS Windows messages.  Lets say this activity occurred in grid #1.  The full implementation of the connection point architecture would allow us to store for each grid pointers to the sinks of all the other grids, so that, when a keypress occurred in grid #1, the sinks for grid #'s 2, 3, and 4 would also be called.  In my mind, this is of dubious value.  If you actually would wish for something like this, I think it makes more sense to code it in the client rather than making it a feature of the grid.  Therefore, I've already decided that for any controls I make (definitely including this one here), I'm going to hold fast to a prescribed one to one relationship between the server, i.e., the control, and the sink to which it calls.

     Lets take a bit of a close look at what is happening with our connection point in our grid.  Up near the top of the source code for FHGrid1.bas is this global variable declaration...

Code Select Expand


Global g_ptrOutGoing  As Dword Ptr


What this variable is supposed to hold for the grid is the pointer to the client's sink which is to be notified.  The following two lines in the client PBClient1_v1.bas...

Code Select Expand


Let pSink = Class  "GridEvents"
Events From pGrid Call pSink     


...will cause the grid's IConnectionPoint_Advise() function to be called.  This function was 'plugged into' the IConnectionPoint VTable by CodePtr() down in DllGetClassObjectImpl().  Here is what our console output showed for this Advise() method when our client executed (reproduced from above)...

Code Select Expand


Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!
  pUnkSink      =  1371108
  @pUnkSink     =  2109324
  Vtbl          =  2109324 
  @Vtbl[0]      =  2115400 
  g_ptrOutGoing =  0       
  g_ptrOutGoing =  1371108
  Call Dword Succeeded!   
Leaving IConnectionPoint_Advise() And Still In One Piece!


And here is the function itself without the debug statements...

Code Select Expand


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
 
  Vtbl=@pUnkSink
  Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(g_ptrOutGoing)) To hr
  If SUCCEEDED(hr) Then
     @pdwCookie=1
  Else
     @pdwCookie=0
  End If
 
  Function=hr
End Function


     Let me discuss this code because its important.  The number 1371108 represents both the address of the instantiation of the client's "GridEvents" Class, and in this particular case, the address of where a pointer to the IGridEvents VTable is located.  This duality exists because the "GridEvents" Class only implements one interface, and a pointer to that interface will be at the base allocation of the class.  As you can see, this number came into the Advise() method through the pUnkSink parameter.  As you can also see, its the number that finally got stored in g_ptrOutGoing through some rather confusing and nasty logic.  At 1371108 is a pointer to the IGridEvents VTable, which starts at 2109324.  The first 'slot' in that VTable holds the number 2115400, and that is the address of where QueryInterface() is located for the "GridEvents" Class.  How do I know that, you ask?  I know it because it is the way it has to be for a COM class.  There is a standard in place.  A call Dword is then done to execute the Event Class's QueryInterface(), and the Guid of IID_IFHGridEvents is passed in.  Also passed in is the address (Varptr) of g_ptrOutGoing, so that a pointer to the sink interface can be returned in it if QueryInterface() can successfully satisfy the request for $IID_IFHGridEvents.  If you've read this paragraph about 10 times, studied the code, and are presently experiencing decent mental clarity, it might occur to you that it would have been a lot easier to just assign pUnkSink directly to g_ptrOutGoing, rather than following the above torturous path.  In this case it would have worked because the Class "EventClass" only implements one interface, and that interface pointer is located at the base allocation for the class.  But what if the client's sink interface was only one of four or five other interfaces implemented by a class, and it wasn't the first?  In that case it wouldn't have worked.  The QueryInterface would have been required to get the correct interface pointer out of the class.

     Unless you are a good bit smarter than I you might be having trouble with all this.  It is pretty 'deep'.  It occurred to me it might be clearer if I presented a low level client written in PowerBASIC without the 'WithEvents' stuff.  Then you would see the one to one relationship in procedure calls between what is going on in the client code and what is happening in the console output from the 'deep innards' of the COM Class.  Here then is PBClient2_v1, and note especially the fnWndProc_OnCreate() code where the grid is instantiated and IConnectionPointContainer and IConnectionPoint interface pointers are retrieved and used directly without the WithEvents stuff.  These interfaces are actually build into the compiler, and when using the PowerBASIC IDE, if you set the cursor in front of either IConnectionPointContainer or IConnectionPoint and hit the 'Help' icon, or press the F1 key, you'll be taken to a page with all kinds of good info on the usage of these interfaces (not).  On my setup they highlight in pretty blue too.

[Frederick J. Harris]

Code Select Expand


'PBClient2_v1.inc

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

Declare Function FnPtr(wea As WndEventArgs) As Long

Type MessageHandler
  wMessage As Long
  dwFnPtr As Dword
End Type
Global MsgHdlr()      As MessageHandler

Interface IGrid $IID_IFHGrid : Inherit IAutomation
  Method Initialize()
  Method Create _
  ( _
    Byval hParent     As Long, _
    Byval strSetup    As WString, _
    Byval x           As Long, _
    Byval y           As Long, _
    Byval cx          As Long, _
    Byval cy          As Long, _
    Byval iRows       As Long, _
    Byval iCols       As Long, _
    Byval iRowHt      As Long, _
    Byval strFontName As WString, _
    Byval iFontSize   As Long, _
    Byval iFontWeight As Long _
  )
  Method SetRowCount(Byval iRowCount As Long, Byval blnForce As Long)
  Method SetData(Byval iRow As Long, Byval iCol As Long, Byval strData As WString)
  Method GetData(Byval iRow As Long, Byval iCol As Long) As WString
  Method FlushData()
  Method Refresh()
  Method GetCtrlId() As Long
  Method GethGrid() As Long
End Interface


Class CGridEvents As Event
  Interface IGridEvents $IID_IGridEvents :  Inherit IAutomation
    Method Grid_OnKeyPress(Byval KeyCode As Long)
      Prnt "Got KeyPress From Grid!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
    End Method

    Method Grid_OnKeyDown(Byval KeyCode As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDown(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDblClk(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnPaste(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
      MsgBox("You Clicked For Row #" & Str$(iGridRow))
    End Method
  End Interface
End Class


And the main source code file....

Code Select Expand


'PBClien2_v1.bas
#Compile                         Exe
#Dim                             All
%UNICODE                         = 1
#If %Def(%UNICODE)
    Macro ZStr                   = WStringz
    Macro BStr                   = WString
    %SIZEOF_CHAR                 = 2
#Else
    Macro ZStr                   = Asciiz
    Macro BStr                   = String
    %SIZEOF_CHAR                 = 1
#EndIf
$CLSID_FHGrid                    = GUID$("{20000000-0000-0000-0000-000000000060}")
$IID_IFHGrid                     = GUID$("{20000000-0000-0000-0000-000000000061}")
$IID_IGridEvents                 = GUID$("{20000000-0000-0000-0000-000000000062}")
%IDC_RETRIEVE                    = 1500
%IDC_UNLOAD_GRID                 = 1505
#Include                         "Windows.inc"
#Include                         "ObjBase.inc"
#Include                         "PBClient2_v1.inc"
Global pSink                     As IGridEvents
Global pGrid                     As IGrid
Global pConPtCon                 As IConnectionPointContainer
Global pConPt                    As IConnectionPoint
Global dwCookie                  As Dword

Sub Prnt(strLn As BStr)
  Local iLen, iWritten As Long
  Local hStdOutput As Dword
  Local strNew As BStr
  hStdOutput=GetStdHandle(%STD_OUTPUT_HANDLE)
  strNew=strLn + $CrLf
  iLen = Len(strNew)
  WriteConsole(hStdOutput, Byval Strptr(strNew), iLen, iWritten, Byval 0)
End Sub


Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long
  Local pCreateStruct As CREATESTRUCT Ptr
  Local strSetup,strCoordinate As BStr
  Local EventGuid As Guid
  Local hCtl As Dword
  Register i As Long
  Register j As Long

  Call AllocConsole()                                                                     'Allocate A Console For Debug Output
  pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance                           'Get hInstance From CREATESTRUCT Ptr
  Let pGrid = NewCom "FHGrid1.Grid"                                                       'Instantiate COM Grid Class
  strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"   'Setup String For Grid
  pGrid.Initialize()                                                                      'Initialize Window Classes In Grid
  pGrid.Create(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE)     'IGrid Interface Method Call To Create Grid
  pConPtCon = pGrid                                                                       'QueryInterface() For IConnectionPointContainer
  EventGuid=$IID_IGridEvents                                                              'Convert Guid In Text Form To Raw Guid
  Call pConPtCon.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConPt))       'Find Connection Point
  Let pSink = Class  "CGridEvents"                                                        'Instantiate Event Sink Class
  Call pConPt.Advise(Byval Objptr(pSink), dwCookie)                                       'Notify Grid Component of Sink Address
  For i=1 To 25                                                                           'Load Grid With Sample Strings
    For j=1 To 5                                                                          'Refresh() Method Needs To Be
      strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"                     'Called Afterwards To Make Them Visible
      pGrid.SetData(i, j, strCoordinate)                                                  'The Button Lower Left Retrieves The
    Next j                                                                                'Text From Row 3, Col 2.  The Button
  Next i                                                                                  'Lower Right Unloads The Grid.
  pGrid.Refresh()
  hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,75,245,200,30,Wea.hWnd,%IDC_RETRIEVE,Wea.hInst,ByVal 0)
  hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,325,245,200,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)

  fnWndProc_OnCreate=0
End Function


Sub DestroyGrid()
  If IsTrue(IsObject(pConPt)) Then
     Call pConPt.Unadvise(dwCookie)
  End If
  If IsTrue(IsObject(pSink)) Then
     Set pSink     = Nothing
  End If
  If IsTrue(IsObject(pConPtCon)) Then
     Set pConPtCon = Nothing
  End If
  If IsTrue(IsObject(pConPt)) Then
     Set pConPt    = Nothing
  End If
  If IsTrue(IsObject(pGrid)) Then
     Set pGrid     = Nothing
  End If
End Sub


Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
  Local strData As BStr

  Select Case As Long Lowrd(Wea.wParam)
    Case %IDC_RETRIEVE
      pGrid.FlushData()
      strData=pGrid.GetData(3,2)
      MsgBox("Cell 3,2 Contains " & strData)
    Case %IDC_UNLOAD_GRID
      Call DestroyGrid()
      Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
      Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
      Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
  End Select

  fnWndProc_OnCommand=0
End Function


Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
  Call DestroyGrid()
  Call CoFreeUnusedLibraries()
  Call PostQuitMessage(0)
  Function=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_DESTROY  :   MsgHdlr(2).dwFnPtr=CodePtr(fnWndProc_OnDestroy)
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 ZStr*16
  Local wc As WndClassEx
  Local hWnd As Dword
  Local Msg As tagMsg

  szAppName="Grid Test"                           : Call AttachMessageHandlers()
  wc.lpszClassName=VarPtr(szAppName)              : wc.lpfnWndProc=CodePtr(fnWndProc)
  wc.cbClsExtra=0                                 : wc.cbWndExtra=0
  wc.style=%CS_HREDRAW Or %CS_VREDRAW             : wc.hInstance=hIns
  wc.cbSize=SizeOf(wc)                            : 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=CreateWindowEx(0,szAppName,szAppName,%WS_OVERLAPPEDWINDOW,200,100,600,330,0,0,hIns,ByVal 0)
  Call ShowWindow(hWnd,iShow)
  While GetMessage(Msg,%NULL,0,0)
    TranslateMessage Msg
    DispatchMessage Msg
  Wend : MsgBox("Last Chance To Get What You Can!")

  Function=msg.wParam
End Function



And here then would be the output from running this program with FHGrid1.dll....

Code Select Expand


Entering DllGetClassObjectImpl()
  Entering IClassFactory_QueryInterface()
    Entering IClassFactory_AddRef()
      g_lObjs =  1
    Leaving IClassFactory_AddRef()
    this =  2689732
  Leaving IClassFactory_QueryInterface()
  IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()

Entering IClassFactory_CreateInstance()
  pGrid                      =  4456360
  Varptr(@pGrid.lpIGridVtbl) =  4456360
  Varptr(@pGrid.lpICPCVtbl)  =  4456364
  Varptr(@pGrid.lpICPVtbl)   =  4456368
  @ppv                       =  0  << Before QueryInterface() Call
  Entering IGrid_QueryInterface()
    Trying To Get IFHGrid
    Entering IGrid_AddRef()
      @pGrid.m_cRef =  0  << Before
      @pGrid.m_cRef =  1  << After
    Leaving IGrid_AddRef()
    this =  4456360
  Leaving IGrid_QueryInterface()
  @ppv                       =  4456360  << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()

Entering IGrid_AddRef()
  @pGrid.m_cRef =  1  << Before
  @pGrid.m_cRef =  2  << After
Leaving IGrid_AddRef()

Entering IGrid_Release()
  @pGrid.m_cRef =  2  << Before
  @pGrid.m_cRef =  1  << After
Leaving IGrid_Release()

Entering IClassFactory_Release()
  g_lObjs =  1
Leaving IClassFactory_Release()

Entering IGrid_QueryInterface()
  Trying To Get IFHGrid
  Entering IGrid_AddRef()
    @pGrid.m_cRef =  1  << Before
    @pGrid.m_cRef =  2  << After
  Leaving IGrid_AddRef()
  this =  4456360
Leaving IGrid_QueryInterface()

Entering IGrid_Release()
  @pGrid.m_cRef =  2  << Before
  @pGrid.m_cRef =  1  << After
Leaving IGrid_Release()

Entering Initialize() -- IGrid_Initialize()
  GetModuleHandle() =  2621440
Leaving Initialize()

Entering IGrid_CreateGrid()
  this           =  4456360
  hContainer     =  459332
  strSetup       =  120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^
  x              =  10
  y              =  10
  cx             =  570
  cy             =  222
  iRows          =  25
  iCols          =  5
  iRowHt         =  20
  strFontName    =
  GetLastError() =  0
  hGrid          =  393808
Leaving IGrid_CreateGrid()

Entering IGrid_QueryInterface()
  Trying To Get IConnectionPointContainer
  this =  4456360
  Entering IConnectionPointContainer_AddRef()
    @pGrid.m_cRef =  1  << Before
    @pGrid.m_cRef =  2  << After
  Leaving IConnectionPointContainer_AddRef()
  this =  4456364
Leaving IGrid_QueryInterface()

Entering IConnectionPointContainer_FindConnectionPoint()
  this  =  4456364
  @ppCP =  0
  Entering IConnectionPointContainer_QueryInterface()
    Looking For IID_IConnectionPoint
    Entering IConnectionPoint_AddRef()
      @pGrid.m_cRef =  2  << Before
      @pGrid.m_cRef =  3  << After
    Leaving IConnectionPoint_AddRef()
  Leaving IConnectionPointContainer_QueryInterface()
  @ppCP =  4456368
Leaving IConnectionPointContainer_FindConnectionPoint()

Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!
  pUnkSink      =  4722948
  @pUnkSink     =  2109285
  Vtbl          =  2109285
  @Vtbl[0]      =  2115976
  g_ptrOutGoing =  0        << Before Call Of QueryInterface() On Sink
  g_ptrOutGoing =  4722948  << After Call Of QueryInterface() On Sink
  Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!

Got KeyPress From Grid! 102=f
Got KeyPress From Grid! 114=r
Got KeyPress From Grid! 101=e
Got KeyPress From Grid! 100=d

Entering IConnectionPoint_Unadvise()
  dwCookie =  1
  IGrid_Events::Release() Succeeded!
  Release() Returned  1
Leaving IConnectionPoint_Unadvise()

Entering IConnectionPointContainer_Release()
  @pGrid.m_cRef =  3  << Before
  @pGrid.m_cRef =  2  << After
Leaving IConnectionPointContainer_Release()

Entering IConnectionPoint_Release()
  @pGrid.m_cRef =  2    << Before
  @pGrid.m_cRef =  1    << After
Leaving IConnectionPoint_Release()

Entering IGrid_Release()
  @pGrid.m_cRef =  1  << Before
  @pGrid.m_cRef = 0   << After
  Grid Was Deleted!
Leaving IGrid_Release()

Entering DllCanUnloadNow()
  I'm Outta Here! (dll is unloaded)
Leaving DllCanUnloadNow()


     I wasn't going to present that program until later, after showing version 3, but I thought now would be a better time instead, because I'm discussing connection points.  I also mentioned somewhere above that there were problems with version 1.  Perhaps I'll mention some of them now and end my discussion of version 1.  And we can fix some of these problems in the next version.

     Let me pose this question.  What do you think would happen if the client attempted to instantiate two grid objects in the fnWndProc_OnCreate() message handler which creates the UI for the client app?  From the last example, and using the IConnectionPointContainer and IConnectionPoint interfaces directly, here s the code used to create a grid...

Code Select Expand


pGrid.Create(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE)     'IGrid Interface Method Call To Create Grid
pConPtCon = pGrid                                                                       'QueryInterface() For IConnectionPointContainer
EventGuid=$IID_IGridEvents                                                              'Convert Guid In Text Form To Raw Guid
Call pConPtCon.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConPt))       'Find Connection Point
Let pSink = Class  "CGridEvents"                                                        'Instantiate Event Sink Class
Call pConPt.Advise(Byval Objptr(pSink), dwCookie)                                       'Notify Grid Component of Sink Address


     I won't keep you in suspense.  Bad things will happen.  Recall above where we looked at the console output for the IConnectionPoint::Advise() method a global variable in the COM object g_ptrOutGoing got initialized with the address of the class in the client that implements the event sink.  Using the architecture to which I'm partial, i.e., a separate sink class for each grid, that would necessitate the storage within the COM object of multiple pointers to multiple sinks.  They certainly won't all go into scaler g_ptrOutGoing!  Let me show you what would actually happen.  Lets create two grids and two sinks...

Code Select Expand


Global pSink1         As IGridEvents
Global pGrid1         As IGrid
Global pSink2         As IGridEvents
Global pGrid2         As IGrid


Grid Creation Code...

Code Select Expand


'Grid #1
pGrid1.Create(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE)    'IGrid Interface Method Call To Create Grid #1
pConPtCon = pGrid1                                                                      'QueryInterface() For IConnectionPointContainer
EventGuid=$IID_IGridEvents                                                              'Convert Guid In Text Form To Raw Guid
Call pConPtCon.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConPt))       'Find Connection Point
Let pSink1 = Class  "CGridEvents1"                                                      'Instantiate Event Sink Class #1
Call pConPt.Advise(Byval Objptr(pSink1), dwCookie)                                      'Notify Grid Component of Sink #1 Address


'Grid #2
pGrid2.Create(Wea.hWnd,strSetup,10,300,570,218,12,5,28,"",18,%FW_DONTCARE)              'IGrid Interface Method Call To Create Grid #2
pConPtCon = pGrid2                                                                      'QueryInterface() For IConnectionPointContainer
EventGuid=$IID_IGridEvents                                                              'Convert Guid In Text Form To Raw Guid
Call pConPtCon.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConPt))       'Find Connection Point
Let pSink2 = Class  "CGridEvents2"                                                      'Instantiate Event Sink Class #2
Call pConPt.Advise(Byval Objptr(pSink2), dwCookie)                                      'Notify Grid Component of Sink #2 Address


In the above code snippet all the damage is being done in this line...

Code Select Expand


Call pConPt.Advise(Byval Objptr(pSink2), dwCookie)


The PowerBASIC ObjPtr() verb returns an interface pointer and its that number that is coming through in the Byval pUnkSink As Dword Ptr parameter of the Advise() method we looked at several paragraphs above.  And referring to that code you'll see the number is stored in g_ptrOutGoing.  Here is an example of what you might see for the setup of the connection point for grid #1....     

Code Select Expand


Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!
  pUnkSink      =  2887932
  @pUnkSink     =  2110933
  Vtbl          =  2110933
  @Vtbl[0]      =  2117192
  g_ptrOutGoing =  0  << Before Call Of QueryInterface() On Sink
  g_ptrOutGoing =  2887932  << After Call Of QueryInterface() On Sink
  Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!


The 2887932 number would be the address of the class for Event Sink #1.  Note that g_ptrOutGoing is zero at the outset, and after the QueryInterface call 2887932 was stored in it.  Here is what you might see in the Advise() method output when the connection point was setup for grid #2...

Code Select Expand


Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!
  pUnkSink      =  2887764
  @pUnkSink     =  2111101
  Vtbl          =  2111101
  @Vtbl[0]      =  2117192
  g_ptrOutGoing =  2887932  << Before Call Of QueryInterface() On Sink
  g_ptrOutGoing =  2887764  << After Call Of QueryInterface() On Sink
  Call Dword Succeeded!
Leaving IConnectionPoint_Advise() And Still In One Piece!


Note in the above code that the address of the first sink, i.e., 2887932, gets overwritten by the address of the second sink!  No good will come of this!  I'll end this presentation of version #1 on that note, and it will give you something to ponder until I get to version #2 where we'll fix it!

[Frederick J. Harris]

Just some final thoughts....

Don't try the above control, i.e., version 1 in Visual Basic or .NET.  It won't work!  You'll have to wait for version #3 for that!  Otherwise, it should work in C, C++, or PowerBASIC on x86 or x64 from Win2000 on up.

[Frederick J. Harris]

Version #2 Of Com Grid Control

     We left off several days ago with a problem in version #1 of our COM based grid control where the code only provided one Dword Ptr variable, i.e., g_ptrOutGoing, to hold the address of client sinks.  There are two conditions where this could be made to work.  The first condition would be where only one grid object at a time could be created by the COM server.  This is pretty unacceptable to me, and I imagine to everyone else as well.  What good would Windows itself be if you could only instantiate one edit control at a time? 

     The second condition where it could be made to work is something of a design or architectural consideration in that if each grid were assigned a separate control id (they are), then the host app could simply maintain one sink object, and parse outbound interface calls made into the single sink for the control id of the grid making the call.  For that to work the function signatures of my model declarations in the server would need to be modified to include the control id of the grid making the Call Dword outbound interface call.  As I presented them in version #1, the control id wasn't used.  If this were done then the logic would be analogous to what takes place in typical Windows messaging involving the WM_COMMAND or WM_NOTIFY messages where the control id is one of the parameters.

     But, I mentioned previously that I didn't want to take that route.  I think I could sum up my reasons for not wanting to do it under the category of cleanliness; I think it would be cleaner to maintain my one sink per one grid rule. 

     That being the case, something obviously needs to be done to allow our server to maintain multiple pointers to client sinks.  The first thought that might come to mind for a solution would be an array of Dword pointers instead of the simple variable, i.e., g_ArrayPtrOutGoing(?).  But, as suggested by my question mark for an array dimension, how big should it be?  And more subtle perhaps but definitely with the potential to be most damaging, how would one then associate pointers loaded into the array with the correct grid window handle when a call needed to be made to a client sink?  After all, the grid will have a window handle coming through the window procedure and none of the other parameters relate in any obvious way to the address of the client sink which needs to be called.  So to make this work infallible logic would need to be written to come up with a way of relating the address of the sink in the client and the window handle of the grid which calls it.

     This is a problem that Windows Sdk coders are pretty familiar with, really, that is, associating data pertaining to an instance of a window with the window object itself, that is, its internal structure within Windows.  The Api maintains various mechanism to do this such as the .cbWndExtra bytes member of the WNDCLASS struct, user data, and window properties.  Note that within the grid server there is this class to represent a grid....

Code Select Expand


Type CGrid
  lpIGridVtbl                         As IGridVtbl Ptr
  lpICPCVtbl                          As IConnectionPointContainerVtbl Ptr
  lpICPVtbl                           As IConnectionPointVtbl Ptr
  hWndCtrl                            As Dword
  m_cRef                              As Long
End Type


We'll obviously have one of these created for each instance of the grid, and note that one of the members is a window handle of the grid filled out in IGrid_CreateGrid()...

Code Select Expand


  hGrid=CreateWindowEx _
  ( _
    %WS_EX_OVERLAPPEDWINDOW, _
    "Grid", _
    Byval Strptr(strSetup), _
    dwStyle, _
    x, _
    y, _
    cx, _
    cy, _
    hContainer, _
    g_CtrlId, _
    g_hModule, _
    ByVal Varptr(gd) _
  )
  #If %Def(%DEBUG)
  Prnt "    GetLastError() = " & Str$(GetLastError())
  Prnt "    hGrid          = " & Str$(hGrid)
  #EndIf
  Incr g_CtrlId
  pGrid=this
  @pGrid.hWndCtrl=hGrid


     Further note that when an IConnectionPoint::Advise() call comes in the server will certainly have access to a CGrid pointer through the 'this' pointer, and that would present an excellent opportunity for storing the address of the client's sink in some way within the grid's internal structure.   Here is what we had in v1 of the COM Control...

Code Select Expand


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

  Vtbl=@pUnkSink
  Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(g_ptrOutGoing)) To hr
  If SUCCEEDED(hr) Then
     @pdwCookie=1
  Else
     @pdwCookie=0
  End If
 
  Function=hr
End Function


In that code the address of g_ptrOutGoing was passed back to the client in a QueryInterface() call on the client's sink class, and was thereby initialized in the server for later callback purposes.  What we'll do here in our modification is pass through to the client a local instead, i.e., dwPtr below, and within the procedure immediately store it at offset 4 in the grid's .cbWndExtra bytes.  At offset 0 is a pointer to a GridData structure that maintains state for each instance of the grid.  Here's the modified code...
           

Code Select Expand


Function IConnectionPoint_Advise(Byval this As IConnectionPoint1 Ptr, Byval pUnkSink As Dword Ptr, Byval pdwCookie As Dword Ptr) As Long
  Local Vtbl,dwPtr As Dword Ptr
  Local pGrid As Grid Ptr
  Local hr As Long
                                                        'this'
  Decr this : Decr this   'the IConnectionPoint VTable pointer is at bytes 8 through 11 of the grid's memory allocation, so we need to 'back off'
  pGrid=this              'a distance of two 32 bit pointer slots to get a valid CGrid Ptr, which we can then use to access @pGrid.hWndCtrl. 
  Vtbl=@pUnkSink
  Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(dwPtr)) To hr
  Call SetWindowLong(@pGrid.hWndCtrl,4,dwPtr)
  If SUCCEEDED(hr) Then
     @pdwCookie=1
  Else
     @pdwCookie=0
  End If

  Function=hr
End Function

     Before I provide the full code for version #2 of the control, I have to confess I made a few relatively minor changes to the Idl file, which will require a recompile of the type library.  Like before, I'll attach the updated FHGrid2.tlb file.  Here is the new idl file...

Code Select Expand


// fhGrid2.idl
import "unknwn.idl";

[object, uuid(20000000-0000-0000-0000-000000000066), oleautomation] interface IGrid : IUnknown
{
HRESULT Initialize();
HRESULT CreateGrid
(
  [in] int hParent,
  [in] BSTR strSetup,
  [in] int x,
  [in] int y,
  [in] int cx,
  [in] int cy,
  [in] int iRows,
  [in] int iCols,
  [in] int iRowHt,
  [in] BSTR strFontName,
  [in] int iFontSize,
  [in] int iFontWeight
);
HRESULT SetRowCount([in] int iRowCount, [in] int blnForce);
HRESULT SetData([in] int iRow, [in] int iCol, [in] BSTR strData);
HRESULT GetData([in] int iRow, [in] int iCol, [out, retval] BSTR* strData);
HRESULT FlushData();
HRESULT Refresh();
HRESULT GetCtrlId([out, retval] int* iCtrlId);
HRESULT GethGrid([out, retval] int* hWnd);
};

[object, uuid(20000000-0000-0000-0000-000000000067), oleautomation] interface IGridEvents : IUnknown
{
HRESULT Grid_OnKeyPress([in] int iKeyCode, [in] int iKeyData, [in] int iCellRow, [in] int iGridRow, [in] int iCol);
HRESULT Grid_OnKeyDown([in] int KeyCode, [in] int iKeyData, [in] int iCellRow, [in] int iGridRow, [in] int iCol);
HRESULT Grid_OnLButtonDown([in] int iCellRow, [in] int iGridRow, [in] int iCol);
HRESULT Grid_OnLButtonDblClk([in] int iCellRow, [in] int iGridRow, [in] int iCol);
HRESULT Grid_OnPaste([in] int iCellRow, [in] int iGridRow, [in] int iCol);
HRESULT Grid_OnVButtonClick([in] int iCellRow, [in] int iGridRow);
};

[uuid(20000000-0000-0000-0000-000000000068), helpstring("FHGrid2 TypeLib"), version(1.0)] library FHGrid2Library
{
importlib("stdole32.tlb");
interface IGrid;
interface IGridEvents;
[uuid(20000000-0000-0000-0000-000000000065)]
coclass FHGrid2
{
           interface IGrid;
  [source] interface IGridEvents;
}
};


[Frederick J. Harris]

     Without further ado here is version #2 of our grid COM Control (probably will need three posts to fit it all)...

Code Select Expand


#Compile                              Dll  "FHGrid2.dll"
#Dim                                  All
%DEBUG                                = 1
%UNICODE                              = 1
#If %Def(%UNICODE)
    Macro ZStr                        = WStringz        'This is exactly how C/C++ programmers handle the ansi/unicode
    Macro BStr                        = WString         'issue.  They have a macro called TCHAR that reduces to a single
    %SIZEOF_CHAR                      = 2               'byte char data type if UNICODE isn't defined and wchar_t if it
#Else
    Macro ZStr                        = Asciiz          'is defined.  wchar_t is a 'typedef' of an unsigned short int in
    Macro BStr                        = String          'C or C++, and that is a WORD or two byte sequence.  Just what
    %SIZEOF_CHAR                      = 1               'unicode uses.
#EndIf
#Include                              "Windows.inc"
#Include                              "Commctrl.inc
#Include                              "HeaderCtrl.inc"
#Resource                             Typelib, 1, "FHGrid2.tlb"

%IDC_GRID                             = 1400            'There are a number of simpler windows controls out of which the
%IDC_BASE                             = 1499            'grid is created.  The "Base" class is a child of the grid that
%SIZEOF_PTR                           = 4               'became necessary due to a truely miserable and intractable
%SIZEOF_HANDLE                        = 4               'SetWindowPos() problem I was having with the "Pane" class and
%ID_PANE                              = 1500            'the verticle buttons along the left edge of the grid.  The "Pane"
%ID_HEADER                            = 1505            'class is what scrolls horizontally.  Upon it sit the "Cell" objects
%ID_CELL                              = 1600            'which are just simple white windows.  When the user clicks in a cell an
%IDC_EDIT                             = 1605            'edit control is created over the cell and the parent set to the cell.

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 ptrKeyPress _
( _
  Byval this                          As Dword Ptr, _
  Byval iKeyCode                      As Long, _
  Byval iKeyData                      As Long, _
  Byval iCellRow                      As Long, _
  Byval iGridRow                      As Long, _
  Byval iCol                          As Long _
) As Long

Declare Function ptrKeyDown _
( _
  Byval this                          As Dword Ptr, _
  Byval iKeyCode                      As Long, _
  Byval iKeyData                      As Long, _
  Byval iCellRow                      As Long, _
  Byval iGridRow                      As Long, _
  Byval iCol                          As Long _
) As Long

Declare Function ptrLButtonDown _
( _
  Byval this                          As Dword Ptr, _
  Byval iCellRow                      As Long, _
  Byval iGridRow                      As Long, _
  Byval iCol                          As Long _
) As Long

Declare Function ptrLButtonDblClk _
( _
  Byval this                          As Dword Ptr, _
  Byval iCellRow                      As Long, _
  Byval iGridRow                      As Long, _
  Byval iCol                          As Long _
) As Long

Declare Function ptrPaste _
( _
  Byval this                          As Dword Ptr, _
  Byval iCellRow                      As Long, _
  Byval iGridRow                      As Long, _
  Byval iCol                          As Long _
) As Long

Declare Function ptrVButtonClick _
( _
  Byval this                          As Dword Ptr, _
  Byval iCellRow                      As Long, _
  Byval iGridRow                      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_FHGrid                         = Guid$("{20000000-0000-0000-0000-000000000065}")
$IID_IFHGrid                          = Guid$("{20000000-0000-0000-0000-000000000066}")
$IID_IFHGrid_Events                   = Guid$("{20000000-0000-0000-0000-000000000067}")
$IID_LIBID_FHGrid                     = Guid$("{20000000-0000-0000-0000-000000000068}")

Type IGridVtbl
  QueryInterface                      As Dword Ptr
  AddRef                              As Dword Ptr
  Release                             As Dword Ptr
  Initialize                          As Dword Ptr
  CreateGrid                          As Dword Ptr
  SetRowCount                         As Dword Ptr
  SetData                             As Dword Ptr
  GetData                             As Dword Ptr
  FlushData                           As Dword Ptr
  Refresh                             As Dword Ptr
  GetCtrlId                           As Dword Ptr
  GethGrid                            As Dword Ptr
End Type

Type IGrid
  lpVtbl                              As IGridVtbl 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 GridData
  iCtrlID                             As Long
  hParent                             As Dword
  hGrid                               As Dword
  hBase                               As Dword
  hPane                               As Dword
  hEdit                               As Dword
  cx                                  As Dword
  cy                                  As Dword
  hHeader                             As Dword
  iCols                               As Dword
  iRows                               As Dword
  iVisibleRows                        As Dword
  iRowHeight                          As Dword
  iPaneHeight                         As Dword
  iEditedCellRow                      As Long
  iEditedRow                          As Long
  iEditedCol                          As Long
  pColWidths                          As Dword Ptr
  pCellHandles                        As Dword Ptr
  pGridMemory                         As Dword Ptr
  pVButtons                           As Dword Ptr
  blnAddNew                           As Long
  iFontSize                           As Long
  iFontWeight                         As Long
  hFont                               As Dword
  szFontName                          As ZStr * 28
End Type


Type CGrid
  lpIGridVtbl                         As IGridVtbl Ptr
  lpICPCVtbl                          As IConnectionPointContainerVtbl Ptr
  lpICPVtbl                           As IConnectionPointVtbl Ptr
  hWndCtrl                            As Dword
  m_cRef                              As Long
End Type


Type IGridEventsVtbl
  QueryInterface                      As Dword Ptr
  AddRef                              As Dword Ptr
  Release                             As Dword Ptr
  Grid_OnKeyPress                     As Dword Ptr
  Grid_OnKeyDown                      As Dword Ptr
  Grid_OnLButtonDown                  As Dword Ptr
  Grid_OnLButtonDblClk                As Dword Ptr
  Grid_OnPaste                        As Dword Ptr
  Grid_OnVButtonClick                 As Dword Ptr
End Type

Type IGridEvents
  lpVtbl                              As IGridEventsVtbl 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

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

Declare Function FnPtr(wea As WndEventArgs) As Long

Type MessageHandler
  wMessage                            As Long
  dwFnPtr                             As Dword
End Type
Global MsgHdlr()                      As MessageHandler

Macro  dwIdx(r,c)                     = (r-1)*iRange + (c-1)            'Used to index from two dimensional row/col coordinates to zero based linear address space.
Global CDClassFactory                 As IClassFactory1                 'COM class involved in creation of object.  In OOP terminology its a COM Constructor
Global IClassFactory_Vtbl             As IClassFactoryVtbl              'Contains pointers to the five IClassFactory Interface Members
Global IGrid_Vtbl                     As IGridVtbl                      'This obj will hold pointers to all the functions that make up the IGrid interface
Global IConnPointContainer_Vtbl       As IConnectionPointContainerVtbl  'This obj will hold pointers to all the IConnectionPointContainer interface functions (5).
Global IConnPoint_Vtbl                As IConnectionPointVtbl           'This obj will hold pointers to all the IConnectionPoint interface functions (8) (some not implemented).
Global g_hModule                      As Dword                          'Global instance handle initialized in DllMain().
Global g_lLocks                       As Long                           'You can use this to lock this server in memory even if there are no outstanding objects alive.
Global g_lObjs                        As Long                           'This will be a count of how many Grid objects have been created by calls to IClassFactory::CreateInstance().
Global g_CtrlId                       As Long                           'I'm using this to bump a control id count up by one for each Grid created.
Global fnEditWndProc                  As Dword                          'This is for subclassing the edit control and is the address of the original edit control WndProc().

#If %Def(%DEBUG)
    Global fp                         As Long
#EndIf


Sub Prnt(strLn As BStr)
  Local iLen, iWritten As Long
  Local hStdOutput As Dword
  Local strNew As BStr
  hStdOutput=GetStdHandle(%STD_OUTPUT_HANDLE)
  strNew=strLn + $CrLf
  iLen = Len(strNew)
  WriteConsole(hStdOutput, Byval Strptr(strNew), iLen, iWritten, Byval 0)
End Sub


Function IGrid_QueryInterface(ByVal this As IGrid Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
  #If %Def(%DEBUG)
  Prnt "    Entering IGrid_QueryInterface()"
  #EndIf
  @ppv=%NULL
  Select Case iid
    Case $IID_IUnknown
      #If %Def(%DEBUG)
      Prnt "        Trying To Get IUnknown"
      #EndIf
      Call IGrid_AddRef(this)
      @ppv=this
      #If %Def(%DEBUG)
      Prnt "        this = " & Str$(this)
      Prnt "      Leaving IGrid_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case $IID_IFHGrid
      #If %Def(%DEBUG)
      Prnt "      Trying To Get IFHGrid"
      #EndIf
      Call IGrid_AddRef(this)
      @ppv=this
      #If %Def(%DEBUG)
      Prnt "      this = " & Str$(this)
      Prnt "    Leaving IGrid_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case $IID_IConnectionPointContainer
      #If %Def(%DEBUG)
      Prnt "        Trying To Get IConnectionPointContainer"
      Prnt "        this = " & Str$(this)
      #EndIf
      Incr this
      @ppv=this
      Call IConnectionPointContainer_AddRef(this)
      #If %Def(%DEBUG)
      Prnt "        this = " & Str$(this)
      Prnt "      Leaving IGrid_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case $IID_IConnectionPoint
      #If %Def(%DEBUG)
      Prnt "        Trying To Get IConnectionPoint"
      Prnt "        this = " & Str$(this)
      #EndIf
      Incr this : Incr this
      @ppv=this
      Call IConnectionPoint_AddRef(this)
      #If %Def(%DEBUG)
      Prnt "        this = " & Str$(this)
      Prnt "      Leaving IComCtrl_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case Else
      #If %Def(%DEBUG)
      Prnt "        Looking For Something I Ain't Got!"
      Prnt "      Leaving IGrid_QueryInterface()"
      #EndIf
  End Select

  Function=%E_NoInterface
End Function


Function IGrid_AddRef(ByVal this As IGrid Ptr) As Long
  Local pGrid As CGrid Ptr

  #If %Def(%DEBUG)
  Prnt "    Entering IGrid_AddRef()"
  #EndIf
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "      @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << Before"
  #EndIf
  Incr @pGrid.m_cRef
  #If %Def(%DEBUG)
  Prnt "      @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << After"
  Prnt "    Leaving IGrid_AddRef()"
  #EndIf

  IGrid_AddRef=@pGrid.m_cRef
End Function


Function IGrid_Release(ByVal this As IGrid Ptr) As Long
  Local pGrid As CGrid Ptr

  #If %Def(%DEBUG)
  Prnt "  Entering IGrid_Release()"
  #EndIf
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "    @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << Before"
  #EndIf
  Decr @pGrid.m_cRef
  If @pGrid.m_cRef=0 Then
     Call DestroyWindow(@pGrid.hWndCtrl)
     Call CoTaskMemFree(Byval this)
     Call InterlockedDecrement(g_lObjs)
     #If %Def(%DEBUG)
     Prnt "    @pGrid.m_cRef = 0   << After"
     Prnt "    Grid Was Deleted!"
     Prnt "  Leaving IGrid_Release()"
     #EndIf
     Function=0
  Else
     #If %Def(%DEBUG)
     Prnt "    @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << After"
     Prnt "  Leaving IGrid_Release()"
     #EndIf
     Function=@pGrid.m_cRef
  End If
End Function


Function IGrid_Initialize(Byval this As IGrid Ptr) As Long
  Local szClassName As ZStr*16
  Local wc As WNDCLASSEX

  #If %Def(%DEBUG)
      Prnt ""
      Prnt "  Entering Initialize() -- IGrid_Initialize()"
  #EndIf
  szClassName="Cell"
  wc.lpszClassName=VarPtr(szClassName)             : wc.lpfnWndProc=CodePtr(fnCellProc)
  wc.cbSize=SizeOf(wc)                             : wc.style=0
  wc.cbClsExtra=0                                  : wc.cbWndExtra=8
  wc.hInstance=g_hModule                           : wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION)
  wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW)   : wc.hbrBackground=GetStockObject(%WHITE_BRUSH)
  wc.lpszMenuName=%NULL
  If RegisterClassEx(wc)=%FALSE Then
     Function=%E_FAIL
     Exit Function
  End If

  szClassName="Pane"
  wc.lpszClassName=VarPtr(szClassName)             : wc.lpfnWndProc=CodePtr(fnPaneProc)
  wc.cbSize=SizeOf(wc)                             : wc.style=0
  wc.cbClsExtra=0                                  : wc.cbWndExtra=4
  wc.hInstance=g_hModule                           : wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION)
  wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW)   : wc.hbrBackground=GetStockObject(%WHITE_BRUSH)
  wc.lpszMenuName=%NULL
  If RegisterClassEx(wc)=%FALSE Then
     Function=%E_FAIL
     Exit Function
  End If

  szClassName="Base"
  wc.lpszClassName=VarPtr(szClassName)             : wc.lpfnWndProc=CodePtr(fnBaseProc)
  wc.cbSize=SizeOf(wc)                             : wc.style=0
  wc.cbClsExtra=0                                  : wc.cbWndExtra=0
  wc.hInstance=g_hModule                           : wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION)
  wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW)   : wc.hbrBackground=GetStockObject(%GRAY_BRUSH)
  wc.lpszMenuName=%NULL
  If RegisterClassEx(wc)=%FALSE Then
     Function=%E_FAIL
     Exit Function
  End If

  szClassName="Grid"
  wc.lpszClassName=VarPtr(szClassName)             : wc.lpfnWndProc=CodePtr(fnGridProc)
  wc.cbSize=SizeOf(wc)                             : wc.style=0
  wc.cbClsExtra=0                                  : wc.cbWndExtra=8
  wc.hInstance=g_hModule                           : wc.hIcon=LoadIcon(%NULL, ByVal %IDI_APPLICATION)
  wc.hCursor=LoadCursor(%NULL, ByVal %IDC_ARROW)   : wc.hbrBackground=GetStockObject(%DKGRAY_BRUSH)
  wc.lpszMenuName=%NULL
  #If %Def(%DEBUG)
  Prnt "    GetModuleHandle() = " & Str$(wc.hInstance)
  #EndIf
  If RegisterClassEx(wc)=%FALSE Then
     Function=%E_FAIL
     Exit Function
  End If

  Call AttachMessageHandlers()
  #If %Def(%DEBUG)
      Prnt "  Leaving Initialize()"
      Prnt ""
  #EndIf

  Function=%True
End Function


Function IGrid_CreateGrid _
  ( _
    ByVal this        As IGrid Ptr, _
    Byval hContainer  As Long, _
    Byval strSetup    As BStr, _
    Byval x           As Long, _
    Byval y           As Long, _
    Byval cx          As Long, _
    Byval cy          As Long, _
    Byval iRows       As Long, _
    Byval iCols       As Long, _
    Byval iRowHt      As Long, _
    Byval strFontName As BStr, _
    Byval iFontSize   As Long, _
    Byval iFontWeight As Long _
  ) As Long
  Local hGrid,dwStyle As Dword
  Local pGrid As CGrid Ptr
  Local gd As GridData

  #If %Def(%DEBUG)
  Prnt "  Entering IGrid_CreateGrid()"
  Prnt "    this           = " & Str$(this)
  Prnt "    hContainer     = " & Str$(hContainer)
  Prnt "    strSetup       = " & strSetup
  Prnt "    x              = " & Str$(x)
  Prnt "    y              = " & Str$(y)
  Prnt "    cx             = " & Str$(cx)
  Prnt "    cy             = " & Str$(cy)
  Prnt "    iRows          = " & Str$(iRows)
  Prnt "    iCols          = " & Str$(iCols)
  Prnt "    iRowHt         = " & Str$(iRowHt)
  Prnt "    strFontName    = " & strFontName
  #EndIf
  dwStyle        = %WS_CHILD Or %WS_VISIBLE Or %WS_HSCROLL Or %WS_VSCROLL
  gd.iCols       = iCols
  gd.iRowHeight  = iRowHt
  gd.szFontName  = strFontName
  gd.iFontSize   = iFontSize
  gd.iFontWeight = iFontWeight
  gd.iRows       = iRows
  hGrid=CreateWindowEx _
  ( _
    %WS_EX_OVERLAPPEDWINDOW, _
    "Grid", _
    Byval Strptr(strSetup), _
    dwStyle, _
    x, _
    y, _
    cx, _
    cy, _
    hContainer, _
    g_CtrlId, _
    g_hModule, _
    ByVal Varptr(gd) _
  )
  #If %Def(%DEBUG)
  Prnt "    GetLastError() = " & Str$(GetLastError())
  Prnt "    hGrid          = " & Str$(hGrid)
  #EndIf
  Incr g_CtrlId
  pGrid=this
  @pGrid.hWndCtrl=hGrid
  Call SetFocus(hGrid)
  #If %Def(%DEBUG)
  Prnt "  Leaving IGrid_CreateGrid()" : Prnt ""
  #EndIf

  Function=%S_OK
End Function


Function IGrid_SetRowCount(Byval this As IGrid Ptr, Byval iRowCount As Long, Byval blnForce As Long) As Long
  Local pGrid As CGrid Ptr

  pGrid=this
  If SetRowCount(@pGrid.hWndCtrl, iRowCount, blnForce) Then
     Function=%S_OK
  Else
     Function=%E_FAIL
  End If
End Function


Function IGrid_SetData(Byval this As IGrid Ptr, Byval iRow As Long, Byval iCol As Long, Byval strData As BStr) As Long
  Local pGrid As CGrid Ptr

  pGrid=this
  If SetGrid(@pGrid.hWndCtrl,iRow,iCol,strData) Then
     Function=%S_OK
  Else
     Function=%E_FAIL
  End If
End Function


Function IGrid_GetData(Byval this As IGrid Ptr, Byval iRow As Long, Byval iCol As Long, Byref strData As BStr) As Long
  Local pGrid As CGrid Ptr

  pGrid=this
  strData=GetGrid(@pGrid.hWndCtrl,iRow,iCol)
  If strData<>"" Then
     Function=%S_OK
  Else
     Function=%E_FAIL
  End If
End Function


Function IGrid_FlushData(Byval this As IGrid Ptr) As Long
  Local pGrid As CGrid Ptr

  pGrid=this
  If blnFlushEditControl(@pGrid.hWndCtrl) Then
     Function=%S_OK
  Else
     Function=%E_FAIL
  End If
End Function


Function IGrid_Refresh(Byval this As IGrid Ptr) As Long
  Local pGrid As CGrid Ptr
  pGrid=this
  Call Refresh(@pGrid.hWndCtrl)
  Function=%S_OK
End Function


Function IGrid_GetCtrlId(Byval this As IGrid Ptr, Byref iCtrlId As Long)  As Long
  Local pGridData As GridData Ptr
  Local pGrid As CGrid Ptr

  pGrid=this
  pGridData=GetWindowLong(@pGrid.hWndCtrl,0)
  If pGridData Then
     iCtrlId=@pGridData.iCtrlId
     Function=%S_OK
  Else
     Function=%E_FAIL
  End If
End Function


Function IGrid_GethGrid(Byval this As IGrid Ptr, Byref hGrid As Long)  As Long
  Local pGrid As CGrid Ptr

  pGrid=this
  hGrid=@pGrid.hWndCtrl
  If hGrid Then
     Function=%S_OK
  Else
     Function=%E_FAIL
  End If
End Function


Function SetRowCount(Byval hGrid As Long, Byval iRowCount As Long, Byval blnForce As Long) Export As Long
  Local pGridData As GridData Ptr
  Local iSize,blnFree As Long
  Local si As SCROLLINFO
  Register i As Long

  #If %Def(%DEBUG)
  Print #fp, "  Entering SetRowCount()"
  Print #fp,
  Print #fp, "    i         blnFree"
  Print #fp, "    ================="
  #EndIf
  pGridData=GetWindowLong(hGrid,0)
  iSize=@pGridData.iRows * @pGridData.iCols
  For i=0 To iSize - 1
    blnFree=GlobalFree(@pGridData.@pGridMemory[i])
    #If %Def(%DEBUG)
    Print #fp, "    " i, blnFree
    #EndIf
  Next i
  blnFree=GlobalFree(@pGridData.pGridMemory)
  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "     GlobalFree(@pGridData.pGridMemory) = " blnFree
  #EndIf

  'Create New Memory Block
  iSize=iRowCount * @pGridData.iCols
  @pGridData.pGridMemory=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
  If @pGridData.pGridMemory Then
     @pGridData.iRows=iRowCount
     si.cbSize=Sizeof(SCROLLINFO)
     si.fMask=%SIF_RANGE Or %SIF_PAGE Or %SIF_POS
     si.nMin=1
     si.nMax=@pGridData.iRows
     si.nPage=@pGridData.iVisibleRows
     si.nPos=1
     Call SetScrollInfo(hGrid,%SB_VERT,si,%TRUE)
     Function=%TRUE : Exit Function
  End If

  #If %Def(%DEBUG)
  Print #fp, "  Leaving SetRowCount()"
  Print #fp,
  #EndIf

  Function=%FALSE
End Function


Sub Refresh(Byval hGrid As Dword) Export
  Local iRows,iCols,iCountCells,iIdx As Long
  Local pGridData As GridData Ptr
  Local pText As ZStr Ptr
  Local si As SCROLLINFO
  Register i As Long

  #If %Def(%DEBUG)
  Print #fp, "  Entering Refresh()"
  #EndIf
  pGridData=GetWindowLong(hGrid,0)
  iRows=@pGridData.iVisibleRows
  iCols=@pGridData.iCols
  iCountCells=iRows*iCols
  si.cbSize = sizeof(SCROLLINFO)
  si.fMask=%SIF_POS
  Call GetScrollInfo(hGrid,%SB_VERT,si)
  #If %Def(%DEBUG)
  Print #fp, "    @pGridData.iVisibleRows = " @pGridData.iVisibleRows
  Print #fp, "    @pGridData.iCols        = " @pGridData.iCols
  Print #fp, "    iCountCells             = " iCountCells
  Print #fp, "    si.nPos                 = " si.nPos
  Print #fp,
  Print #fp, "    i       @pCellHndls[i]  @pGridMem[i]  @pText"
  Print #fp, "    ============================================"
  #EndIf
  For i=0 To @pGridData.iVisibleRows * @pGridData.iCols - 1
    iIdx=iCols*(si.nPos-1)+i
    Call SetWindowLong(@pGridData.@pCellHandles[i],0,@pGridData.@pGridMemory[iIdx])
    Call InvalidateRect(@pGridData.@pCellHandles[i], Byval %NULL, %TRUE)
    pText=@pGridData.@pGridMemory[i]
    #If %Def(%DEBUG)
    Print #fp, "    " i, @pGridData.@pCellHandles[i], @pGridData.@pGridMemory[i], @pText
    #EndIf
  Next i
  #If %Def(%DEBUG)
  Print #fp, "  Leaving Refresh()"
  Print #fp,
  #EndIf
End Sub


Function SetGrid(Byval hGrid As Long, Byval iRow As Long, Byval iCol As Long, Byval strData As BStr) Export As Long
  Local iIndex,iRange,blnFree As Long
  Local pGridData As GridData Ptr
  Local pAsciz As ZStr Ptr
  Local hCell As Dword

  pGridData=GetWindowLong(hGrid,0)
  If iRow <= @pGridData.iRows And iCol <=@pGridData.iCols Then
     If iRow>0 And iCol>0 Then
        iRange=@pGridData.iCols
        iIndex=dwIdx(iRow,iCol)
        pAsciz=@pGridData.@pGridMemory[iIndex]
        If @pAsciz<>strData Then
           blnFree=GlobalFree(pAsciz)
           pAsciz=GlobalAlloc(%GPTR, (Len(strData)+1)*%SIZEOF_CHAR )
           @pAsciz=strData
           @pGridData.@pGridMemory[iIndex]=pAsciz
        End If
        SetGrid=%TRUE
        Exit Function
     End If
  End If

  Function=%FALSE
End Function


Function GetGrid(Byval hGrid As Long, Byval iRow As Long, Byval iCol As Long) Export As BStr
  Local pGridData As GridData Ptr
  Local iIndex,iRange As Long
  Local pZStr As ZStr Ptr

  pGridData=GetWindowLong(hGrid,0)
  If iRow <= @pGridData.iRows And iRow > 0 Then
     If iCol<=@pGridData.iCols And iCol>0  Then
        iRange=@pGridData.iCols
        iIndex=dwIdx(iRow,iCol)
        pZStr=@pGridData.@pGridMemory[iIndex]
        GetGrid=@pZStr
        Exit Function
     End If
  End If

  Function=""
End Function


Function blnFlushEditControl(Byval hGrid As Dword) Export As Long
  Local pGridData As GridData Ptr
  Local pZStr As ZStr Ptr
  Local strData As BStr
  Local iLen As Long

  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Entering blnFlushEditControl()"
  #EndIf
  pGridData=GetWindowLong(hGrid,0)
  If @pGridData.hEdit Then
     iLen=GetWindowTextLength(@pGridData.hEdit)
     pZStr=GlobalAlloc(%GPTR,(iLen+1)*%SIZEOF_CHAR)
     If pZStr Then
        Call GetWindowText(@pGridData.hEdit,Byval pZStr,iLen+1)
        strData=@pZStr
        Call SetGrid(hGrid,@pGridData.iEditedRow,@pGridData.iEditedCol,strData)
        Call SetWindowLong(@pGridData.hEdit,%GWL_WNDPROC,fnEditWndProc)
        Call DestroyWindow(@pGridData.hEdit)
        @pGridData.hEdit=0
        Call Refresh(hGrid)
     Else
        #If %Def(%DEBUG)
        Print #fp, "    Function=%FALSE"
        Print #fp, "  Leaving blnFlushEditControl()"
        Print #fp,
        #EndIf
        Function=%FALSE : Exit Function
     End If
  End If
  #If %Def(%DEBUG)
  Print #fp, "    Function=%TRUE"
  Print #fp, "  Leaving blnFlushEditControl()"
  Print #fp,
  #EndIf

  Function=%TRUE
End Function


[Frederick J. Harris]

continued...

Code Select Expand


Function fnEditSubClass(ByVal hEdit As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Local hCell,hPane,hBase,hGrid As Dword
  Local pGridData As GridData Ptr
  Local Vtbl,dwPtr As Dword Ptr
  Local iReturn,hr As Long

  #If %Def(%DEBUG)
  Print #fp, "  Entering fnEditSubClass"
  #EndIf
  hCell=GetParent(hEdit) : hPane=GetParent(hCell)
  hBase=GetParent(hPane) : hGrid=GetParent(hBase)
  pGridData=GetWindowLong(hPane,0)
  dwPtr=GetWindowLong(hGrid,4)
  Vtbl=@dwPtr
  Select Case As Long wMsg
    Case %WM_CHAR
      #If %Def(%DEBUG)
      Print #fp, "    Got WM_CHAR Message In fnEditSubClass!"
      #EndIf
      Call Dword @Vtbl[3] Using ptrKeyPress(dwPtr, wParam, lParam, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
      #If %Def(%DEBUG)
      If SUCCEEDED(hr) Then
         Print #fp, "    Call Dword @Vtbl[3] Using ptrKeyPress() Succeeded!"
      End If
      #EndIf
      If FAILED(hr) Then
         Function=0 : Exit Function
      End If
      If wParam=%VK_RETURN Then
         #If %Def(%DEBUG)
         Print #fp, "    Got WM_CHAR Message %VK_RETURN In fnEditSubClass!"
         #EndIf
         Call blnFlushEditControl(hGrid)
         Call Refresh(hGrid)
         #If %Def(%DEBUG)
         Print #fp, "  Leaving fnEditSubClass"
         Print #fp,
         #EndIf
         Exit Function
      Else
         @pGridData.hEdit=hEdit
      End If
    Case %WM_KEYDOWN
      #If %Def(%DEBUG)
      Print #fp, "    Got WM_KEYDOWN Message In fnEditSubClass!"
      #EndIf
      Call Dword @Vtbl[4] Using ptrKeyDown(dwPtr, wParam, lParam, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
      #If %Def(%DEBUG)
      If SUCCEEDED(hr) Then
         Print #fp, "    Call Dword @Vtbl[4] Using ptrKeyDown() Succeeded!"
      End If
      #EndIf
      If FAILED(hr) Then
         Function=0 : Exit Function
      End If
      #If %Def(%DEBUG)
      Print #fp, "    iReturn = " iReturn
      #EndIf
    Case %WM_PASTE
      #If %Def(%DEBUG)
      Print #fp, "    Got WM_PASTE Message In fnEditSubClass!"
      #EndIf
      Call Dword @Vtbl[7] Using ptrPaste(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
      #If %Def(%DEBUG)
      If SUCCEEDED(hr) Then
         Print #fp, "    Call Dword @Vtbl[7] Using ptrPaste() Succeeded!"
      End If
      #EndIf
      If FAILED(hr) Then
         Function=0 : Exit Function
      End If
    Case %WM_LBUTTONDBLCLK
      #If %Def(%DEBUG)
      Print #fp, "    Got %WM_LBUTTONDBLCLK Message In fnEditSubClass!"
      #EndIf
      Call Dword @Vtbl[6] Using ptrLButtonDblClk(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
      #If %Def(%DEBUG)
      If SUCCEEDED(hr) Then
         Print #fp, "    Call Dword @Vtbl[6] Using ptrPaste() Succeeded!"
      End If
      #EndIf
   End Select
  #If %Def(%DEBUG)
  Print #fp, "  Leaving fnEditSubClass"
  Print #fp,
  #EndIf

  Function=CallWindowProc(fnEditWndProc,hEdit,wMsg,wParam,lParam)
End Function


Function fnCellProc(ByVal hCell As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Select Case As Long wMsg
    Case %WM_CREATE
      Call SetWindowLong(hCell,0,%NULL)
      Function=0 : Exit Function
    Case %WM_LBUTTONDOWN
      Local iRange,iCellBufferPos,iGridMemOffset,iRow,iCol,hr As Long
      Local hPane,hBase,hGrid As Dword
      Local pGridData As GridData Ptr
      Local Vtbl,dwPtr As Dword Ptr
      Local si As SCROLLINFO
      Local pZStr As ZStr Ptr
      Register i As Long
      Register j As Long

      #If %Def(%DEBUG)
      Print #fp, "  Entering fnCellProc - Case WM_LBUTTONDOWN"
      #EndIf
      hPane=GetParent(hCell)
      hBase=GetParent(hPane)
      hGrid=GetParent(hBase)
      pGridData=GetWindowLong(hPane,0)
      Call blnFlushEditControl(hGrid)
      si.cbSize = sizeof(SCROLLINFO)
      si.fMask=%SIF_POS
      Call GetScrollInfo(hGrid,%SB_VERT,si)
      iRange=@pGridData.iCols
      For i=1 To @pGridData.iVisibleRows
        For j=1 To @pGridData.iCols
          iCellBufferPos = dwIdx(i,j)
          If @pGridData.@pCellHandles[iCellBufferPos]=hCell Then
             iGridMemOffset=iRange*(si.nPos-1)+iCellBufferPos                 'get rank of cell memory in
             pZStr=@pGridData.@pGridMemory[iGridMemOffset]
             iRow=i : iCol=j
             Exit, Exit
          End If
        Next j
      Next i
      @pGridData.hEdit=CreateWindow _
      ( _
        "edit", _
        "", _
        %WS_CHILD Or %WS_VISIBLE Or %ES_AUTOHSCROLL, _
        1, _
        0, _
        @pGridData.@pColWidths[iCol-1]-2, _
        @pGridData.iRowHeight, _
        hCell, _
        %IDC_EDIT, _
        GetModuleHandle(Byval 0), _
        ByVal 0 _
      )
      If @pGridData.hFont Then
         Call SendMessage(@pGridData.hEdit,%WM_SETFONT,@pGridData.hFont,%TRUE)
      End If
      Call SetWindowText(@pGridData.hEdit,@pZStr)
      fnEditWndProc=SetWindowLong(@pGridData.hEdit,%GWL_WNDPROC,CodePtr(fnEditSubClass))
      @pGridData.iEditedCellRow=iRow         'This is the one based row number in the visible grig
      @pGridData.iEditedRow=iRow+si.nPos-1   'This is the row in the buffer
      @pGridData.iEditedCol=iCol
      Call SetFocus(@pGridData.hEdit)
      dwPtr=GetWindowLong(hGrid,4)
      Vtbl=@dwPtr
      Call Dword @Vtbl[5] Using ptrLButtonDown(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
      #If %Def(%DEBUG)
      Print #fp, "    hGrid = " hGrid
      Print #fp, "    dwPtr = " dwPtr
      Print #fp, "    Vtbl  = " Vtbl
      Print #fp, "  Leaving fnCellProc - Case WM_LBUTTONDOWN" : Print #fp,
      #EndIf
      Function=0 : Exit Function
    Case %WM_PAINT
      Local hDC,hFont,hTmp As Dword
      Local pBuffer As ZStr Ptr
      Local ps As PAINTSTRUCT
      hDC=BeginPaint(hCell,ps)
      pBuffer=GetWindowLong(hCell,0)
      hFont=GetWindowLong(hCell,4)
      If hFont Then
         hTmp=SelectObject(hDC,hFont)
      End If
      Call TextOut(hDC,1,0,@pBuffer,Len(@pBuffer))
      If hFont Then
         hFont=SelectObject(hDC,hTmp)
      End If
      Call EndPaint(hCell,ps)
      Function=0 : Exit Function
  End Select

  fnCellProc=DefWindowProc(hCell, wMsg, wParam, lParam)
End Function



Function fnPaneProc(ByVal hPane As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Local si As SCROLLINFO
  Register i As Long
  Register j As Long

  Select Case As Long wMsg
    Case %WM_NOTIFY
      Local pGridData As GridData Ptr
      Local pNotify As HD_NOTIFY Ptr
      Local iPos(),iWidth() As Long
      Local index,iHt,iRange As Long
      Local iCols As Dword
      pNotify=lParam
      pGridData=GetWindowLong(hPane,0)
      Select Case As Long @pNotify.hdr.Code
        Case %HDN_TRACK
          #If %Def(%DEBUG)
          Print #fp, "  Entering fnPaneProc() - %HDN_TRACK Case"
          #EndIf
          If @pGridData.hEdit Then
             Call blnFlushEditControl(@pGridData.hGrid)
             Call Refresh(@pGridData.hGrid)
          End If
          If @pGridData.pColWidths Then
             @pGridData.@pColWidths[@pNotify.iItem]=@pNotify.@pItem.cxy
          End If
          iCols=@pGridData.iCols
          @pGridData.@pColWidths[iCols]=0
          For i=0 To iCols-1
            @pGridData.@pColWidths[iCols]=@pGridData.@pColWidths[iCols]+@pGridData.@pColWidths[i]
          Next i
          si.cbSize = sizeof(SCROLLINFO)
          si.fMask = %SIF_RANGE Or %SIF_PAGE Or %SIF_DISABLENOSCROLL
          si.nMin = 0 : si.nMax=@pGridData.@pColWidths[iCols]
          si.nPage=@pGridData.cx-33
          iRange=si.nMax-si.nMin
          Call SetScrollInfo(@pGridData.hGrid,%SB_HORZ,si,%TRUE)
          If iRange>si.nPage Then   'Original
             Call SetWindowPos(@pGridData.hPane,%HWND_TOP,0,0,@pGridData.@pColWidths[iCols],@pGridData.cy,%SWP_NOMOVE Or %SWP_SHOWWINDOW)
          Else
             Call SetWindowPos(@pGridData.hPane,%HWND_TOP,0,0,@pGridData.@pColWidths[iCols],@pGridData.cy,%SWP_SHOWWINDOW)
          End If
          Call SetWindowPos(@pGridData.hHeader,%HWND_BOTTOM,0,0,@pGridData.@pColWidths[iCols],@pGridData.iRowHeight,%SWP_NOMOVE Or %SWP_SHOWWINDOW)

          #If %Def(%DEBUG)
          Print #fp, "    si.nMin                       = " si.nMin
          Print #fp, "    si.nMax                       = " si.nMax
          Print #fp, "    si.nPage                      = " si.nPage
          Print #fp, "    @pGridData.@pColWidths[iCols] = " @pGridData.@pColWidths[iCols]
          #EndIf
          Redim iPos(iCols) As Long
          For i=1 To iCols-1
            iPos(i)=iPos(i-1)+@pGridData.@pColWidths[i-1]
          Next i
          If @pGridData.pCellHandles Then
             For i=0 To @pGridData.iVisibleRows-1
               For j=0 To iCols-1
                 index=iCols*i+j
                 iHt=@pGridData.iRowHeight
                 Call MoveWindow(@pGridData.@pCellHandles[index], iPos(j), iHt+(i*iHt), @pGridData.@pColWidths[j], iHt, %False)
               Next j
             Next i
             Call InvalidateRect(@pGridData.hGrid,Byval %NULL,%TRUE)
          End If
          Erase iPos()
          #If %Def(%DEBUG)
          Print #fp, "  Leaving fnPaneProc Case" : Print #fp,
          #EndIf
          Function=0
          Exit Function
        Case %HDN_ENDTRACK
          #If %Def(%DEBUG)
          Print #fp, "  Entering fnPaneProc() - %END_TRACK Case"
          #EndIf
          Call InvalidateRect(@pGridData.hGrid,Byval 0,%TRUE)
          #If %Def(%DEBUG)
          Print #fp, "  Leaving %END_TRACK Case"
          #EndIf
          Function=0 : Exit Function
      End Select
      Function=0 : Exit Function
  End Select

  fnPaneProc=DefWindowProc(hPane, wMsg, wParam, lParam)
End Function


Function fnBaseProc(ByVal hBase As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  fnBaseProc=DefWindowProc(hBase, wMsg, wParam, lParam)
End Function


Function fnGridProc_OnCreate(Wea As WndEventArgs) As Long
  Local iFlds,iHdlCount,iCols,iCtr,iSize As Long
  Local strParseData(),strFieldData() As BStr
  Local pGridData1,pGridData2 As GridData Ptr
  Local dwStyle,hButton,hCell,hDC As Dword
  Local pCreateStruct As CREATESTRUCT Ptr
  Local uCC As INIT_COMMON_CONTROLSEX
  Local szText As ZStr*64
  Local hdrItem As HDITEM
  Local strSetup As BStr
  Local iPos() As Long
  Register i As Long
  Register j As Long
  Local rc As RECT

  #If %Def(%DEBUG)
  Print #fp, "  Entering %WM_CREATE Case"
  #EndIf
  pCreateStruct=Wea.lParam
  Wea.hInst=@pCreateStruct.hInstance
  pGridData1=@pCreateStruct.lpCreateParams
  strSetup=@pCreateStruct.@lpszName
  Call GetClientRect(Wea.hWnd,rc)
  #If %Def(%DEBUG)
  Print #fp, "    %WM_USER                 = " %WM_USER
  Print #fp, "    %WM_APP                  = " %WM_APP
  Print #fp, "    hGrid                    = " Wea.hWnd
  Print #fp, "    pGridData1               = " pGridData1
  Print #fp, "    Wea.hInstance            = " Wea.hInst
  Print #fp, "    @pCreateStruct.cx        = " @pCreateStruct.cx
  Print #fp, "    @pCreateStruct.cy        = " @pCreateStruct.cy
  Print #fp, "    rc.Right                 = " rc.Right
  Print #fp, "    rc.Bottom                = " rc.Bottom
  Print #fp, "    @pGridData1.iFontSize    = " @pGridData1.iFontSize
  Print #fp, "    @pGridData1.iFontWeight  = " @pGridData1.iFontWeight
  Print #fp, "    @pGridData1.szFontName   = " @pGridData1.szFontName
  Print #fp, "    strSetup                 = " strSetup
  #EndIf
  uCC.dwSize = SizeOf(uCC)
  uCC.dwICC  = %ICC_LISTVIEW_CLASSES
  Call InitCommonControlsEx(uCC)
  iCols=ParseCount(strSetup,",")
  #If %Def(%DEBUG)
  Print #fp, "    iCols                    = " iCols
  Print #fp, "    @pGridData1.iRows        = " @pGridData1.iRows
  Print #fp, "    @pGridData1.iCols        = " @pGridData1.iCols
  Print #fp, "    @pGridData1.iRowHeight   = " @pGridData1.iRowHeight
  #EndIf
  If iCols<>@pGridData1.iCols Then
     Function=-1 : Exit Function
  End If
  pGridData2=GlobalAlloc(%GPTR,sizeof(GridData))
  If pGridData2=0 Then
     Function=-1 : Exit Function
  End If
  Call SetWindowLong(Wea.hWnd,0,pGridData2)
  @pGridData2.iCtrlID=@pCreateStruct.hMenu
  @pGridData2.cx=@pCreateStruct.cx
  @pGridData2.cy=@pCreateStruct.cy
  @pGridData2.iCols=iCols
  @pGridData2.iRows=@pGridData1.iRows
  @pGridData2.iRowHeight=@pGridData1.iRowHeight
  @pGridData2.iVisibleRows=Fix((rc.Bottom-@pGridData1.iRowHeight)/@pGridData1.iRowHeight)
  @pGridData2.iPaneHeight=(@pGridData2.iVisibleRows+1)*@pGridData1.iRowHeight
  @pGridData2.hGrid=Wea.hWnd
  @pGridData2.hParent=GetParent(Wea.hWnd)
  @pGridData1.iVisibleRows=@pGridData2.iVisibleRows
  #If %Def(%DEBUG)
  Print #fp, "    pGridData2               = " pGridData2
  Print #fp, "    @pGridData2.hParent      = " @pGridData2.hParent
  Print #fp, "    @pGridData2.iCtrlID      = " @pGridData2.iCtrlID
  Print #fp, "    @pGridData2.iPaneHeight  = " @pGridData2.iPaneHeight
  Print #fp, "    @pCreateStruct.cy        = " @pCreateStruct.cy
  Print #fp, "    @pGridData1.iRowHeight   = " @pGridData1.iRowHeight
  Print #fp, "    @pGridData2.iVisibleRows = " @pGridData2.iVisibleRows
  Print #fp, "    @pGridData2.iRows        = " @pGridData2.iRows
  #EndIf
  Redim strParseData(iCols) As BStr
  Parse strSetup,strParseData(),","
  @pGridData2.pColWidths=GlobalAlloc(%GPTR,(iCols+1)*%SIZEOF_PTR)
  If @pGridData2.pColWidths=0 Then
     Call GlobalFree(pGridData2)
     Function=-1 : Exit Function
  End If
  #If %Def(%DEBUG)
  Print #fp, "    @pGridData2.pColWidths   = " @pGridData2.pColWidths
  Print #fp,
  Print #fp, "    i         strParseData(i) "
  Print #fp, "    ============================="
  For i=0 To iCols-1
    Print #fp, "    " i, strParseData(i)
  Next i
  Print #fp,
  #EndIf

  @pGridData2.hBase=CreateWindowEx(0,"Base","",%WS_CHILD Or %WS_VISIBLE,0,0,0,0,Wea.hWnd,1499,Wea.hInst,Byval 0)
  dwStyle=%WS_CHILD Or %WS_BORDER Or %WS_VISIBLE Or %HDS_HOTTRACK Or %HDS_HORZ
  @pGridData2.hPane=CreateWindowEx(0,"Pane","",%WS_CHILD Or %WS_VISIBLE,0,0,0,0,@pGridData2.hBase,%ID_PANE,Wea.hInst,Byval 0)  'Create Pane
  @pGridData2.hHeader=CreateWindowEx(0,WC_HEADER,"",dwStyle,0,0,0,0,@pGridData2.hPane,%ID_HEADER,Wea.hInst,Byval 0)     'Create Header Control
  Call SetWindowLong(@pGridData2.hPane,0,pGridData2)
  #If %Def(%DEBUG)
  Print #fp, "    @pGridData2.hBase   = " @pGridData2.hBase
  Print #fp, "    @pGridData2.hPane   = " @pGridData2.hPane
  Print #fp, "    @pGridData2.hHeader = " @pGridData2.hHeader
  Print #fp,
  Print #fp, "    i     @pColWidths[i]     iPos(i)      szText"
  Print #fp, "    =================================================="
  #EndIf
  hdrItem.mask=%HDI_FORMAT Or %HDI_WIDTH Or %HDI_TEXT
  Redim iPos(iCols) As Long
  For i=0 To iCols-1
    iFlds=ParseCount(strParseData(i),":")
    Redim strFieldData(iFlds-1)
    Parse strParseData(i), strFieldData(), ":"
    @pGridData2.@pColWidths[i]=Val(strFieldData(0))
    @pGridData2.@pColWidths[iCols]=@pGridData2.@pColWidths[iCols]+@pGridData2.@pColWidths[i]
    hdrItem.cxy=@pGridData2.@pColWidths[i]
    szText=strFieldData(1)
    hdrItem.pszText=Varptr(szText) : hdrItem.cchTextMax=Len(szText)
    hdrItem.fmt=%HDF_STRING Or %HDF_CENTER
    'Call Header_InsertItem(@pGridData2.hHeader,i,Varptr(hdrItem))
    Call Header_InsertItem(@pGridData2.hHeader,i,hdrItem)
    If i Then
       iPos(i)=iPos(i-1)+@pGridData2.@pColWidths[i-1]
    End If
    #If %Def(%DEBUG)
    Print #fp, "   " i, @pGridData2.@pColWidths[i], iPos(i), szText
    #EndIf
    Erase strFieldData()
  Next i
  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "    @pGridData2.@pColWidths[iCols]   = " @pGridData2.@pColWidths[iCols]
  Print #fp,
  #EndIf
  Call MoveWindow(@pGridData2.hBase,12,0,rc.right-12,@pGridData2.iPaneHeight,%FALSE)
  Call MoveWindow(@pGridData2.hPane,0,0,@pGridData2.@pColWidths[iCols],@pGridData2.iPaneHeight,%FALSE)  'Size Pane
  Call MoveWindow(@pGridData2.hHeader,0,0,@pGridData2.@pColWidths[iCols],@pGridData2.iRowHeight,%TRUE)  'Size Header

  'Make Verticle Buttons
  @pGridData2.pVButtons=GlobalAlloc(%GPTR,(@pGridData2.iVisibleRows+1)*%SIZEOF_PTR)
  #If %Def(%DEBUG)
  Print #fp, "    @pGridData2.pVButtons = " @pGridData2.pVButtons
  Print #fp,
  Print #fp, "   i          @pGridData2.@pVButtons[i] "
  Print #fp, "   ====================================="
  #EndIf
  If @pGridData2.pVButtons Then
     For i=0 To @pGridData2.iVisibleRows
       @pGridData2.@pVButtons[i]=CreateWindow("button","",%WS_CHILD Or %WS_VISIBLE Or %BS_FLAT,0,@pGridData2.iRowHeight*i,12,@pGridData2.iRowHeight,Wea.hWnd,20000+i,Wea.hInst,Byval 0)
       #If %Def(%DEBUG)
       Print #fp, "   " i, @pGridData2.@pVButtons[i]
       #EndIf
     Next i
  Else
     Call GlobalFree(@pGridData2.pColWidths)
     Call GlobalFree(pGridData2)
     Function=-1 : Exit Function
  End If

  'Try To Create Font  ' ANSI_CHARSET  '%OEM_CHARSET
  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "    Now Gonna Try To Create Font..."
  Print #fp, "    @pGridData1.szFontName = " @pGridData1.szFontName
  #EndIf
  If @pGridData1.szFontName<>"" Then
     hDC=GetDC(Wea.hWnd)
     @pGridData2.hFont=CreateFont _
     ( _
       -1*(@pGridData1.iFontSize*GetDeviceCaps(hDC,%LOGPIXELSY))/72, _
       0, _
       0, _
       0, _
       @pGridData1.iFontWeight, _
       0, _
       0, _
       0, _
       %ANSI_CHARSET, _
       0, _
       0, _
       %DEFAULT_QUALITY, _
       0, _
       @pGridData1.szFontName _
     )
     Call ReleaseDC(Wea.hWnd,hDC)
  End If
  #If %Def(%DEBUG)
  Print #fp, "    @pGridData2.hFont      = " @pGridData2.hFont
  #EndIf

  'Try To Make Cells
  iHdlCount=@pGridData2.iCols*@pGridData2.iVisibleRows
  @pGridData2.pCellHandles=GlobalAlloc(%GPTR, iHdlCount * %SIZEOF_HANDLE)
  If @pGridData2.pCellHandles Then
     dwStyle=%WS_CHILD Or %WS_VISIBLE Or %WS_BORDER
     #If %Def(%DEBUG)
     Print #fp,
     Print #fp, "    i          j             iPos(j)       yLoc          hCell"
     Print #fp, "    ============================================================="
     #EndIf
     For i=0 To @pGridData2.iVisibleRows-1
       For j=0 To @pGridData2.iCols-1
         hCell=CreateWindowEx _
         ( _
           0, _
           "Cell", _
           "", _
           dwStyle, _
           iPos(j), _
           @pGridData2.iRowHeight+(i*@pGridData2.iRowHeight), _
           @pGridData2.@pColWidths[j], _
           @pGridData2.iRowHeight, _
           @pGridData2.hPane, _
           %ID_CELL+iCtr, _
           Wea.hInst, _
           Byval 0 _
         )
         @pGridData2.@pCellHandles[iCtr]=hCell
         Call SetWindowLong(hCell,4,@pGridData2.hFont)
         #If %Def(%DEBUG)
         Print #fp, "   " i, j, iPos(j), @pGridData2.iRowHeight+(i*@pGridData2.iRowHeight), hCell
         #EndIf
         Incr iCtr
       Next j
     Next i

     'Create Grid Memory
     iSize=@pGridData2.iCols * @pGridData2.iRows
     #If %Def(%DEBUG)
         Print #fp,
         Print #fp, "    Now Will Try To Create Grid Row Memory!"
         Print #fp,
         Print #fp, "    iSize = " iSize
     #EndIf
     @pGridData2.pGridMemory=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
     #If %Def(%DEBUG)
     Print #fp, "    @pGridData2.pGridMemory = " @pGridData2.pGridMemory
     #EndIf
  Else
     Erase strParseData()
     Erase iPos()
     Call GlobalFree(@pGridData2.pColWidths)
     Call GlobalFree(pGridData2)
     Function=-1 : Exit Function
  End If
  Erase strParseData()
  Erase iPos()
  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Leaving %WM_CREATE Case" : Print #fp,
  #EndIf

  Function=0
End Function


Function fnGridProc_OnSize(Wea As WndEventArgs) As Long
  Local pGridData As GridData Ptr
  Local si As SCROLLINFO
  Local iCols As Long

  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Entering %WM_SIZE Case"
  #EndIf
  pGridData=GetWindowLong(Wea.hWnd,0)
  iCols=@pGridData.iCols

  'Set Up Horizontal Scrollbar
  si.cbSize=Sizeof(SCROLLINFO)
  si.fMask=%SIF_RANGE Or %SIF_PAGE Or %SIF_POS
  si.nMin=0
  si.nMax=@pGridData.@pColWidths[iCols]
  si.nPage=@pGridData.cx-33 '33 is the width of vert
  si.nPos=0                 'btns + width scroll bar + window edge
  Call SetScrollInfo(Wea.hWnd,%SB_HORZ,si,%TRUE)
  #If %Def(%DEBUG)
  Print #fp, "    Horizontal Scrollbar...."
  Print #fp, "    si.nMin    = " si.nMin
  Print #fp, "    si.nMax    = " si.nMax
  Print #fp, "    si.nPos    = " si.nPos
  Print #fp,
  #EndIf

  'Set Up Verticle Scrollbar
  si.cbSize=Sizeof(SCROLLINFO)
  si.fMask=%SIF_RANGE Or %SIF_PAGE Or %SIF_POS
  si.nMin=1
  si.nMax=@pGridData.iRows
  si.nPage=@pGridData.iVisibleRows
  si.nPos=1
  Call SetScrollInfo(Wea.hWnd,%SB_VERT,si,%TRUE)
  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "    Verticle Scrollbar...."
  Print #fp, "    si.nMin    = " si.nMin
  Print #fp, "    si.nMax    = " si.nMax
  Print #fp, "    si.nPos    = " si.nPos
  Print #fp, "  Leaving %WM_SIZE Case" : Print #fp,
  #EndIf

  fnGridProc_OnSize=0
End Function


Function fnGridProc_OnHScroll(Wea As WndEventArgs) As Long
  Local pGridData As GridData Ptr
  Local iCols,iScrollPos As Long
  Local si As SCROLLINFO

  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Entering %WM_HSCROLL Case"
  #EndIf
  pGridData=GetWindowLong(Wea.hWnd,0)
  iCols=@pGridData.iCols
  si.cbSize = sizeof(SCROLLINFO)   : si.fMask=%SIF_ALL
  Call GetScrollInfo(@pGridData.hGrid,%SB_HORZ,si)
  iScrollPos=si.nPos
  #If %Def(%DEBUG)
  Print #fp, "    Before Adjustments"
  Print #fp, "    si.nMin    = " si.nMin
  Print #fp, "    si.nMax    = " si.nMax
  Print #fp, "    si.nPos    = " si.nPos
  Print #fp,
  #EndIf
  Select Case As Long Lowrd(Wea.wParam)
    Case %SB_LINELEFT
      #If %Def(%DEBUG)
      Print #fp, "    Got In %SB_LINELEFT"
      #EndIf
      If si.nPos > si.nMin Then
         si.nPos=si.nPos-50
      End If
    Case %SB_PAGELEFT
      si.nPos = si.nPos - si.nPage
    Case %SB_LINERIGHT
      #If %Def(%DEBUG)
      Print #fp, "    Got In %SB_LINERIGHT"
      #EndIf
      If si.nPos<si.nMax Then
         si.nPos=si.nPos+50
      End If
    Case %SB_PAGERIGHT
      si.nPos = si.nPos + si.nPage
    Case %SB_THUMBTRACK
      si.nPos=si.nTrackPos
  End Select
  si.fMask=%SIF_POS
  Call SetScrollInfo(@pGridData.hGrid,%SB_HORZ,si,%TRUE)
  Call GetScrollInfo(@pGridData.hGrid,%SB_HORZ,si)
  If iScrollPos<>si.nPos Then   'Original
     If si.nPos=0 Then
        Call SetWindowPos(@pGridData.hPane,%HWND_TOP,0,0,@pGridData.@pColWidths[iCols],@pGridData.iPaneHeight,%SWP_SHOWWINDOW)
     Else
        Call SetWindowPos(@pGridData.hPane,%HWND_TOP,-si.nPos,0,@pGridData.@pColWidths[iCols],@pGridData.iPaneHeight,%SWP_SHOWWINDOW)
     End If
  End If
  #If %Def(%DEBUG)
  Print #fp, "    After All Adjustments"
  Print #fp, "    si.nMin    = " si.nMin
  Print #fp, "    si.nMax    = " si.nMax
  Print #fp, "    si.nPos    = " si.nPos
  Print #fp, "  Leaving %WM_HSCROLL Case"
  #EndIf

  fnGridProc_OnHScroll=0
End Function


Function fnGridProc_OnVScroll(Wea As WndEventArgs) As Long
  Local pGridData As GridData Ptr
  Local iScrollPos As Long
  Local si As SCROLLINFO
  Local hCell As Dword
  Register i As Long

  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Entering %WM_VSCROLL Case"
  #EndIf
  pGridData=GetWindowLong(Wea.hWnd,0)
  Call blnFlushEditControl(@pGridData.hGrid)
  si.cbSize = sizeof(SCROLLINFO)   : si.fMask=%SIF_ALL
  Call GetScrollInfo(@pGridData.hGrid,%SB_VERT,si)
  iScrollPos=si.nPos
  #If %Def(%DEBUG)
  Print #fp, "    Before Adjustments"
  Print #fp, "    si.nMin    = " si.nMin
  Print #fp, "    si.nMax    = " si.nMax
  Print #fp, "    si.nPos    = " si.nPos
  Print #fp,
  #EndIf
  Select Case As Long Lowrd(Wea.wParam)
    Case %SB_LINEUP
      #If %Def(%DEBUG)
      Print #fp, "    Got In %SB_LINEUP"
      #EndIf
      If si.nPos > si.nMin Then
         si.nPos=si.nPos-1
      End If
    Case %SB_PAGEUP
      si.nPos = si.nPos - si.nPage
    Case %SB_LINEDOWN
      #If %Def(%DEBUG)
      Print #fp, "    Got In %SB_LINEDOWN"
      #EndIf
      If si.nPos<si.nMax Then
         si.nPos=si.nPos+1
      End If
    Case %SB_PAGEDOWN
      si.nPos = si.nPos + si.nPage
    Case %SB_THUMBTRACK
      si.nPos=si.nTrackPos
  End Select
  si.fMask=%SIF_POS
  Call SetScrollInfo(@pGridData.hGrid,%SB_VERT,si,%TRUE)
  Call GetScrollInfo(@pGridData.hGrid,%SB_VERT,si)
  If iScrollPos<>si.nPos Then
     Local iNum,iLast,iRange As Long
     iNum=@pGridData.iCols*(si.nPos-1)
     iRange=@pGridData.iCols
     iLast=(iRange * @pGridData.iVisibleRows) - 1
     For i=0 To iLast
       hCell=@pGridData.@pCellHandles[i]
       Call SetWindowLong(hCell,0,@pGridData.@pGridMemory[iNum])
       Incr iNum
     Next i
  End If
  Call InvalidateRect(@pGridData.hGrid,Byval %NULL,%TRUE)
  #If %Def(%DEBUG)
  Print #fp, "    After All Adjustments"
  Print #fp, "    si.nMin    = " si.nMin
  Print #fp, "    si.nMax    = " si.nMax
  Print #fp, "    si.nPos    = " si.nPos
  Print #fp, "  Leaving %WM_VSCROLL Case"
  #EndIf

  fnGridProc_OnVScroll=0
End Function


Function fnGridProc_OnCommand(Wea As WndEventArgs) As Long     'from other code
  Local iCellRow,iGridRow,hr As Long
  Local pGridData As GridData Ptr
  Local Vtbl,dwPtr As Dword Ptr
  Local si As SCROLLINFO

  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Entering fnGridProc_OnCommand()"
  Print #fp, "    Lowrd(Wea.wParam) = " Lowrd(Wea.wParam)
  #EndIf
  If Lowrd(Wea.wParam)>20000 Then
     pGridData=GetWindowLong(Wea.hWnd,0)
     Call blnFlushEditControl(@pGridData.hGrid)
     si.cbSize = sizeof(SCROLLINFO)
     si.fMask=%SIF_POS
     Call GetScrollInfo(@pGridData.hGrid,%SB_VERT,si)
     iCellRow=Lowrd(Wea.wParam)-20000 : iGridRow=si.nPos+iCellRow-1
     dwPtr=GetWindowLong(Wea.hWnd,4)
     Vtbl=@dwPtr
     Call Dword @Vtbl[8] Using ptrVButtonClick(dwPtr, iCellRow, iGridRow) To hr
     #If %Def(%DEBUG)
     If SUCCEEDED(hr) Then
        Print #fp, "    Call Dword @Vtbl[8] Using ptrVButtonClick() Succeeded!"
     End If
     #EndIf
  End If
  #If %Def(%DEBUG)
  Print #fp, "  Leaving fnGridProc_OnCommand()"
  Print #fp,
  #EndIf

  Function=0
End Function


Function fnGridProc_OnDestroy(Wea As WndEventArgs) As Long
  Local pGridData As GridData Ptr
  Local blnFree,iCtr As Long
  Local pMem As ZStr Ptr
  Register i As Long
  Register j As Long

  #If %Def(%DEBUG)
  Print #fp,
  Print #fp, "  Entering fnGridProc_OnDestroy()"
  #EndIf
  pGridData=GetWindowLong(Wea.hWnd,0)
  If pGridData Then
     #If %Def(%DEBUG)
     Print #fp, "    @pGridData.iCols      = " @pGridData.iCols
     Print #fp, "    @pGridData.iRows      = " @pGridData.iRows
     Print #fp, "    @pGridData.pColWidths = " @pGridData.pColWidths
     #EndIf
     blnFree=GlobalFree(@pGridData.pColWidths)
     #If %Def(%DEBUG)
     Print #fp, "    blnFree(pColWidths)    = " blnFree
     #EndIf
     If @pGridData.hFont Then
        blnFree=DeleteObject(@pGridData.hFont)
        #If %Def(%DEBUG)
        Print #fp, "    blnFree(hFont)         = " blnFree
        #EndIf
     End If

     'Grid Row Memory
     #If %Def(%DEBUG)
         Print #fp,
         Print #fp, "     i         j            iCtr          strCoordinate                 pMem"
         Print #fp, "    ============================================================================"
     #EndIf
     iCtr=0
     For i=1 To @pGridData.iRows
       For j=1 To @pGridData.iCols
         pMem=@pGridData.@pGridMemory[iCtr]
         #If %Def(%DEBUG)
             Print #fp, "    " i,j,iCtr,@pMem Tab(72) pMem
         #EndIf
         Incr iCtr
        Next j
     Next i
     #If %Def(%DEBUG)
         Print #fp,
         Print #fp,
         Print #fp, "     i         j            iCtr        blnFree"
         Print #fp, "    ==========================================="
     #EndIf
     iCtr=0
     For i=1 To @pGridData.iRows
       For j=1 To @pGridData.iCols
         pMem=@pGridData.@pGridMemory[iCtr]
         If pMem Then
            blnFree=GlobalFree(pMem)
            #If %Def(%DEBUG)
                Print #fp, "    " i,j,iCtr,blnFree
            #EndIf
         End If
         Incr iCtr
        Next j
     Next i
     blnFree=GlobalFree(@pGridData.pGridMemory)
     #If %Def(%DEBUG)
         Print #fp,
         Print #fp, "    blnFree(@pGridData.pGridMemory)     = " blnFree
     #EndIf
     blnFree = GlobalFree(pGridData)
     #If %Def(%DEBUG)
     Print #fp, "    blnFree                             = " blnFree
     #EndIf
  End If
  #If %Def(%DEBUG)
  Print #fp, "  Leaving fnGridProc_OnDestroy()"
  #EndIf

  Function=0
End Function


Function fnGridProc(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 5
    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
       fnGridProc=iReturn
       Exit Function
    End If
  Next i

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


Sub AttachMessageHandlers()
  ReDim MsgHdlr(5) As MessageHandler   'Associate Windows Message With Message Handlers
  MsgHdlr(3).wMessage=%WM_CREATE   :   MsgHdlr(3).dwFnPtr=CodePtr(fnGridProc_OnCreate)
  MsgHdlr(2).wMessage=%WM_SIZE     :   MsgHdlr(2).dwFnPtr=CodePtr(fnGridProc_OnSize)
  MsgHdlr(1).wMessage=%WM_HSCROLL  :   MsgHdlr(1).dwFnPtr=CodePtr(fnGridProc_OnHScroll)
  MsgHdlr(0).wMessage=%WM_VSCROLL  :   MsgHdlr(0).dwFnPtr=CodePtr(fnGridProc_OnVScroll)
  MsgHdlr(5).wMessage=%WM_COMMAND  :   MsgHdlr(5).dwFnPtr=CodePtr(fnGridProc_OnCommand)
  MsgHdlr(4).wMessage=%WM_DESTROY  :   MsgHdlr(4).dwFnPtr=CodePtr(fnGridProc_OnDestroy)
End Sub



Function IConnectionPointContainer_QueryInterface(ByVal this As IConnectionPointContainer1 Ptr, ByRef iid As Guid, ByVal ppv As Dword Ptr) As Long
  #If %Def(%DEBUG)
  Prnt "    Entering IConnectionPointContainer_QueryInterface()"
  #EndIf
  @ppv=%NULL
  Select Case iid
    Case $IID_IUnknown
      #If %Def(%DEBUG)
      Prnt "      Looking For IID_IUnknown"
      #EndIf
      Decr this : @ppv=this
      Call IGrid_AddRef(this)
      #If %Def(%DEBUG)
      Prnt "    Leaving IConnectionPointContainer_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case $IID_IFHGrid
      #If %Def(%DEBUG)
      Prnt "      Looking For IID_IFJHGrid"
      #EndIf
      Decr this : @ppv=this
      Call IGrid_AddRef(this)
      #If %Def(%DEBUG)
      Prnt "    Leaving IConnectionPointContainer_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case $IID_IConnectionPointContainer
      #If %Def(%DEBUG)
      Prnt "      Looking For IID_IConnectionPointContainer"
      #EndIf
      Call IConnectionPointContainer_AddRef(this)
      #If %Def(%DEBUG)
      Prnt "    Leaving IConnectionPointContainer_QueryInterface()"
      #EndIf
      @ppv=this : Function=%S_OK : Exit Function
    Case $IID_IConnectionPoint
      #If %Def(%DEBUG)
      Prnt "      Looking For IID_IConnectionPoint"
      #EndIf
      Incr this : @ppv=this
      Call IConnectionPoint_AddRef(this)
      #If %Def(%DEBUG)
      Prnt "    Leaving IConnectionPointContainer_QueryInterface()"
      #EndIf
      Function=%S_OK : Exit Function
    Case Else
      #If %Def(%DEBUG)
      Prnt "        Looking For Something I Ain't Got!"
      Prnt "      Leaving IConnectionPointContainer_QueryInterface()"
      #EndIf
  End Select

  Function=%E_NOINTERFACE
End Function


Function IConnectionPointContainer_AddRef(ByVal this As IConnectionPointContainer1 Ptr) As Long
  Local pGrid As CGrid Ptr

  #If %Def(%DEBUG)
  Prnt "    Entering IConnectionPointContainer_AddRef()"
  #EndIf
  Decr this
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "      @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << Before"
  #EndIf
  Incr @pGrid.m_cRef
  #If %Def(%DEBUG)
  Prnt "      @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << After"
  Prnt "    Leaving IConnectionPointContainer_AddRef()"
  #EndIf

  Function=@pGrid.m_cRef
End Function


Function IConnectionPointContainer_Release(ByVal this As IConnectionPointContainer1 Ptr) As Long
  Local pGrid As CGrid Ptr

  #If %Def(%DEBUG)
  Prnt "  Entering IConnectionPointContainer_Release()"
  #EndIf
  Decr this : pGrid=this
  #If %Def(%DEBUG)
  Prnt "    @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << Before"
  #EndIf
  Decr @pGrid.m_cRef
  If @pGrid.m_cRef=0 Then
     Call DestroyWindow(@pGrid.hWndCtrl)
     #If %Def(%DEBUG)
     Prnt "    @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
     #EndIf
     Call CoTaskMemFree(this)
     Call InterlockedDecrement(g_lObjs)
     Function=0
  Else
     #If %Def(%DEBUG)
     Prnt "    @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << After"
     #EndIf
     Function=@pGrid.m_cRef
  End If
  #If %Def(%DEBUG)
  Prnt "  Leaving IConnectionPointContainer_Release()"
  #EndIf
End Function


Function IConnectionPointContainer_EnumConnectionPoints(ByVal this As Dword, Byval ppEnum As Dword) 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

  #If %Def(%DEBUG)
  Prnt "  Entering IConnectionPointContainer_FindConnectionPoint()"
  #EndIf
  If iid=$IID_IFHGrid_Events Then
     #If %Def(%DEBUG)
     Prnt "    this  = " & Str$(this)
     Prnt "    @ppCP = " & Str$(@ppCP)
     #EndIf
     hr=IConnectionPointContainer_QueryInterface(this, $IID_IConnectionPoint, ppCP)
     #If %Def(%DEBUG)
     Prnt "    @ppCP = " & Str$(@ppCP)
     Prnt "  Leaving IConnectionPointContainer_FindConnectionPoint()" : Prnt ""
     #EndIf
     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
  #If %Def(%DEBUG)
  Prnt "    Entering IConnectionPoint_QueryInterface()"
  #EndIf
  @ppv=%NULL
  Select Case iid
    Case $IID_IUnknown
      Decr this : Decr this
      @ppv=this
      Call IGrid_AddRef(this)
      Function=%S_OK : Exit Function
    Case $IID_IFHGrid
      Decr this : Decr this
      @ppv=this
      Call IGrid_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
    Case Else
      #If %Def(%DEBUG)
      Prnt "        Looking For Something I Ain't Got!"
      Prnt "      Leaving IConnectionPoint_QueryInterface()"
      #EndIf
  End Select

  Function=%E_NOINTERFACE
End Function


Function IConnectionPoint_AddRef(ByVal this As IConnectionPoint1 Ptr) As Long
  Local pGrid As CGrid Ptr

  #If %Def(%DEBUG)
  Prnt "      Entering IConnectionPoint_AddRef()"
  #EndIf
  Decr this : Decr this
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "        @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << Before"
  #EndIf
  Incr @pGrid.m_cRef
  #If %Def(%DEBUG)
  Prnt "        @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "  << After"
  Prnt "      Leaving IConnectionPoint_AddRef()"
  #EndIf

  Function=@pGrid.m_cRef
End Function


Function IConnectionPoint_Release(ByVal this As IConnectionPoint1 Ptr) As Long
  Local pGrid As CGrid Ptr

  #If %Def(%DEBUG)
  Prnt "  Entering IConnectionPoint_Release()"
  #EndIf
  Decr this : Decr this
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "    @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "    << Before"
  #EndIf
  Decr @pGrid.m_cRef
  If @pGrid.m_cRef=0 Then
     Call DestroyWindow(@pGrid.hWndCtrl)
     #If %Def(%DEBUG)
     Prnt "    @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
     #EndIf
     Call CoTaskMemFree(this)
     Call InterlockedDecrement(g_lObjs)
     #If %Def(%DEBUG)
     Prnt "  Leaving IConnectionPoint_Release()"
     #EndIf
     Function=0
  Else
     #If %Def(%DEBUG)
     Prnt "    @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & "    << After"
     Prnt "  Leaving IConnectionPoint_Release()"
     #EndIf
     Function=@pGrid.m_cRef
  End If
End Function


Function IConnectionPoint_GetConnectionInterface(Byval this As Dword, Byref iid As Dword) As Long
  Function=%E_NOTIMPL
End Function


Function IConnectionPoint_GetConnectionPointContainer(Byval this As Dword, Byval ppCPC As Dword) 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,dwPtr As Dword Ptr
  Local pGrid As CGrid Ptr
  Local hr As Long

  #If %Def(%DEBUG)
  Prnt "  Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!"
  Prnt "    this            = " & Str$(this)
  #EndIf
  Decr this : Decr this
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "    pGrid           = " & Str$(pGrid)
  Prnt "    @pGrid.hControl = " & Str$(@pGrid.hWndCtrl)
  Prnt "    pUnkSink        = " & Str$(pUnkSink)
  Prnt "    @pUnkSink       = " & Str$(@pUnkSink)
  #EndIf
  Vtbl=@pUnkSink
  #If %Def(%DEBUG)
  Prnt "    Vtbl            = " & Str$(Vtbl)
  Prnt "    @Vtbl[0]        = " & Str$(@Vtbl[0])
  #EndIf
  Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(dwPtr)) To hr
  #If %Def(%DEBUG)
  Prnt "    dwPtr           = " & Str$(dwPtr)
  #EndIf
  Call SetWindowLong(@pGrid.hWndCtrl,4,dwPtr)
  If SUCCEEDED(hr) Then
     #If %Def(%DEBUG)
     Prnt "    Call Dword Succeeded!"
     #EndIf
     @pdwCookie=1
  Else
     @pdwCookie=0
  End If
  #If %Def(%DEBUG)
  Prnt "  Leaving IConnectionPoint_Advise() And Still In One Piece!" : Prnt ""
  #EndIf

  Function=hr
End Function


Function IConnectionPoint_Unadvise(Byval this As IConnectionPoint1 Ptr, Byval dwCookie As Dword) As Long
  Local Vtbl,dwPtr As Dword Ptr
  Local pGrid As CGrid Ptr
  Local iReturn As Long

  #If %Def(%DEBUG)
  Prnt "  Entering IConnectionPoint_Unadvise()"
  Prnt "    this            = " & Str$(this)
  #EndIf
  Decr this : Decr this
  pGrid=this
  #If %Def(%DEBUG)
  Prnt "    @pGrid.hWndCtrl = " & Str$(@pGrid.hWndCtrl)
  #EndIf
  dwPtr=GetWindowLong(@pGrid.hWndCtrl,4)
  Vtbl=@dwPtr
  #If %Def(%DEBUG)
  Prnt "    dwPtr           = " & Str$(dwPtr)
  #EndIf
  Call Dword @Vtbl[2] Using ptrRelease(dwPtr) To iReturn
  #If %Def(%DEBUG)
  If SUCCEEDED(iReturn) Then
     Prnt "    IGrid_Events::Release() Succeeded!"
  End If
  Prnt "    Release() Returned " & Str$(iReturn)
  Prnt "  Leaving IConnectionPoint_Unadvise()" : Prnt ""
  #EndIf

  Function=%NOERROR
End Function


Function IConnectionPoint_EnumConnections(Byval this As Dword, Byval ppEnum As Dword) As Long
  Function=%E_NOTIMPL
End Function


[Frederick J. Harris]

continued...

Code Select Expand


Function IClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
  #If %Def(%DEBUG)
  Prnt "      Entering IClassFactory_AddRef()"
  #EndIf
  Call InterlockedIncrement(g_lObjs)
  #If %Def(%DEBUG)
  Prnt "        g_lObjs = " & Str$(g_lObjs)
  Prnt "      Leaving IClassFactory_AddRef()"
  #EndIf

  IClassFactory_AddRef=g_lObjs
End Function


Function IClassFactory_Release(ByVal this As IClassFactory1 Ptr) As Long
  #If %Def(%DEBUG)
  Prnt "    Entering IClassFactory_Release()"
  #EndIf
  Call InterlockedDecrement(g_lObjs)
  #If %Def(%DEBUG)
  Prnt "      g_lObjs = " & Str$(g_lObjs)
  Prnt "    Leaving IClassFactory_Release()"
  #EndIf

  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
  #If %Def(%DEBUG)
  Prnt "    Entering IClassFactory_QueryInterface()"
  #EndIf
  @pCF=0
  If RefIID=$IID_IUnknown Or RefIID=$IID_IClassFactory Then
     Call IClassFactory_AddRef(this)
     @pCF=this
     #If %Def(%DEBUG)
     Prnt "      this = " & Str$(this)
     Prnt "    Leaving IClassFactory_QueryInterface()"
     #EndIf
     Function=%NOERROR : Exit Function
  End If
  #If %Def(%DEBUG)
  Prnt "    Leaving IClassFactory_QueryInterface() Empty Handed!"
  #EndIf

  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 pIGrid As IGrid Ptr
  Local pGrid As CGrid Ptr
  Local hr As Long

  #If %Def(%DEBUG)
  Prnt "  Entering IClassFactory_CreateInstance()"
  #EndIf
  @ppv=%NULL
  If pUnknown Then
     hr=%CLASS_E_NOAGGREGATION
  Else
     pGrid=CoTaskMemAlloc(SizeOf(CGrid))
     #If %Def(%DEBUG)
     Prnt "    pGrid                      = " & Str$(pGrid)
     #EndIf
     If pGrid Then
        @pGrid.lpIGridVtbl = VarPtr(IGrid_Vtbl)
        @pGrid.lpICPCVtbl  = VarPtr(IConnPointContainer_Vtbl)
        @pGrid.lpICPVtbl   = Varptr(IConnPoint_Vtbl)
        #If %Def(%DEBUG)
        Prnt "    Varptr(@pGrid.lpIGridVtbl) = " & Str$(Varptr(@pGrid.lpIGridVtbl))
        Prnt "    Varptr(@pGrid.lpICPCVtbl)  = " & Str$(Varptr(@pGrid.lpICPCVtbl))
        Prnt "    Varptr(@pGrid.lpICPVtbl)   = " & Str$(Varptr(@pGrid.lpICPVtbl))
        #EndIf
        @pGrid.m_cRef=0 : @pGrid.hWndCtrl=0
        pIGrid=pGrid
        #If %Def(%DEBUG)
        Prnt "    @ppv                       = " & Str$(@ppv) & "  << Before QueryInterface() Call"
        #EndIf
        hr= IGrid_QueryInterface(pIGrid,RefIID,ppv)
        #If %Def(%DEBUG)
        Prnt "    @ppv                       = " & Str$(@ppv) & "  << After QueryInterface() Call"
        #EndIf
        If SUCCEEDED(hr) Then
           Call InterlockedIncrement(g_lObjs)
        Else
           Call CoTaskMemFree(pGrid)
        End If
     Else
        hr=%E_OutOfMemory
     End If
  End If
  #If %Def(%DEBUG)
  Prnt "  Leaving IClassFactory_CreateInstance()"
  Prnt ""
  #EndIf

  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
  #If %Def(%DEBUG)
  Prnt "Entering DllCanUnloadNow()"
  #EndIf
  If g_lObjs = 0 And g_lLocks = 0 Then
     #If %Def(%DEBUG)
     Prnt "  I'm Outta Here! (dll is unloaded)"
     #EndIf
     Function=%S_OK
  Else
     #If %Def(%DEBUG)
     Prnt "  The System Wants Rid Of Me But I Won't Go!"
     #EndIf
     Function=%S_FALSE
  End If
  #If %Def(%DEBUG)
  Prnt "Leaving DllCanUnloadNow()"
  #EndIf
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

  #If %Def(%DEBUG)
  Prnt "" : Prnt "  Entering DllGetClassObjectImpl()"
  #EndIf
  If RefClsid=$CLSID_FHGrid 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)

     IGrid_Vtbl.QueryInterface                       = CodePtr(IGrid_QueryInterface)
     IGrid_Vtbl.AddRef                               = CodePtr(IGrid_AddRef)
     IGrid_Vtbl.Release                              = CodePtr(IGrid_Release)
     IGrid_Vtbl.Initialize                           = CodePtr(IGrid_Initialize)
     IGrid_Vtbl.CreateGrid                           = CodePtr(IGrid_CreateGrid)
     IGrid_Vtbl.SetRowCount                          = CodePtr(IGrid_SetRowCount)
     IGrid_Vtbl.SetData                              = CodePtr(IGrid_SetData)
     IGrid_Vtbl.GetData                              = CodePtr(IGrid_GetData)
     IGrid_Vtbl.FlushData                            = CodePtr(IGrid_FlushData)
     IGrid_Vtbl.Refresh                              = CodePtr(IGrid_Refresh)
     IGrid_Vtbl.GetCtrlId                            = CodePtr(IGrid_GetCtrlId)
     IGrid_Vtbl.GethGrid                             = CodePtr(IGrid_GethGrid)

     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
        #If %Def(%DEBUG)
        Prnt "    IClassFactory_QueryInterface() For iid Succeeded!"
        #EndIf
     End If
  End If
  #If %Def(%DEBUG)
  Prnt "  Leaving DllGetClassObjectImpl()" : Prnt ""
  #EndIf

  Function=hr
End Function


Function SetKeyAndValue(Byref szKey As ZStr, Byref szSubKey As ZStr, Byref szValue As ZStr) As Long
  Local szKeyBuf As ZStr*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) * %SIZEOF_CHAR + %SIZEOF_CHAR)
     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 ZStr) As Long
  Local dwSize,hKeyChild As Dword
  Local szBuffer As ZStr*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 ZStr, Byref ClassId As Guid, Byref LibId As Guid, Byref szFriendlyName As ZStr, Byref szVerIndProgID As ZStr, Byref szProgID As ZStr) As Long
  Local szClsid As ZStr*96, szLibid As ZStr*96, szKey As ZStr*128
  Local iReturn As Long

  #If %Def(%DEBUG)
  Print #fp, "    Entering RegisterServer()"
  Print #fp, "      szFileName      = " szFileName
  Print #fp, "      szFriendlyName  = " szFriendlyName
  Print #fp, "      szVerIndProgID  = " szVerIndProgID
  Print #fp, "      szProgID        = " szProgID
  #EndIf
  szClsid=GuidTxt$(ClassId)
  szLibid=GuidTxt$(LibId)
  #If %Def(%DEBUG)
  Print #fp, "      szClsid = " szClsid
  Print #fp, "      szLibid = " szLibid
  #EndIf
  If szClsid <> "" And szLibid <> "" Then
     szKey="CLSID\" & szClsid
     If IsFalse(SetKeyAndValue(szKey, Byval %NULL, szFriendlyName)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szFriendlyName = " szFriendlyName
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "InprocServer32", szFileName)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szFileName     = " szFileName
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "ProgID", szProgID)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szProgID       = " szProgID
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szVerIndProgID = " szVerIndProgID
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szKey, "TypeLib", szLibid)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szLibid        = " szLibid
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szVerIndProgID,Byval %NULL, szFriendlyName)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szVerIndProgID = " szVerIndProgID
        Print #fp, "      szFriendlyName = " szFriendlyName
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szVerIndProgID, "CLSID", szClsid)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szClsid        = " szClsid
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szVerIndProgID, "CurVer", szProgID)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szProgID       = " szProgID
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szProgID, Byval %NULL, szFriendlyName)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szFriendlyName = " szFriendlyName
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     If IsFalse(SetKeyAndValue(szProgID, "CLSID", szClsid)) Then
        #If %Def(%DEBUG)
        Print #fp, "      szClsid        = " szClsid
        Print #fp, "    Leaving RegisterServer() Early!"
        #EndIf
        Function=%E_FAIL : Exit Function
     End If
     #If %Def(%DEBUG)
     Print #fp, "      RegisterServer = %S_OK!
     Print #fp, "    Leaving RegisterServer()"
     #EndIf
     Function=%S_OK      : Exit Function
  Else
     #If %Def(%DEBUG)
     Print #fp, "      RegisterServer  = %E_FAIL!"
     Print #fp, "    Leaving RegisterServer() Early!"
     #EndIf
     Function=%E_FAIL    : Exit Function
  End If
End Function


Function UnregisterServer(Byref ClassId As Guid, Byref szVerIndProgID As ZStr, Byref szProgID As ZStr) As Long
  Local szClsid As ZStr*48, szKey As ZStr*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 ZStr*64, szVerIndProgID As ZStr*32, szProgID As ZStr*32
  Local strAsciPath,strWideCharPath,strPath As BStr
  Local hr,iBytesReturned As Long
  Local pTypeLib As ITypeLib
  Local szPath As ZStr*256

  #If %Def(%DEBUG)
  Print #fp, "  Entering DllRegisterServer()"
  #EndIf
  If GetModuleFileName(g_hModule, szPath, 256) Then
     #If %Def(%DEBUG)
     Print #fp, "    szPath = " szPath
     #EndIf
     #If %Def(%UNICODE)
         hr=LoadTypeLibEx(szPath, %REGKIND_REGISTER, pTypeLib)
     #Else
         strAsciPath=szPath
         strWideCharPath=UCode$(strAsciPath & $Nul)
         hr=LoadTypeLibEx(Byval Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
     #EndIf
     If SUCCEEDED(hr) Then
        #If %Def(%DEBUG)
        Print #fp, "    LoadTypeLib() Succeeded!"
        #EndIf
        Set pTypeLib    = Nothing
        szFriendlyName  =  "Fred Harris Grid Control v2"
        szVerIndProgID  =  "FHGrid2.Grid"
        szProgID        =  "FHGrid2.Grid.1"
        #If %Def(%DEBUG)
        Print #fp, "    szFriendlyName = " szFriendlyName
        Print #fp, "    szVerIndProgID = " szVerIndProgID
        Print #fp, "    szProgID       = " szProgID
        #EndIf
        hr=RegisterServer(szPath, $CLSID_FHGrid, $IID_LIBID_FHGrid, szFriendlyName, szVerIndProgID, szProgID)
        #If %Def(%DEBUG)
        If SUCCEEDED(hr) Then
           Print #fp, "    RegisterServer() Succeeded!"
        Else
           Print #fp, "    RegisterServer() Failed!"
        End If
        #EndIf
     Else
        #If %Def(%DEBUG)
        Print #fp, "    LoadTypeLib() Failed!"
        #EndIf
        Local dwFlags As Dword
        Local szError As ZStr*256
        Local strError As BStr
        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
  #If %Def(%DEBUG)
  Print #fp, "  Leaving DllRegisterServer()"
  #EndIf

  Function=hr
End Function


Function DllUnregisterServer Alias "DllUnregisterServer" () Export As Long
  Local szVerIndProgID As ZStr*32, szProgID As ZStr*32
  Local hr As Long

  hr=UnRegisterTypeLib($IID_LIBID_FHGrid, 1, 0, %LANG_NEUTRAL, %SYS_WIN32)
  If SUCCEEDED(hr) Then
     szVerIndProgID  =  "FHGrid2.Grid"
     szProgID        =  "FHGrid2.Grid.1"
     hr=UnregisterServer($CLSID_FHGrid, 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
  Select Case As Long fwdReason
    Case %DLL_PROCESS_ATTACH
      #If %Def(%DEBUG)
      fp=Freefile
      Open "C:\Code\PwrBasic\PBWin10\COM\Grids\v2\Output.txt" For Output As #fp
      Print #fp, "Entering DllMain() -- %DLL_PROCESS_ATTACH"
      #EndIf
      Call DisableThreadLibraryCalls(hInstance)
      g_hModule         =  hInstance
      g_CtrlId          =  1500
    Case %DLL_PROCESS_DETACH
      #If %Def(%DEBUG)
      Print #fp, "Leaving DllMain() -- %DLL_PROCESS_DETACH"
      Close #fp
      #EndIf
  End Select

  DllMain=%TRUE
End Function


[Frederick J. Harris]

Well, that's it!  Made it in three posts!

Don't forget to change the path to the debug output file in DllMain() if you compile it.  I hard coded the path because I was having trouble finding the output file when RegSvr32 started it, and it required a lot of debugging to get the registry code right.

You can compile and register this new version and leave version #1 registered, because this one is Prog Id "FHGrid2.Grid" and also has different clsids...

Code Select Expand


$CLSID_FHGrid                         = Guid$("{20000000-0000-0000-0000-000000000065}")
$IID_IFHGrid                          = Guid$("{20000000-0000-0000-0000-000000000066}")
$IID_IFHGrid_Events                   = Guid$("{20000000-0000-0000-0000-000000000067}")
$IID_LIBID_FHGrid                     = Guid$("{20000000-0000-0000-0000-000000000068}")


     Version #1's numbers ended in 60, 61, 62, and 63.  Rather than using Guidgen to create random guids I make up my own so I can easily find them in the registry and delete them.  For production code though it would be a good idea to follow the rules and use Guidgen or its equivalent.

     Here is a client to try this code with.   I named it PBClient1_v2.bas, and it creates two grids.  First the inc file...

Code Select Expand


'PBClient1_v2.inc

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

Declare Function FnPtr(wea As WndEventArgs) As Long

Type MessageHandler
  wMessage As Long
  dwFnPtr As Dword
End Type
Global MsgHdlr()      As MessageHandler

Interface IGrid $IID_IFHGrid : Inherit IAutomation
  Method Initialize()
  Method CreateGrid _
  ( _
    Byval hParent     As Long, _
    Byval strSetup    As WString, _
    Byval x           As Long, _
    Byval y           As Long, _
    Byval cx          As Long, _
    Byval cy          As Long, _
    Byval iRows       As Long, _
    Byval iCols       As Long, _
    Byval iRowHt      As Long, _
    Byval strFontName As WString, _
    Byval iFontSize   As Long, _
    Byval iFontWeight As Long _
  )
  Method SetRowCount(Byval iRowCount As Long, Byval blnForce As Long)
  Method SetData(Byval iRow As Long, Byval iCol As Long, Byval strData As WString)
  Method GetData(Byval iRow As Long, Byval iCol As Long) As WString
  Method FlushData()
  Method Refresh()
  Method GetCtrlId() As Long
  Method GethGrid() As Long
End Interface


Class GridEvents1 As Event
  Interface IGridEvents $IID_IGridEvents :  Inherit IAutomation
    Method Grid_OnKeyPress(Byval KeyCode As Long)
      Prnt "Got KeyPress From Grid!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
    End Method

    Method Grid_OnKeyDown(Byval KeyCode As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDown(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDblClk(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnPaste(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
      MsgBox("You Clicked For Row #" & Str$(iGridRow))
    End Method
  End Interface
End Class


Class GridEvents2 As Event
  Interface IGridEvents $IID_IGridEvents :  Inherit IAutomation
    Method Grid_OnKeyPress(Byval KeyCode As Long)
      Prnt "Got KeyPress From Grid!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
    End Method

    Method Grid_OnKeyDown(Byval KeyCode As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDown(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDblClk(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnPaste(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
      MsgBox("You Clicked For Row #" & Str$(iGridRow))
    End Method
  End Interface
End Class


Then the main source...

Code Select Expand


'PBClient1_v2.bas
#Compile              Exe "PBClient1_v2.exe"   
#Dim                  All
$CLSID_FHGrid         = GUID$("{20000000-0000-0000-0000-000000000065}")
$IID_IFHGrid          = GUID$("{20000000-0000-0000-0000-000000000066}")
$IID_IGridEvents      = GUID$("{20000000-0000-0000-0000-000000000067}")
%IDC_RETRIEVE1        = 1500
%IDC_UNLOAD_GRID1     = 1505
%IDC_RETRIEVE2        = 1510
%IDC_UNLOAD_GRID2     = 1515
%UNICODE              = 1
#If %Def(%UNICODE)
    Macro ZStr        = WStringz
    Macro BStr        = WString
    %SIZEOF_CHAR      = 2
#Else
    Macro ZStr        = Asciiz
    Macro BStr        = String
    %SIZEOF_CHAR      = 1
#EndIf
#Include              "Windows.inc"
#Include              "ObjBase.inc"
#Include              "PBClient1_v2.inc"
Global pSink1         As IGridEvents
Global pGrid1         As IGrid
Global pSink2         As IGridEvents
Global pGrid2         As IGrid


Sub Prnt(strLn As BStr)
  Local iLen, iWritten As Long
  Local hStdOutput As Dword
  Local strNew As BStr
  hStdOutput=GetStdHandle(%STD_OUTPUT_HANDLE)
  strNew=strLn + $CrLf
  iLen = Len(strNew)
  WriteConsole(hStdOutput, Byval Strptr(strNew), iLen, iWritten, Byval 0)
End Sub


Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long
  Local strSetup,strFontName,strCoordinate As BStr
  Local pCreateStruct As CREATESTRUCT Ptr
  Local hCtl As Dword
  Register i As Long
  Register j As Long

  Call AllocConsole()
  Prnt "Entering fnWndProc_OnCreate() In Host"
  pCreateStruct=wea.lParam
  wea.hInst=@pCreateStruct.hInstance

  'Grid #1
  Let pGrid1 = NewCom "FHGrid2.Grid"
  Call pGrid1.Initialize()
  strFontName="Times New Roman"
  strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
  pGrid1.CreateGrid(Wea.hWnd,strSetup,10,10,570,218,12,5,28,strFontName,18,%FW_DONTCARE)
  Let pSink1 = Class  "GridEvents1"
  Events From pGrid1 Call pSink1
  For i=1 To 10
    For j=1 To 5
      strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
      pGrid1.SetData(i,j,strCoordinate)
    Next j
  Next i
  pGrid1.Refresh()
  hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,75,245,200,30,Wea.hWnd,%IDC_RETRIEVE1,Wea.hInst,ByVal 0)
  hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,325,245,200,30,Wea.hWnd,%IDC_UNLOAD_GRID1,Wea.hInst,ByVal 0)

  'Grid #2
  Let pGrid2 = NewCom "FHGrid2.Grid"
  strFontName="Courier New"
  strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
  pGrid2.CreateGrid(Wea.hWnd,strSetup,10,300,570,218,12,5,28,strFontName,18,%FW_DONTCARE)
  Let pSink2 = Class  "GridEvents2"
  Events From pGrid2 Call pSink2
  For i=1 To 10
    For j=1 To 5
      strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
      pGrid2.SetData(i,j,strCoordinate)
    Next j
  Next i
  pGrid2.Refresh()
  hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,75,530,200,30,Wea.hWnd,%IDC_RETRIEVE2,Wea.hInst,ByVal 0)
  hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,325,530,200,30,Wea.hWnd,%IDC_UNLOAD_GRID2,Wea.hInst,ByVal 0)
  Prnt "Leaving fnWndProc_OnCreate() In Host"

  fnWndProc_OnCreate=0
End Function


Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
  Local strData As BStr

  Prnt "Entering fnWndProc_OnCommand()"
  Select Case As Long Lowrd(Wea.wParam)
    Case %IDC_RETRIEVE1
      pGrid1.FlushData()
      strData=pGrid1.GetData(3,2)
      Prnt "Cell 3,2 Contains " & strData
    Case %IDC_RETRIEVE2
      pGrid2.FlushData()
      strData=pGrid2.GetData(3,2)
      Prnt "Cell 3,2 Contains " & strData
    Case %IDC_UNLOAD_GRID1
      Events End pSink1
      Set pGrid1=Nothing : Set pSink1=Nothing
      Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE1),%False)
      Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID1),%False)
      Call InvalidateRect(Wea.hWnd, Byval 0, %True)
    Case %IDC_UNLOAD_GRID2
      Events End pSink2
      Set pGrid2=Nothing : Set pSink2=Nothing
      Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE2),%False)
      Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID2),%False)
      Call InvalidateRect(Wea.hWnd, Byval 0, %True)
  End Select
  Prnt "Leaving fnWndProc_OnCommand()"

  fnWndProc_OnCommand=0
End Function


Function fnWndProc_OnClose(Wea As WndEventArgs) As Long
  Prnt "Entering fnWndProc_OnClose() In Host"

  'Grid #1
  If IsObject(pGrid1) Then
     Set pGrid1=Nothing
  End If
  If IsObject(pSink1) Then
     Events End pSink1
     Set pSink1=Nothing
  End If

  'Grid #2
  If IsObject(pGrid2) Then
     Set pGrid2=Nothing
  End If
  If IsObject(pSink2) Then
     Events End pSink2
     Set pSink2=Nothing
  End If
  Call CoFreeUnusedLibraries()
  Call DestroyWindow(Wea.hWnd)
  Call PostQuitMessage(0)
  Prnt "Leaving fnWndProc_OnClose() In Host"

  fnWndProc_OnClose=0
End Function


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

  For i=0 To 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 ZStr*16
  Local wc As WndClassEx
  Local hWnd As Dword
  Local Msg As tagMsg

  szAppName="Grid Test"                           : Call AttachMessageHandlers()
  wc.lpszClassName=VarPtr(szAppName)              : wc.lpfnWndProc=CodePtr(fnWndProc)
  wc.cbClsExtra=0                                 : wc.cbWndExtra=0
  wc.style=%CS_HREDRAW Or %CS_VREDRAW             : wc.hInstance=hIns
  wc.cbSize=SizeOf(wc)                            : 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=CreateWindowEx(0,szAppName,szAppName,%WS_OVERLAPPEDWINDOW,200,100,600,620,0,0,hIns,ByVal 0)
  Call ShowWindow(hWnd,iShow)
  While GetMessage(Msg,%NULL,0,0)
    TranslateMessage Msg
    DispatchMessage Msg
  Wend : MsgBox("Last Chance To Get What You Can!")

  Function=msg.wParam
End Function


     And here then is a console output run of  PBClient1_v2 showing clearly its new functionality...

Code Select Expand


Entering fnWndProc_OnCreate() In Host
  Entering DllGetClassObjectImpl()
    Entering IClassFactory_QueryInterface()
      Entering IClassFactory_AddRef()
        g_lObjs =  1
      Leaving IClassFactory_AddRef()
      this =  2689732
    Leaving IClassFactory_QueryInterface()
    IClassFactory_QueryInterface() For iid Succeeded!
  Leaving DllGetClassObjectImpl()

  Entering IClassFactory_CreateInstance()
    pGrid                      =  4457936
    Varptr(@pGrid.lpIGridVtbl) =  4457936
    Varptr(@pGrid.lpICPCVtbl)  =  4457940
    Varptr(@pGrid.lpICPVtbl)   =  4457944
    @ppv                       =  0  << Before QueryInterface() Call
    Entering IGrid_QueryInterface()
      Trying To Get IFHGrid
      Entering IGrid_AddRef()
        @pGrid.m_cRef =  0  << Before
        @pGrid.m_cRef =  1  << After
      Leaving IGrid_AddRef()
      this =  4457936
    Leaving IGrid_QueryInterface()
    @ppv                       =  4457936  << After QueryInterface() Call
  Leaving IClassFactory_CreateInstance()

  Entering IGrid_AddRef()
    @pGrid.m_cRef =  1  << Before
    @pGrid.m_cRef =  2  << After
  Leaving IGrid_AddRef()

  Entering IGrid_Release()
    @pGrid.m_cRef =  2  << Before
    @pGrid.m_cRef =  1  << After
  Leaving IGrid_Release()

  Entering IClassFactory_Release()
    g_lObjs =  1
  Leaving IClassFactory_Release()

  Entering IGrid_QueryInterface()
    Trying To Get IFHGrid
    Entering IGrid_AddRef()
      @pGrid.m_cRef =  1  << Before
      @pGrid.m_cRef =  2  << After
    Leaving IGrid_AddRef()
    this =  4457936
  Leaving IGrid_QueryInterface()

  Entering IGrid_Release()
    @pGrid.m_cRef =  2  << Before
    @pGrid.m_cRef =  1  << After
  Leaving IGrid_Release()

  Successfully Created FHGrid2.Grid! :  pGrid1 =  4457936

  Entering Initialize() -- IGrid_Initialize()
    GetModuleHandle() =  2621440
  Leaving Initialize()

  Entering IGrid_CreateGrid()
    this           =  4457936
    hContainer     =  525212
    strSetup       =  120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^
    x              =  10
    y              =  10
    cx             =  570
    cy             =  218
    iRows          =  12
    iCols          =  5
    iRowHt         =  28
    strFontName    = Times New Roman
    GetLastError() =  0
    hGrid          =  197568
  Leaving IGrid_CreateGrid()

  pSink1         =  4464900                          '<<< This would be the base allocation for the "GridEvents1" Class
  Objptr(pSink1) =  4464900                          '<<< which is also the location for the sink interface pointer

  Entering IGrid_QueryInterface()
    Trying To Get IConnectionPointContainer
    this =  4457936
    Entering IConnectionPointContainer_AddRef()
      @pGrid.m_cRef =  1  << Before
      @pGrid.m_cRef =  2  << After
    Leaving IConnectionPointContainer_AddRef()
    this =  4457940
  Leaving IGrid_QueryInterface()

  Entering IConnectionPointContainer_FindConnectionPoint()
    this  =  4457940
    @ppCP =  0
    Entering IConnectionPointContainer_QueryInterface()
      Looking For IID_IConnectionPoint
      Entering IConnectionPoint_AddRef()
        @pGrid.m_cRef =  2  << Before
        @pGrid.m_cRef =  3  << After
      Leaving IConnectionPoint_AddRef()
    Leaving IConnectionPointContainer_QueryInterface()
    @ppCP =  4457944
  Leaving IConnectionPointContainer_FindConnectionPoint()

  Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!
    this            =  4457944
    pGrid           =  4457936
    @pGrid.hControl =  197568
    pUnkSink        =  4464900                       '<<< Here is where the address of the "GridEvents1" class came into Advise()
    @pUnkSink       =  2111301                       '<<< for Grid #1
    Vtbl            =  2111301
    @Vtbl[0]        =  2117560
    dwPtr           =  4464900
    Call Dword Succeeded!
  Leaving IConnectionPoint_Advise() And Still In One Piece!

  Entering IGrid_AddRef()
    @pGrid.m_cRef =  3  << Before
    @pGrid.m_cRef =  4  << After
  Leaving IGrid_AddRef()

  Entering IConnectionPoint_Release()
    @pGrid.m_cRef =  4    << Before
    @pGrid.m_cRef =  3    << After
  Leaving IConnectionPoint_Release()

  Entering IConnectionPointContainer_Release()
    @pGrid.m_cRef =  3  << Before
    @pGrid.m_cRef =  2  << After
  Leaving IConnectionPointContainer_Release()

  Entering DllGetClassObjectImpl()
    Entering IClassFactory_QueryInterface()
      Entering IClassFactory_AddRef()
        g_lObjs =  2
      Leaving IClassFactory_AddRef()
      this =  2689732
    Leaving IClassFactory_QueryInterface()
    IClassFactory_QueryInterface() For iid Succeeded!
  Leaving DllGetClassObjectImpl()

  Entering IClassFactory_CreateInstance()
    pGrid                      =  4468968
    Varptr(@pGrid.lpIGridVtbl) =  4468968
    Varptr(@pGrid.lpICPCVtbl)  =  4468972
    Varptr(@pGrid.lpICPVtbl)   =  4468976
    @ppv                       =  0  << Before QueryInterface() Call
    Entering IGrid_QueryInterface()
      Trying To Get IFHGrid
      Entering IGrid_AddRef()
        @pGrid.m_cRef =  0  << Before
        @pGrid.m_cRef =  1  << After
      Leaving IGrid_AddRef()
      this =  4468968
    Leaving IGrid_QueryInterface()
    @ppv                       =  4468968  << After QueryInterface() Call
  Leaving IClassFactory_CreateInstance()

  Entering IClassFactory_Release()
    g_lObjs =  2
  Leaving IClassFactory_Release()

  Successfully Created FHGrid2.Grid! :  pGrid2 =  4468968

  Entering IGrid_CreateGrid()
    this           =  4468968
    hContainer     =  525212
    strSetup       =  120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^
    x              =  10
    y              =  300
    cx             =  570
    cy             =  218
    iRows          =  12
    iCols          =  5
    iRowHt         =  28
    strFontName    = Courier New
    GetLastError() =  0
    hGrid          =  852706
  Leaving IGrid_CreateGrid()

  pSink2         =  4464732                     '<<< ...and this would be the address of the "GridEvents2" Class
  Objptr(pSink2) =  4464732

  Entering IGrid_QueryInterface()
    Trying To Get IConnectionPointContainer
    this =  4468968
    Entering IConnectionPointContainer_AddRef()
      @pGrid.m_cRef =  1  << Before
      @pGrid.m_cRef =  2  << After
    Leaving IConnectionPointContainer_AddRef()
    this =  4468972
  Leaving IGrid_QueryInterface()

  Entering IConnectionPointContainer_FindConnectionPoint()
    this  =  4468972
    @ppCP =  0
    Entering IConnectionPointContainer_QueryInterface()
      Looking For IID_IConnectionPoint
      Entering IConnectionPoint_AddRef()
        @pGrid.m_cRef =  2  << Before
        @pGrid.m_cRef =  3  << After
      Leaving IConnectionPoint_AddRef()
    Leaving IConnectionPointContainer_QueryInterface()
    @ppCP =  4468976
  Leaving IConnectionPointContainer_FindConnectionPoint()

  Entering IConnectionPoint_Advise()!  Grab Your Hardhat And Hang On Tight!
    this            =  4468976
    pGrid           =  4468968
    @pGrid.hControl =  852706
    pUnkSink        =  4464732                  '<<< ...and here is where the address of "GridEvents2" came into the Advise()
    @pUnkSink       =  2111469                  '<<< method of Grid #2.
    Vtbl            =  2111469
    @Vtbl[0]        =  2117560
    dwPtr           =  4464732
    Call Dword Succeeded!
  Leaving IConnectionPoint_Advise() And Still In One Piece!

  Entering IGrid_AddRef()
    @pGrid.m_cRef =  3  << Before
    @pGrid.m_cRef =  4  << After
  Leaving IGrid_AddRef()

  Entering IConnectionPoint_Release()
    @pGrid.m_cRef =  4    << Before
    @pGrid.m_cRef =  3    << After
  Leaving IConnectionPoint_Release()

  Entering IConnectionPointContainer_Release()
    @pGrid.m_cRef =  3  << Before
    @pGrid.m_cRef =  2  << After
  Leaving IConnectionPointContainer_Release()
Leaving fnWndProc_OnCreate() In Host


Got KeyPress From Grid! 102=f
Got KeyPress From Grid! 114=r
Got KeyPress From Grid! 101=e
Got KeyPress From Grid! 100=d

Entering fnWndProc_OnCommand()
  Cell 3,2 Contains fred
Leaving fnWndProc_OnCommand()

Got KeyPress From Grid! 104=h
Got KeyPress From Grid! 97=a
Got KeyPress From Grid! 114=r
Got KeyPress From Grid! 114=r
Got KeyPress From Grid! 105=i
Got KeyPress From Grid! 115=s

Entering fnWndProc_OnCommand()
  Cell 3,2 Contains harris
Leaving fnWndProc_OnCommand()


Entering fnWndProc_OnCommand()
  Entering IGrid_QueryInterface()
    Trying To Get IConnectionPointContainer
    this =  4457936
    Entering IConnectionPointContainer_AddRef()
      @pGrid.m_cRef =  2  << Before
      @pGrid.m_cRef =  3  << After
    Leaving IConnectionPointContainer_AddRef()
    this =  4457940
  Leaving IGrid_QueryInterface()

  Entering IConnectionPointContainer_FindConnectionPoint()
    this  =  4457940
    @ppCP =  0
    Entering IConnectionPointContainer_QueryInterface()
      Looking For IID_IConnectionPoint
      Entering IConnectionPoint_AddRef()
        @pGrid.m_cRef =  3  << Before
        @pGrid.m_cRef =  4  << After
      Leaving IConnectionPoint_AddRef()
    Leaving IConnectionPointContainer_QueryInterface()
    @ppCP =  4457944
  Leaving IConnectionPointContainer_FindConnectionPoint()

  Entering IConnectionPoint_Unadvise()
    this            =  4457944
    @pGrid.hWndCtrl =  197568
    dwPtr           =  4464900
    IGrid_Events::Release() Succeeded!
    Release() Returned  1
  Leaving IConnectionPoint_Unadvise()

  Entering IGrid_Release()
    @pGrid.m_cRef =  4  << Before
    @pGrid.m_cRef =  3  << After
  Leaving IGrid_Release()

  Entering IConnectionPoint_Release()
    @pGrid.m_cRef =  3    << Before
    @pGrid.m_cRef =  2    << After
  Leaving IConnectionPoint_Release()

  Entering IConnectionPointContainer_Release()
    @pGrid.m_cRef =  2  << Before
    @pGrid.m_cRef =  1  << After
  Leaving IConnectionPointContainer_Release()

  Entering IGrid_Release()
    @pGrid.m_cRef =  1  << Before
    @pGrid.m_cRef = 0   << After
    Grid Was Deleted!
  Leaving IGrid_Release()
Leaving fnWndProc_OnCommand()


Entering fnWndProc_OnCommand()
  Entering IGrid_QueryInterface()
    Trying To Get IConnectionPointContainer
    this =  4468968
    Entering IConnectionPointContainer_AddRef()
      @pGrid.m_cRef =  2  << Before
      @pGrid.m_cRef =  3  << After
    Leaving IConnectionPointContainer_AddRef()
    this =  4468972
  Leaving IGrid_QueryInterface()

  Entering IConnectionPointContainer_FindConnectionPoint()
    this  =  4468972
    @ppCP =  0
    Entering IConnectionPointContainer_QueryInterface()
      Looking For IID_IConnectionPoint
      Entering IConnectionPoint_AddRef()
        @pGrid.m_cRef =  3  << Before
        @pGrid.m_cRef =  4  << After
      Leaving IConnectionPoint_AddRef()
    Leaving IConnectionPointContainer_QueryInterface()
    @ppCP =  4468976
  Leaving IConnectionPointContainer_FindConnectionPoint()

  Entering IConnectionPoint_Unadvise()
    this            =  4468976
    @pGrid.hWndCtrl =  852706
    dwPtr           =  4464732
    IGrid_Events::Release() Succeeded!
    Release() Returned  1
  Leaving IConnectionPoint_Unadvise()

  Entering IGrid_Release()
    @pGrid.m_cRef =  4  << Before
    @pGrid.m_cRef =  3  << After
  Leaving IGrid_Release()

  Entering IConnectionPoint_Release()
    @pGrid.m_cRef =  3    << Before
    @pGrid.m_cRef =  2    << After
  Leaving IConnectionPoint_Release()

  Entering IConnectionPointContainer_Release()
    @pGrid.m_cRef =  2  << Before
    @pGrid.m_cRef =  1  << After
  Leaving IConnectionPointContainer_Release()

  Entering IGrid_Release()
    @pGrid.m_cRef =  1  << Before
    @pGrid.m_cRef = 0   << After
    Grid Was Deleted!
  Leaving IGrid_Release()
Leaving fnWndProc_OnCommand()

Entering fnWndProc_OnClose() In Host
  Entering DllCanUnloadNow()
    I'm Outta Here! (dll is unloaded)
  Leaving DllCanUnloadNow()
Leaving fnWndProc_OnClose() In Host


[Frederick J. Harris]

     Well, that problem has I believe been solved.  The next problem to solve is harder, and I ran into this one as soon as I tried to use the control in Visual Basic.   In all the clients I've shown so far we first started the grid creation by creating an instance of the control through PowerBASIC's NewCom function, then we called its Initialize() method, followed by a creation call such as CreateGrid() or whatever I used above.   Having a Windows 'Custom Control' mindset, that seemed a reasonable way to proceed.  The problem is that it imposes a particular order in which these steps must be followed that Visual Basic doesn't honor.  That language is setup in such a manner that the creation of the object and its linkage to the sink must be setup simultaneously.  I'm getting ahead of myself here, but here is a .NET 3.5 Visual Basic program that won't work with the code I've shown so far...

Code Select Expand


Public Class frmFHGrid3
  Public WithEvents pGrid As New FHGrid3Library.FHGrid3

  Sub New()
    Dim strSetup As String = "120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
    Dim strFontName As String = "Times New Roman"
    Dim i As New Int32, j As New Int32

    InitializeComponent()
    pGrid.Create(MyBase.Handle, strSetup, 10, 10, 570, 218, 12, 5, 28, strFontName, 18, 0)
    For i = 1 To 10
      For j = 1 To 5
        Dim strCoordinate As String = "(" & i.ToString() & "," & j.ToString() & ")"
        pGrid.SetData(i, j, strCoordinate)
      Next
    Next
    pGrid.Refresh()
  End Sub

  Private Sub btnGetText_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnGetText.Click
    Dim strData As String = ""

    pGrid.FlushData()
    strData = pGrid.GetData(3, 2)
    MsgBox("Row 3, Col 2 Contains " & strData)
  End Sub

  Private Sub pGrid_Grid_OnVButtonClick(ByVal iCellRow As Integer, ByVal iGridRow As Integer) Handles pGrid.Grid_OnVButtonClick
    MsgBox("You Clicked A Verticle Button.  iCellRow=" & iCellRow.ToString() & "  iGridRow=" & iGridRow.ToString() & ".")
  End Sub

  Private Sub btnDestroyGrid_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnDestroyGrid.Click
    pGrid = Nothing
  End Sub
End Class


The problem is this global/public declaration, which is where .NET will set up both the object and its connection to a sink before the CreateWindowEx() call that creates the grid!

Code Select Expand


Public WithEvents pGrid As New FHGrid3Library.FHGrid3


Don't forget that we are now storing the Sink pointer within the instantiated grid Window Class.   When Visual Basic calls IConnectionPoint::Advise() there will be no window created as of yet into which my Advise() method in my server can store a client sink's address.  This is a bad one, and will cause us to have to do some ripping and tearing and rearranging!  So we'll save that for version #3!

[Dominic Mitchell]

This is a topic I would really like to get into, but I am too busy with Phoenix at the moment.

In that code the address of g_ptrOutGoing was passed back to the client in a QueryInterface() call on the client's sink class,
and was thereby initialized in the server for later callback purposes.  What we'll do here in our modification is pass through
to the client a local instead, i.e., dwPtr below, and within the procedure immediately store it at offset 4 in the grid's .

A global variable was bad, but this is no better.  You seem to have forgotten that, for an instance of an object, more than one
client can be connected to the same outgoing interface. This is why the cookie is very important.  It is also why this code

Code Select Expand


  IF SUCCEEDED(hr) THEN
     #IF %DEF(%DEBUG)
     Prnt "    Call Dword Succeeded!"
     #ENDIF
     @pdwCookie=1
  ELSE
     @pdwCookie=0
  END IF
 

leaves me scratching my head.  The cookie in this code is almost useless.

Why not store a pointer to an array or linked-list of connections on the grid object itself? For example,

Code Select Expand


TYPE CGrid
  lpIGridVtbl                         AS IGridVtbl PTR
  lpICPCVtbl                          AS IConnectionPointContainerVtbl PTR
  lpICPVtbl                           AS IConnectionPointVtbl PTR
 
  m_pConnections                      AS DWORD
   
  hWndCtrl                            AS DWORD
  m_cRef                              AS LONG
END TYPE

         
Where connection is  defined as     

Code Select Expand


TYPE Connection
  dwCookie  AS DWORD
  pAdvise   AS DWORD
  riid      AS GUID       ' Outgoing interface
END TYPE


Then IConnectionPoint::Advise and IConnectionPoint::Unadvise would be coded as shown below. 
The code below uses an array(not a PowerBASIC "array", because I never use that).
Notice that the lookup is based on the cookie.

Code Select Expand


'-------------------------------------------------------------------------------
'
' PROCEDURE: treeIConnectionPoint_Advise
' PURPOSE:   Establishes a connection between the connection point object
'            and the client's sink.
' RETURN:
'
'-------------------------------------------------------------------------------

FUNCTION treeIConnectionPoint_Advise _
  ( _
  BYVAL pThis     AS DWORD, _ ' [IN] IConnectionPoint interface pointer
  BYVAL pUnkSink  AS DWORD, _ ' [IN] Pointer to the IUnknown interface on the client's advise sink
        pdwCookie AS DWORD _  ' [OUT] Pointer to a returned token that uniquely identifies this connection
  ) AS LONG

  LOCAL pCIFace     AS CIFace PTR
  LOCAL pTreeCtl    AS ITreeControl PTR
  LOCAL plCount     AS LONG PTR
  LOCAL pConnect    AS Connection PTR
  LOCAL pSink       AS DWORD
  LOCAL dwCookie    AS DWORD
  LOCAL iConnect    AS LONG
  LOCAL hr          AS LONG

  EnterCriticalSection g_lpcs

  pCIFace  = pThis
  pTreeCtl = @pCIFace.pObject

SaveToLog "IConnectionPoint::Advise"

  IF (pUnkSink = %NULL) OR (VARPTR(pdwCookie) = %NULL) THEN
    FUNCTION = %E_POINTER
    EXIT FUNCTION
  END IF

  hr = %CONNECT_E_CANNOTCONNECT

  ' Check for the right interface on the sink
  hr = IUnknown_QueryInterface(pUnkSink, @pCIFace.riid, pSink)
  IF hr = %S_OK THEN
    IF @pTreeCtl.m_pConnections THEN
      plCount  = @pTreeCtl.m_pConnections
      iConnect = @plCount
    END IF
    dwCookie = TreeControl_GetNextCookie(pThis)
    @pTreeCtl.m_pConnections = Tree_ItemInsert(GetProcessHeap(), 1, @pTreeCtl.m_pConnections, SIZEOF(@pConnect), iConnect)
    IF @pTreeCtl.m_pConnections THEN
      pConnect = @pTreeCtl.m_pConnections + 4
      @pConnect[iConnect].dwCookie = dwCookie
      @pConnect[iConnect].riid     = @pCIFace.riid
      ComPtrAssign @pConnect[iConnect].pAdvise, pSink
      hr = %S_OK
    ELSE
      hr = %E_OUTOFMEMORY
    END IF
  END IF

  pdwCookie = dwCookie

  LeaveCriticalSection g_lpcs

  FUNCTION = hr

END FUNCTION

'-------------------------------------------------------------------------------

FUNCTION treeIConnectionPoint_Unadvise _
  ( _
  BYVAL pThis     AS DWORD, _ ' [IN] IConnectionPoint interface pointer
  BYVAL dwCookie  AS DWORD _  ' [IN] Connection token previously returned from IConnectionPoint::Advise
  ) AS LONG

  LOCAL pCIFace     AS CIFace PTR
  LOCAL pTreeCtl    AS ITreeControl PTR
  LOCAL plCount     AS LONG PTR
  LOCAL pConnect    AS Connection PTR
  LOCAL iConnect    AS LONG
  LOCAL hr          AS LONG

  EnterCriticalSection g_lpcs

  pCIFace  = pThis
  pTreeCtl = @pCIFace.pObject

SaveToLog "IConnectionPoint::Unadvise"

  IF dwCookie = 0 THEN
    FUNCTION = %E_INVALIDARG
    EXIT FUNCTION
  END IF

  hr = %CONNECT_E_NOCONNECTION

  IF @pTreeCtl.m_pConnections THEN
    plCount  = @pTreeCtl.m_pConnections
    pConnect = @pTreeCtl.m_pConnections + 4
    iConnect = 0

    DO
      IF iConnect >= @plCount THEN EXIT DO
      IF @pConnect[iConnect].dwCookie = dwCookie THEN
        @pConnect[iConnect].dwCookie  = 0
        ComPtrAssign @pConnect[iConnect].pAdvise, %NULL
        @pTreeCtl.m_pConnections = Tree_ItemDelete(GetProcessHeap(), 1, @pTreeCtl.m_pConnections, SIZEOF(@pConnect), iConnect)
        hr = %S_OK
        EXIT DO
      END IF
      INCR iConnect
    LOOP

  END IF

  LeaveCriticalSection g_lpcs

  FUNCTION = hr

END FUNCTION


At offset 0 is a pointer to a GridData structure that maintains state for each instance of the grid.

To clarify, this would be each instance of the window. Information such as default font, size and position,
miscellaneous bits cannot be stored here.  Depending on the value of the miscellaneous bits, if the control
is not inplace activated, there will no window but rather a metafile image.   

The GridData structure should have a pointer to the grid object for easy access when notifying the client
of events that happen in the window.

  'Grid #1
  LET pGrid1 = NEWCOM "FHGrid2.Grid"
  CALL pGrid1.Initialize()
  strFontName="Times New Roman"
  strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
  pGrid1.CreateGrid(Wea.hWnd,strSetup,10,10,570,218,12,5,28,strFontName,18,%FW_DONTCARE)

In my opinion, this is a very odd way to create an ActiveX control.
Why do you need to do NEWCOM followed by a CreateGrid method?

[Frederick J. Harris]

This is a topic I would really like to get into, but I am too busy with Phoenix at the moment.

Yes, keep working on Phoenix.  I'd like to have one of those when you have it ready.

I imagine we'll have time to discuss this all.  I've been thinking about this and working on it on and off for years. 

You seem to have forgotten that, for an instance of an object, more than one
client can be connected to the same outgoing interface.

I didn't forget it.  I simply don't understand its use, purpose, or relavance in the case of an in process visual control as opposed to an out of process server which can be set up in various ways to either create one process which all connections share or launch a new process for each connection.  That is why I gave the story in either my version #1 or version #2 of the control about the stock market object keeping track of multiple connection points and multiple connections to each connection point.  The purpose of that story was to introduce the issue and provide an arguement that it simply didn't apply in the case of visual COM based controls.  I admit I might be wrong.  I could be wrong about just about anything.

However, let me phrase my arguement this way.  Perhaps you can explain to me the errors in this arguement.  Lets forget COM for a moment and just consider five button controls on an Sdk window.  And keep in mind that I'll be making an analogy between buttons and COM Controls/ActiveX controls.  When the user clicks button #1 Windows sends the Window Procedure a WM_COMMAND message with the identifier, i.e., control id of the button, in a parameter of the message.  What it doesn't do is send five messages, one to each button, informing it that button #1 was clicked.  No doubt Windows 'knows' that the parent form/dialog has five buttons on it - its probably storing their handles in some sort of memory structure like you suggest, but it nontheless only sends one message - not five. 

It appears to me that the Connection Point concept was made extremely general so that it could handle any type of client/server topology, and one of those designs/topologies is indeed one where a server will be notifying multiple sinks and maintaing pointers to them in some sort of array type structure.  But it also appears to me that other cases exist where there is a simple one to one relationship between client sink and server.  That is the scenario I feel exists in the case of visual COM objects.  As I said, I may simply be wrong and I accept that.  I fully realize you know more about this than I do Dominic, so perhaps you could explain to me how I am wrong. 

So far, in all the tests I have made, the one thing I haven't checked yet is launching multiple client processes loading my grid at the same time.  In other words, in my version #2 which I just posted last night  (August 12, 2011) around midnight, I provided I think PBClient1_v2.bas that instantiates two grids on the form, and my console output using PowerBASIC's COM implementation shows correct reference counting, object creation and destruction, and dll unloading.  But what if I start five PBClient1_v2.exes at the same time?  I'll try it shortly.  Perhaps that is where my design will fail.  I think not - but I could be wrong of course.  I haven't tried that yet.

Just this morning I was thinking of something you toild me last year I think Dominic.  You couldn't understand why I was putting my code using CodePtr() to attach the methods to the VTables in DllGetClassObject().  I believe you felt that ought to go in CreateInstance().  My reason for putting it in DllGetClassObject() was that I felt the attachments only needed to be performed once since the function addresses wouldn't change during a program load.  However, in instantiating two instances of my grid I see PowerBASIC doesn't appear to be using CoGetClassObject() but rather CoCreateInstance() two times, with the class factory being loaded and released twice.  Therefore, I think I'm going to move that code to DllMain() so the attachment will only occur once - when the dll is loaded.  Of course it will occur uselessly when RegisterServer() is called by RegSvr32, but that's no big deal.

In terms of your last comment about  NewCom() followed by creating the grid, I'll be changing that significantly in version #3 so that my control works in Visual Basic.  Also, in terms of your comment about the loading of a default metafile, don't forget I'm not creating this control to provide drag and drop embedding functionality in visual designers at design time.  I'm hoping it will work fine with you Phoenix but will provide no design time functionality. 

[Frederick J. Harris]

     I've just experimented with PBClient1_v2.bas (a client which instantiates two grids on a form), and I started two instances of the program.  Since each had its own process and each allocated a console, I ended up with four windows on my screen - two consoles and two GUI programs with a total of four grids.  Far as I can tell, everything is working correctly.  First time I tested that.

     Consider my 'one sink per one object' rule for a moment.  In a client instantiating two grids there will be a sink class for each grid, i.e., CGridEvents1 and CGridEvents2...

Code Select Expand


Class CGridEvents1 As Event
  Interface IGridEvents $IID_IGridEvents :  Inherit IAutomation
    Method Grid_OnKeyPress(Byval KeyCode As Long)
      Prnt "Got KeyPress From Grid!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
    End Method

    Method Grid_OnKeyDown(Byval KeyCode As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDown(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDblClk(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnPaste(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
      MsgBox("You Clicked For Row #" & Str$(iGridRow))
    End Method
  End Interface
End Class


Class CGridEvents2 As Event
  Interface IGridEvents $IID_IGridEvents :  Inherit IAutomation
    Method Grid_OnKeyPress(Byval KeyCode As Long)
      Prnt "Got KeyPress From Grid!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
    End Method

    Method Grid_OnKeyDown(Byval KeyCode As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDown(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnLButtonDblClk(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnPaste(Byval iRow As Long, Byval iCol As Long)
      ' Insert your code here
    End Method

    Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
      MsgBox("You Clicked For Row #" & Str$(iGridRow))
    End Method
  End Interface
End Class


One might consider this to be wasteful and conducive to bloat, but consider that if multiple grids send event notifications to one sink, then one will need conditional decision making logic to parse out the correct object to which a call applies, i.e....

Code Select Expand


Class CGridEventsForAllGrids As Event
  Interface IGridEvents $IID_IGridEvents :  Inherit IAutomation
    Method Grid_OnKeyPress(Byval KeyCode As Long, Byval iCtrlId As Long)
      If iCtrlId=x Then
         Prnt "Got KeyPress From Grid x!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      Else
         Prnt "Got KeyPress From Grid y!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      End If
    End Method

    Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iCtrlId As LongiCtrl)
      If iCtrlId=x Then
         Prnt "Got KeyPress From Grid x!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      Else
         Prnt "Got KeyPress From Grid y!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      End If
    End Method

    Method Grid_OnLButtonDown(Byval iRow As Long, Byval iCol As Long, Byval iCtrlId As Long)
      If iCtrlId=x Then
         Prnt "Got KeyPress From Grid x!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      Else
         Prnt "Got KeyPress From Grid y!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      End If
    End Method

    Method Grid_OnLButtonDblClk(Byval iRow As Long, Byval iCol As Long, Byval iCtrlId As Long)
      If iCtrlId=x Then
         Prnt "Got KeyPress From Grid x!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      Else
         Prnt "Got KeyPress From Grid y!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      End If
    End Method

    Method Grid_OnPaste(Byval iRow As Long, Byval iCol As Long, Byval iCtrlId As Long)
      If iCtrlId=x Then
         Prnt "Got KeyPress From Grid x!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      Else
         Prnt "Got KeyPress From Grid y!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
      End If
    End Method

    Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCtrlId As Long)
      If iCtrlId=x Then
         MsgBox("You Clicked In Grid x For Row #" & Str$(iGridRow))
      Else
        MsgBox("You Clicked In Grid y For Row #" & Str$(iGridRow))
      End If
    End Method
  End Interface
End Class


My father had an expression - 'its six of one and half a dozen of another', to mean it doesn't make
much difference, and in this case that is the way I see it.  The amount of code will be roughly
equivalent, but the code is cleaner and the logic more obvious if one sticks to my 'one sink per one
object' rule.

     I think your idea of storing a pointer to my sink within the GridData Type I have is an excellent idea.  It pertains to each instance of the grid just as every other member does, so why not?  Yes, I'll implement that.   And I've moved my CodePtr() code which attaches member functions to the VTables out of DllGetClassObject() as you recommended last year Dominic.  However, I'm not sure you'll feel where I've moved it to is better!

     If you could come up with an idea of a client program which would cause my COM Object to fail in some way Dominic, I'll try to implement it.  Consider that in Version #3 of the control which I haven't yet posted I'll be attaching the sink at object creation and my Create() member will be setting the rows, columns, fonts, etc.  Somewhat different from versions 1 and 2.

[Frederick J. Harris]

A book that has been extremely useful to me in learning about COM is Guy And Henry Eddon's book "Inside Distributed COM" by Microsoft Press.   I found it for two or three dollars in a local used book Store and the CD was unopened!   Anyway, here is something they have to say that might pertain to the issues you and I are discussing...

Multicasting With Connection Points

"While it is typical, a one to one relationship is not the rule between a client and a connectable object.  The connection point architecture is generic enough to support a connectable object that fires events at multiple sinks or to support a sink that gets hooked up to several connectable objects."

Their point of departure for that statement is somewhat different from mine, however, because I'm maintaining and arguing that for visual COM based controls (such as my grid control) implementing connection points a 'one to one' relationship is the only architecture that makes sense.

Eddon's book is the only one I've found that uses raw Win32 non-Atl code to show a full implementation of the connection point architecture with all the enumerators fully implemented.   Most books show or discuss a partial implementation (like mine) and then go on to state that a full implementation is far to complex to develop without tool support such as the Active Template Library ( Atl ) or Microsoft Foundation Classes ( Mfc ).  Of course, none of that helps us PowerBASIC coders!

[Dominic Mitchell]

However, let me phrase my arguement this way.  Perhaps you can explain to me the errors
in this arguement.  Lets forget COM for a moment and just consider five button controls
on an Sdk window.  And keep in mind that I'll be making an analogy between buttons and
COM Controls/ActiveX controls.

Your analogy is flawed. A button(server) and can only be connected to one client(its parent)
at a time.

It does not have to be multiple clients connecting to your outgoing interface, it can be the
same client calling IConnectionPoint::Advise/Unadvise more than once.

Take the following scenario:
1) An instance of your grid on a main form.
2) IConnectionPoint::Advise is called from main form to monitor some of the events.
3) A second temporary form is created that will interact with the grid in some way.
4) This secondary form might be some type of editor(created and destroyed many times) while app is running.
4) Second form calls IConnectionPoint::Advise to monitor events that are not necessarily the same as those monitored by main form.
5) Second form calls IConnectionPoint::Unadvise when it closes.

What do you think is going to happen when the second form closes?

[Frederick J. Harris]

Yep, it'll crash sooner or later.  Towards the end of my version #1 of the COM based grid control I believe I stated pretty clearly that these control examples will be based on a one to one relationship between sink and server.  In other words, it would work similarly to the messaging in a standard window procedure.

I agonized over this decision for quite some time.  The context of my quandary over this is that I wished to present the code necessary to show how a custom control could be converted to a COM based control.  Using COM, object construction, lifetime management, messaging, and destruction are considerably different than with custom controls.  With a custom control, the typical behavior is for the control to send notifications back to its parent wrapped up in the WM_NOTIFY message.  I think a fair number of PowerBASIC programmers are familiar with this.  Now it is true that if one wanted to do so one could add extra complexity to a custom control to send multiple messages back to various window procedures within the client app when a single event occurred in the control.  To do so the control would simply need to manage some kind of array of window handles much like your code manages a dynamic array of sink objects within a tree view control or tree view structure.  However, while I have no way of knowing for sure, I expect this has seldom if ever been done or implemented with custom controls.  Perhaps someone will inform me differently.

Therefore, when I looked at the connection point design and saw that it allowed for what you just described, i.e., an instance of a control calling into multiple sinks, my take on it was not particularly positive.   In terms of benefit - cost analysis, my thoughts were, "This looks pretty complicated.  What are the benefits and what are the costs?"

The benefits appeared to me to be too low to justify the costs.  Nonetheless, since it was a part of COM's design to be flexible enough to allow for this architecture, I felt I should at least give somewhat more than passing mention of it in this tutorial.  That is why I devoted at least a whole page to discussing it near the end of version #1 of the grid control where I gave the stock market example and showed some code to give the reader an example of how the control might be set up to manage multiple sinks.  My feelings were that if any reader was interested enough in the topic he/she could use those code ideas I presented to pursue the topic further. 

My opinion of the example you gave is that it is pretty 'contrived'.  I would have never thought to do something like that.   I'll likely keep it in mind in my future coding, however.  It might very well be an ideal solution for some applications.  If that is the case then a control with the ability to manage multiple sinks and fire events at them is a good idea. 

My intention in presenting this grid custom control example and converting it to COM was to show that there is indeed a 'middle ground' between simple IUnknown based worker objects and full blown OCXs  with 16+ interfaces implemented that work in the VB4 - 6 design environment.  In coming up with that 'middle ground' solution I had to accept that some parts of the COM model were fundamental and had to be implemented, and other parts were optional and could remain unimplemented.   COM allows for this, i.e., %E_NOTIMPL.  I think Microsoft eventually came to that conception also, realizing that a component developer shouldn't be required to implement more interfaces than is required to achieve the design goals of a component.