Lately I've been building custom grid controls and trying to convert them to usable COM based controls which can be loaded and used through PowerBASIC's or C++'s COM facilities and COM Apis. Below is the starter code for the grid in custom control form. It compiles to dllGrid.dll. I used PowerBASIC 10.02. I've included the release binary in the attached zip. Also provided is a test host – dllHost1.bas. I didn't bother including the binary for that; it's easy enough to create (not that the dll is any harder). I used the PowerBASIC includes for this but there are comments in the code for using Jose's includes. Very little needs to be changed; one line of code and a couple different includes.
I really didn't want to furnish code that I thought might seriously interfere with folks marketing grid controls, so the functionality of this code is nowhere as complete as with those controls presently for sale. For me to use it in my work apps I'll need to expand its functionality to include coloring of cells, deletions, and use of combo boxes in cells. However, as it now stands you can create as many grid controls and rows and columns as you like, adjust the column widths at run time, put data into it or get it out easily, specify fonts and row heights, scroll about horizontally and vertically, and last but not least, data won't get 'stuck' in the edit control used for editing cells (an aggravating problem with the SIGrid Control, at least for me).
Within several days I should be able to post my largely successful attempts at converting this over to a COM based control. I did not succeed in creating a full Ocx ActiveX based control in the full sense of those terms, i.e., requiring an ActiveX Control Container, IDispatch based, and providing drag and drop through OLE functionality in Visual Basic like visual designers. My control won't work in Visual Basic 6.
Whatever merit it has lies I believe in its ability to be used through language agnostic COM services rather than in dll custom control form. This ability solves the somewhat thorny problem of the need for PowerBASIC created dlls to be accessed through explicit linking and function pointers in other languages such as C or C++. This latter requirement in my opinion significantly reduces the desirability of PowerBASIC components from the standpoint of other language users. COM solves this problem nicely. Here is the code for dllGrid.dll. There are a good many comments in the code, plus un-commenting the %DEBUG symbol will generate loads of diagnostic info in an output file. You can also generate ansi or unicode builds by just commenting or commenting out the %UNICODE symbol right below the %DEBUG symbol...
First Half...
#Compile Dll "dllGrid.dll" 'This grid custom control compiles to about 27 K with the
#Dim All 'PowerBASIC includes and 31 K with Jose's includes (release
'%DEBUG = 1 'version). To do a debug run just uncomment the %DEBUG equate
%UNICODE = 1 'at left. The grid allows you to set the desired number of
#Include "Win32Api.inc" 'rows at design time in the CreateWindowEx() call that creates
%IDC_BASE = 1499 'the grid, or later at run time through a SetRowCount()
%SIZEOF_PTR = 4 'exported function. The grid has horizontal and verticle
%SIZEOF_HANDLE = 4 'scroll bars and resizable columns. It makes use of the
%ID_PANE = 1500 'header ( WC_HEADER ) common control to do this. Also, the
%ID_HEADER = 1505 'verticle buttons along the left side of the grid send a
%ID_CELL = 1600 'message back to the parent as to which row in the grid and
%IDC_EDIT = 1605 'its position (row) in the buffer that was clicked. It also
%GRID_CELL_CHAR = 40000 'sends keypress, keydown, lbuttondown, paste and cell
%GRID_CELL_KEYDOWN = 40001 'double click notifications back to its host in the WM_NOTIFY
%GRID_CELL_LBUTTONDOWN = 40002 'message.
%GRID_CELL_LBUTTONDBLCLK = 40003
%GRID_CELL_PASTE = 40004 'My intentions in creating this control were three-fold. First,
%GRID_VBUTTON_CLICK = 40005 'I wanted to replace the SIGrid control which I'm presently
'using in several mission critical apps at work. Secondly,
#If %Def(%DEBUG) 'I wanted to explore the details of converting the standard
Global fp As Long 'Windows dll based custom control over to a COM based ActiveX
#EndIf 'type control. Thirdly, I wanted to make the code public so
'others might benifit from my explorations of this topic, and
#If %Def(%UNICODE) 'that I might get valuable feedback on my coding and designs.
Macro ZStr = WStringz
Macro BStr = WString 'This app makes use of BStrs and ZStrs instead of the Power-
%SIZEOF_CHAR = 2 'BASIC actual variable types. This is exactly how the UNICODE
#Else
Macro ZStr = Asciiz 'issue is handled in C/C++, and I think its an acceptable and
Macro BStr = String 'perhaps even elegant solution to the miseries of the times we
%SIZEOF_CHAR = 1 'are now lining through related to strings.
#EndIf
Macro dwIdx(r,c) = (r-1)*iRange + (c-1) ' << for obtaining zero based linear offset from one based
Global fnEditWndProc As Dword 'row / col grid data.
Type WndEventArgs 'By the way, the headers for using Jose's includes would be
wParam As Long 'Windows.inc, Commctrl.inc, and HeaderCtrl.inc.
lParam As Long
hWnd As Dword
hInst As Dword
End Type
Declare Function FnPtr(wea As WndEventArgs) As Long
Type MessageHandler 'Used to support my function pointer message cracking scheme.
wMessage As Long
dwFnPtr As Dword
End Type
Global MsgHdlr() As MessageHandler
Type GridData
iCtrlID As Long 'Control ID of Grid
hParent As Dword 'Handle To Grid's Parent, i.e., the object whose CreateWindow() Call Created The Grid.
hGrid As Dword 'Handle To Grid
hBase As Dword 'Parent of Pane. Needed to solve intractable Z Order problem with Verticle Buttons
hPane As Dword 'The Pane Is A Child Of The Grid. It Is What The Cells Are Painted On. hPane Is The Handle
hEdit As Dword 'Handle of edit control. May be NULL if not existing. Its what you type into.
cx As Dword 'This Would Be The Width Of The Grid From The CreateWindow() Call That Created It.
cy As Dword 'This Would Be The Height Of The Grid From The CreateWindow() Call That Created It.
hHeader As Dword 'Handle Of Header Common Control That Allows For Resizable Columns.
iCols As Dword 'Number Of Colums In Grid. This Is Determined From A ParseCount Of strSetup.
iRows As Dword 'This Is The Number Of Rows Of Data The Grid Will Hold, Which Can Be Many More Than the Visible Rows.
iVisibleRows As Dword 'This Is How Many Rows Are Visible, Given How Large The Grid Is Top To Bottom from cx and cy
iRowHeight As Dword 'How Many Pixels High Each Row Is. This affects how many rows are visible.
iPaneHeight As Dword 'A bit complicated. Will explain in WM_CREATE handler.
iEditedCellRow As Long 'This number will be between 1 and iVisibleRows.
iEditedRow As Long 'This will be the row number in the underlying data buffer
iEditedCol As Long 'Column where editing is taking place
pColWidths As Dword Ptr 'Allocated in WM_CREATE. Contains the present column widths. Zero based, i.e., col 1 in zero, etc.
pCellHandles As Dword Ptr 'Allocated in WM_CREATE for grid. Stores Cell handles.
pGridMemory As Dword Ptr 'Allocated when # of rows are known, i.e., in WM_CREATE. Holds pointers to ZStrs.
pVButtons As Dword Ptr 'Same as above. Holds handles of verticle buttons along left edge of grid
blnAddNew As Long 'Not used at this time. Will be used if new rows can be added.
iFontSize As Long 'Self explanatory
iFontWeight As Long 'For CreateFont() call
hFont As Dword 'Handle to Font.
szFontName As ZStr * 28 'Self explanatory
End Type
Type dllGridMessage 'Used for shipping data back to client through WM_NOTIFY message
lpnmh As NMHDR
ptCell As Points
iCol As Long
iRow As Long
wParam As Long
lParam As Long
End Type
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 'This function and fnCellProc() are very important procedures in this grid control.
Local strData As BStr 'When a WM_LBUTTONDOWN message is received in fnCellProc(), which is the registered
Local iLen As Long 'Window Procedure for the "Cell" Window Class, an "edit" control is created and its
'subclass proc - fnEditSubClass is setup. At that point GridData::hEdit is filled
#If %Def(%DEBUG) 'out with the handle of the edit control. This variable in the UDT/struct also serves
Print #fp, 'dual service as a boolean/flag that the grid presently has an active
Print #fp, " Entering blnFlushEditControl()" 'edit control in it. When focus leaves the cell the edit control is
#EndIf 'destroyed, the subclass removed and GridData::hEdit set back to zero.
pGridData=GetWindowLong(hGrid,0) 'Naturally, the contents of the edit control must be salvaged and
If @pGridData.hEdit Then 'written to the underlying data buffer if its different from what is
iLen=GetWindowTextLength(@pGridData.hEdit) 'already there. You can see several lines below where the grid's
pZStr=GlobalAlloc(%GPTR,(iLen+1)*%SIZEOF_CHAR) 'SetGrid() exported function is called
If pZStr Then 'with the row = @pGridData.iEditedRow
Call GetWindowText(@pGridData.hEdit,Byval pZStr,iLen+1) 'and the col = @pGridData.iEditedCol,
strData=@pZStr 'which UDT/struct members would have
Call SetGrid(hGrid,@pGridData.iEditedRow,@pGridData.iEditedCol,strData) 'been set down in fnCellProc() when a
Call SetWindowLong(@pGridData.hEdit,%GWL_WNDPROC,fnEditWndProc) 'WM_LBUTTONDOWN was received there, and
Call DestroyWindow(@pGridData.hEdit) 'the underlying data buffer location
@pGridData.hEdit=0 'determined through various logic there involving loops and SCROLLINFO data. So its
Call Refresh(hGrid) 'like I first said here, this and fnCellProc() are rather important procs. Actually,
Call GlobalFree(pZStr) 'this procedure and fnCellProc() were my answer to years and years of frustration with
Else 'the SIGrid control in terms of flawlessly getting the contents of its edit control
#If %Def(%DEBUG) 'out and getting it persisted to the underlying grid data buffer. Note that after this
Print #fp, " Function=%FALSE" 'procedure exits the edit control is destroyed, the sub class
Print #fp, " Leaving blnFlushEditControl()" 'removed, and GridData.hEdit set to zero.
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
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,hHost As Dword
Local pGridData As GridData Ptr
Local dgm As dllGridMessage
Local iReturn As Long
#If %Def(%DEBUG)
Print #fp, " Entering fnEditSubClass"
#EndIf
hCell=GetParent(hEdit) : hPane=GetParent(hCell) 'I don't think I need to explain this stuff. Just your basic
hBase=GetParent(hPane) : hGrid=GetParent(hBase) 'WM_NOTIFY notification stuff SendMessage'd back to the host.
hHost=GetParent(hGrid) : pGridData=GetWindowLong(hPane,0)
dgm.lpnmh.hwndFrom=hGrid
dgm.lpnmh.idFrom=@pGridData.iCtrlID
dgm.wParam=wParam
dgm.lParam=lParam
dgm.ptCell.x=@pGridData.iEditedCol
dgm.ptCell.y=@pGridData.iEditedCellRow
dgm.iCol=@pGridData.iEditedCol
dgm.iRow=@pGridData.iEditedRow
Select Case As Long wMsg
Case %WM_CHAR
#If %Def(%DEBUG)
Print #fp, " Got WM_CHAR Message In fnEditSubClass!"
#EndIf
dgm.lpnmh.code=%GRID_CELL_CHAR
iReturn=SendMessage(hHost,%WM_NOTIFY,GetDlgCtrlID(hGrid),Varptr(dgm))
#If %Def(%DEBUG)
Print #fp, " iReturn = " iReturn
#EndIf
If iReturn=-1 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
dgm.lpnmh.code=%GRID_CELL_KEYDOWN
iReturn=SendMessage(hHost,%WM_NOTIFY,GetDlgCtrlID(hGrid),Varptr(dgm))
#If %Def(%DEBUG)
Print #fp, " iReturn = " iReturn
#EndIf
Case %WM_PASTE
#If %Def(%DEBUG)
Print #fp, " Got WM_PASTE Message In fnEditSubClass!"
#EndIf
dgm.lpnmh.code=%GRID_CELL_PASTE
iReturn=SendMessage(hHost,%WM_NOTIFY,GetDlgCtrlID(hGrid),Varptr(dgm))
#If %Def(%DEBUG)
Print #fp, " iReturn = " iReturn
#EndIf
Case %WM_LBUTTONDBLCLK
#If %Def(%DEBUG)
Print #fp, " Got %WM_LBUTTONDBLCLK Message In fnEditSubClass!"
#EndIf
dgm.lpnmh.code=%GRID_CELL_LBUTTONDBLCLK
iReturn=SendMessage(hHost,%WM_NOTIFY,GetDlgCtrlID(hGrid),Varptr(dgm))
#If %Def(%DEBUG)
Print #fp, " iReturn = " iReturn
#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 'The cells are actually windows whose parent is the pane, and,
Call SetWindowLong(hCell,0,%NULL) 'of course, the pane's parent is the base, and the base's parent
Function=0 : Exit Function 'is the grid itself. And of course, the grid's parent is the
Case %WM_LBUTTONDOWN 'host app. So there's quite a lineage involved.
Local iRange,iCellBufferPos,iGridMemOffset,iRow,iCol As Long
Local hPane,hBase,hGrid As Dword
Local pGridData As GridData Ptr 'As mentioned in my discussion in blnFlushEditControl(), this proc and the latter mentioned
Local si As SCROLLINFO 'are rather important. Note that blnFlushEditControl() is called here about eight lines below
Local pZStr As ZStr Ptr 'where I'm typing right now. So when a WM_LBUTTONDOWN is received in one of the cells, whatever
Register i As Long 'was in any edit control within the cell is written to the underlying data buffer, and the edit
Register j As Long 'control is destroyed. Just left and below GetScrollInfo() is called to get the .nPos value
hPane=GetParent(hCell) 'because that value will be needed to determine which row in the data buffer is being accessed.
hBase=GetParent(hPane) 'Then the code goes into a double For loop to test the handle of the cell - hCell, against all
hGrid=GetParent(hBase) 'the cell handles stored in the GridData::pCellHandles[] buffer set up in WM_CREATE. Once this
pGridData=GetWindowLong(hPane,0) 'loop logic finds the i, j cell location where the WM_LBUTTONDOWN occurred, it can also determine
Call blnFlushEditControl(hGrid) 'with the .nPos SCROLLINFO data where in the data buffer we are fooling around. It then assigns
si.cbSize = sizeof(SCROLLINFO) 'the data in the buffer to pZStr (a null terminated string buffer pointer), so that data can be
si.fMask=%SIF_POS 'put in the edit control which will soon be created.
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) '<<< macro for converting one based row / col coordinates to linear zero based buffer position.
If @pGridData.@pCellHandles[iCellBufferPos]=hCell Then
iGridMemOffset=iRange*(si.nPos-1)+iCellBufferPos
pZStr=@pGridData.@pGridMemory[iGridMemOffset]
iRow=i : iCol=j
Exit, Exit 'Here you can see an edit control is being created and its parent is being set to the hCell coming
End If 'into this Window Procedure, that is, the cell that received a WM_LBUTTONDOWN. When the grid was
Next j 'created a buffer was set up to store the column widths, i.e., GridData::pColWidths[]. When the
Next i 'user uses the header control at top of the grid to resize columns, this data is received in
@pGridData.hEdit=CreateWindow _ 'fnPaneProc(), and the pColWith[] buffer updated. So it always has the most recent col width info.
( _
"edit", _
"", _
%WS_CHILD Or %WS_VISIBLE Or %ES_AUTOHSCROLL, _
1, _
0, _
@pGridData.@pColWidths[iCol-1]-2, _
@pGridData.iRowHeight, _
hCell, _ 'Note below where the i, j coordinates obtained in the loop above are being persisted to @pGridData
%IDC_EDIT, _ 'in the iEditedCellRow, iEditedRow, and iEditedCol members. The .iEditedCellRow will between 1 and
GetModuleHandle(Byval 0), _ 'the number of grid rows visible. The .iEditedRow value will relate to the row in the grid's data
ByVal 0 _ 'buffer. For example, if the user clicks in the fifth row of the grid, that fifth row might be record
) 'five hundred in the buffer if the user had scrolled down to there.
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
@pGridData.iEditedRow=iRow+si.nPos-1
@pGridData.iEditedCol=iCol
Call SetFocus(@pGridData.hEdit)
Function=0 : Exit Function
Case %WM_PAINT
Local hDC,hFont,hTmp As Dword 'As you can see, I'm writing a pointer to whatever should be visible in a cell at offset
Local pBuffer As ZStr Ptr 'zero in the cell's .cbWndExtra bytes, and the font its supposed to be displayed at offset
Local ps As PAINTSTRUCT 'four. That way, when a WM_PAINT comes through to a cell, it just needs to query its
hDC=BeginPaint(hCell,ps) 'internal structure for what and how its to be displayed. Afterall, I'm a believer in
pBuffer=GetWindowLong(hCell,0) 'OOP, right?
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 'Lot of complicated header control stuff made even worse
Local pNotify As HD_NOTIFY Ptr 'with pointers the misery of which was compounded to the
Local iPos(),iWidth() As Long 'n'th degree with SetWindowPos() miseries. I hate
Local index,iHt,iRange As Long 'SetWindowPos(). Its my least favorite Api fn. I mean,
Local iCols As Dword 'what's the bottom, what's the top, and what's in the
pNotify=lParam 'middle?
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) 'You know, I might have been able to get by with a label control here!
End Function
2nd Half...
Function fnGridProc_OnCreate(Wea As WndEventArgs) As Long 'This is where the grid is put together. Data will be fed
Local iFlds,iHdlCount,iCols,iCtr,iSize As Long 'into this function directly from the CreateWindowEx() call
Local strParseData(),strFieldData() As BStr 'that creates the grid. The 3rd parameter of the call will
Local pGridData1,pGridData2 As GridData Ptr 'be a BStr containing the column information such as # of
Local dwStyle,hButton,hCell,hDC As Dword 'pixels in width, the caption of the column, and whether its
Local pCreateStruct As CREATESTRUCT Ptr 'to be left justified, center, or right justified. The
Local uCC As INIT_COMMON_CONTROLSEX 'column justification hasn't been implemented yet. I'll
Local szText As ZStr*64 'leave that as 'extra credit' work for you! Also, the last
Local hdrItem As HDITEM 'parameter of the CreateWindowEx() call, i.e., lpCreateParams,
Local strSetup As BStr 'will contain a pointer to a GridData UDT passed in from the
Local iPos() As Long 'client. With this info the grid can be built. It more or
Register i As Long 'less 'pulls itself up by its bootstraps'.
Register j As Long
Local rc As RECT
#If %Def(%DEBUG)
Print #fp, " Entering %WM_CREATE Case"
#EndIf
pCreateStruct=Wea.lParam 'Get strSetup from host from caption of CreateWindow() call.
Wea.hInst=@pCreateStruct.hInstance 'A GridData type var will also be passed in through .lpCreateParams
pGridData1=@pCreateStruct.lpCreateParams
If @pGridData1.iRows=0 Or @pGridData1.iCols=0 Or @pGridData1.iRowHeight=0 Then
fnGridProc_OnCreate=-1 : Exit Function
End If
strSetup=@pCreateStruct.@lpszName
Call GetClientRect(Wea.hWnd,rc) 'Get client rect size which will be basis for GridData::iVisibleRows
#If %Def(%DEBUG)
Print #fp, " %WM_USER = " %WM_USER 'and GridData::iPaneHeight
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.blnFontBold = " @pGridData1.blnFontBold
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,",") 'columns are seperated by commas in 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 'A question arose in my mind whether I wanted to have the client
Function=-1 : Exit Function 'both allocate and free memory for a GridData Type to be passed
End If 'through the CreateWindow() call. I decided the client could
pGridData2=GlobalAlloc(%GPTR,sizeof(GridData)) 'locally allocate a GridData, and in here in the WM_CREATE handler
If pGridData2=0 Then 'I'd allocate memory for it, copy what data was in it to here, and
Function=-1 : Exit Function 'fill out the remaining fields. Then I'd store a pointer to in in
End If 'the Grid's WndClassEx::cbWndExtraBytes. Then in a WM_CLOSE or
Call SetWindowLong(Wea.hWnd,0,pGridData2) 'WM_DESTROY deallocate it. That would be easiest for clients. Let
@pGridData2.iCtrlID=@pCreateStruct.hMenu 'the grid do all the dirty work. So what you see at left are the
@pGridData2.cx=@pCreateStruct.cx 'fields of the Grid's GridData type being copied from the one passed
@pGridData2.cy=@pCreateStruct.cy 'in through the CreateWindow() call to the one allocated here. Also
@pGridData2.iCols=iCols 'such critical details are being taken care of such as calculating
@pGridData2.iRows=@pGridData1.iRows 'the number of rows that will be visible given the iRowHeight the
@pGridData2.iRowHeight=@pGridData1.iRowHeight 'client wants and the size of the grid from the CreateWindow() cx, cy
@pGridData2.iVisibleRows=Fix((rc.Bottom-@pGridData1.iRowHeight)/@pGridData1.iRowHeight) 'parameters. You know, I
@pGridData2.iPaneHeight=(@pGridData2.iVisibleRows+1)*@pGridData1.iRowHeight 'go on and on, but if you
@pGridData2.hGrid=Wea.hWnd 'want to know how this thing
@pGridData2.hParent=GetParent(Wea.hWnd) 'works you ought to run it in DEBUG mode (uncomment %DEBUG at top)
@pGridData1.iVisibleRows=@pGridData2.iVisibleRows 'and then check out the Output.txt file. Everything you ever wanted
#If %Def(%DEBUG)
Print #fp, " pGridData2 = " pGridData2 'to know and more is in there!!!!! I'll tell
Print #fp, " @pGridData2.iCtrlID = " @pGridData2.iCtrlID 'what though - this business below with the
Print #fp, " @pGridData2.iPaneHeight = " @pGridData2.iPaneHeight 'pane and the base is a bit tricky. The base
Print #fp, " @pCreateStruct.cy = " @pCreateStruct.cy 'is a child of the grid and is the lowest thing
Print #fp, " @pGridData1.iRowHeight = " @pGridData1.iRowHeight 'in the Z Order, i.e., its on the bottom behind
Print #fp, " @pGridData2.iVisibleRows = " @pGridData2.iVisibleRows 'everything. You'll also find a MoveWindow() call
Print #fp, " @pGridData2.iRows = " @pGridData2.iRows 'on it situating it at x=12. The Pane is a child
#EndIf
Redim strParseData(iCols) As BStr 'of the base. The reason for the existance of the
Parse strSetup,strParseData(),"," 'base at 12 pixels from the left edge of the grid
@pGridData2.pColWidths=GlobalAlloc(%GPTR,(iCols+1)*%SIZEOF_PTR) 'is so that the verticle buttons could sit atop the
If @pGridData2.pColWidths=0 Then 'grid and not the pane. The pane moves - the grid
Call GlobalFree(pGridData2) 'and the base don't. The pane moves to cause the
Function=-1 : Exit Function 'appearance of horizontal scrolling. Also, I had
End If 'excrutiating difficulties getting command clicks
#If %Def(%DEBUG)
Print #fp, " @pGridData2.pColWidths = " @pGridData2.pColWidths 'on the verticle buttons to come through the grid's
Print #fp, 'Window Procedure, if the buttons weren't situated
Print #fp, " i strParseData(i) " 'directly on the grid's surface.
Print #fp, " ============================="
For i=0 To iCols-1 'So, in terms of components, we have a 'grid' class
Print #fp, " " i, strParseData(i) 'which is the grid itself. The 'base' is at the bottom 12 pixels to the right of the
Next i 'left edge. This gives room for the verticle buttons to sit on the grid itself. On
Print #fp, 'top of the base is the pane, and this 'scrolls' through MoveWindow() calls. Finally,
#EndIf
'on top of the pane are the grid cells, a pointer to which is stored in .cbWndExtra bytes.
@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 'All this chunk of code has to do with
iFlds=ParseCount(strParseData(i),":") 'parsing the strSetup comma delimited
Redim strFieldData(iFlds-1) 'fields so as to get the caption and
Parse strParseData(i), strFieldData(), ":" 'pixel width info out so Header control
@pGridData2.@pColWidths[i]=Val(strFieldData(0)) 'can be setup correctly.
@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,hdrItem) 'For Jose's Includes
Call Header_InsertItem(@pGridData2.hHeader,i,Varptr(hdrItem)) 'For the PowerBASIC includes
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
Print #fp,
#EndIf
@pGridData2.pGridMemory=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
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 'Your basic tricky scrollbar code!
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
Local pGridData As GridData Ptr
Local dgm As dllGridMessage
Local si As SCROLLINFO
Local iReturn As Long
#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)
dgm.lpnmh.hwndFrom=@pGridData.hGrid
dgm.lpnmh.idFrom=@pGridData.iCtrlID
dgm.wParam=Wea.wParam
dgm.lParam=Wea.lParam
dgm.iRow=si.nPos+Lowrd(Wea.wParam)-20001
dgm.lpnmh.code=%GRID_VBUTTON_CLICK
iReturn=SendMessage(@pGridData.hParent,%WM_NOTIFY,@pGridData.iCtrlID,Varptr(dgm))
End If
#If %Def(%DEBUG)
Print #fp, " iReturn = " iReturn
Print #fp, " Leaving fnGridProc_OnCommand()"
Print #fp,
#EndIf
Function=0
End Function
Function fnGridProc_OnClose(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_OnClose()"
#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
Call DestroyWindow(Wea.hWnd)
End If
#If %Def(%DEBUG)
Print #fp, " Leaving fnGridProc_OnClose()"
#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_CLOSE : MsgHdlr(4).dwFnPtr=CodePtr(fnGridProc_OnClose)
End Sub
Function Initialize() Export As Long
Local szClassName As ZStr*16
Local wc As WNDCLASSEX
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Entering 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=GetModuleHandle(ByVal %NULL) : 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=%False
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=GetModuleHandle(ByVal %NULL) : 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=%False
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=GetModuleHandle(ByVal %NULL) : 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=%False
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=4
wc.hInstance=GetModuleHandle(ByVal %NULL) : 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)
Print #fp, " GetModuleHandle() = " wc.hInstance
#EndIf
If RegisterClassEx(wc)=%FALSE Then
Function=%False
Exit Function
End If
Call AttachMessageHandlers()
#If %Def(%DEBUG)
Print #fp, " Leaving Initialize()"
Print #fp,
#EndIf
Function=%True
End Function
#If %def(%DEBUG)
Function DllMain(ByVal hInstance As Long, ByVal fwdReason As Long, ByVal lpvReserved As Long) As Long
Select Case As Long fwdReason
Case %DLL_PROCESS_ATTACH
#If %Def(%DEBUG)
fp=Freefile : Open "Output1.txt" For Output As #fp
Print #fp, "In DllMain() Processing %DLL_PROCESS_ATTACH"
#EndIf
Case %DLL_PROCESS_DETACH
#If %Def(%DEBUG)
Print #fp, "In DllMain() Processing %DLL_PROCESS_DETACH"
Close #fp
#EndIf
End Select
DllMain=1
End Function
#EndIf
Here is a zip containing the dll custom control, a host to take a look at it, and the source for the control...
Fred,
I've used an old version of the Farpoint grid control for ages for a couple of reasons.
It has multi-line headers and a min/max setting for each cell.
Another very nice feature is saving/loading just the formatting of all cells with a single call.
The file is huge but compacts down to minimal size.
James
I'll have to check it out James.
Working on a grid control and converting it to a COM based thing is something I wanted to get at for a long time, but am just now getting to it.
Here is an example of multi line headers. It also shows how I use the Min/Max setting of the cell and display it in the status bar.
James
Is that a dll based custom control James or an ActiveX control? I just went to their website and it looks like its .NET now for Windows Forms.
Fred,
It's a dll, version 3.0; no longer available and probably not supported any more.
James
Converting Custom Controls To ActiveX Controls : Initial Thoughts And Issues
There appear to me at this time to be two paths that could be followed in converting a typical Windows custom control which provides some sort of visual appearance to a COM based ActiveX control, and early on in such an endeavor it'll be necessary to decide which of these paths one wishes to take. Also, I'll only be discussing these issues with reference to PowerBASIC, and writing PowerBASIC low level code. I don't believe its possible to use PowerBASIC's high level capabilities to accomplish any of this.
The first path is to develop a 'full' ActiveX control which is also referred to as an OCX and these controls usually have that file name extension. These controls act as OLE servers and support all the linking and embedding interfaces necessary to provide design time drag and drop capabilities in Visual Basic like design environments. These types of controls are actually in one of their 'running' states or 'modes' as they present a visual appearance in the toolbox of Visual Basic, or in design mode on a form, for example. In other words, they are acting in somewhat like the classic case of embedding an Excel spreadsheet within a Word document (which is where COM started, actually). They also make heavy demands on any host or containing application that wishes to utilize them, as witnessed by Jose's Ole Container component (OleCon.inc) capable of negotiating the complex interplay of interface calls between the many interfaces in the Ole Control and the host app. Jose's above mentioned Ole Container custom control involves approximately 4000 lines of code. One alternative to that is the use of Atl71.dll. That component adds an 87 K file dependency to whatever you develop. This is not the road I followed, for I personally don't use visual designers anymore.
The second path one may follow is to simply add the COM 'glue' to an already existing custom control so that it can be loaded by a host app through COM Services and interact with the client/host through a sink interface rather than WM_NOTIFY messaging as is typical with custom controls. This is the path I followed. The techniques I'll shortly show seem to create controls that work perfectly in PowerBASIC, C/C++, or .NET.
The fact that these techniques allow easy use of PowerBASIC created controls in other languages such as those mentioned has merit I think. A PowerBASIC created custom control in Dll form could certainly be loaded and used in C or C++, but I do believe it would require rather special handling that many C or C++ developers might not wish to subject themselves to. C and C++ coders prefer to have a *.lib file to link against so as to have the same facilities as is provided by PowerBASIC's Declare statement. With imported functions listed in PowerBASIC declares where the name and path to the dll is provided, a PowerBASIC developer can use the imported functions just the same as built in functions or ones written directly in the consuming app. C or C++ coders accomplish this same ease of use by being provided with a *.lib file which allows the linker at compile time to resolve external calls into the dll and create an executable. Neither PowerBASIC coders nor C and C++ coders enjoy using LoadLibrary() to load a dll, and GetProcAddress() and function pointers to call Dll functions. Sure it can be done, but who wants to if it can be avoided?
Another issue relating directly to the above is that I'm not even sure all C++ developers – especially the newer ones, are even all that conversant in the use of function pointers in calling functions in loaded Dlls. Function pointers have always been an important topic in C, but much less so in C++ with its oftentimes higher level object oriented syntax. Given the prevalence of high level class libraries in today's C++ application development, its simply not necessary to use function pointers to get things done and I don't think many use them, except likely some of the more advanced developers, and those with strong leanings or backgrounds in C. While I have no idea how widespread the use of PowerBASIC created custom controls are in other languages, given the above situation, I would tend to think it would be minimal.
Modifying an already existing PowerBASIC custom control Dll to make it usable through COM is very doable and nicely solves these problems I just mentioned above. In terms of speed the control will be just as fast as the custom control Dll and in terms of size I believe we're looking at somewhere around a 15 K size hit due to the necessity of defining and implementing a number of interfaces which wouldn't be in a custom control, and of course there is the required registry code to make the control self-registering. Where I'm pulling these numbers from is my custom control grid code I just posted above in this thread which compiles to 27 K as a custom control and 42 K with the necessary COM infrastructure. I expect this 15 K or so would remain relatively constant for larger more complex controls, or only increase slightly.
I'll now discuss the control itself and converting the custom control code over to a COM based control. So far I'm on the third iteration of the control. I wasn't sure if I should discuss or present my first and second iterations (my first try in less pompous terminology) of the control. Since a second and third had to be developed which are apparently better, why not just provide that one to you all? The reason I'm making it harder on myself and providing a first, second, and third iteration of the control as well as having to explain these all is that I'm quite certain the first version of the control will be much easier for you, my readers, to understand. The way I constructed the first version of the control was to literally copy the entirety of the custom control 'as is' to a new file containing fairly boiler plate COM infra-structure code, wire it together here and there with a lick and a promise, put on a crash helmet, brace myself, click the compile button, , and hope for the best! That's probably making it sound too simple, but isn't too far from the truth. In my first version, you'll be able to easily see the exact same procedures as in dllGrid.bas – my custom control posted previously in this thread. And of course the relationship and separateness of this typical message handling Win Api code to what is specifically COM related should help you see what is going on. What would be most difficult for you, I believe, would be an admixture of COM and custom control code where it would be difficult to tell which is what. That really isn't the case in any version, but the separateness is more complete in my first version. And of course I'll discuss the issues I had with the first iteration that caused me to create a second and third, and I think there are some illuminating conceptual issues that were brought forth through this.
The first thing that must be done to convert a custom control into a usable COM Control / ActiveX Control, is decide what the external interfaces to the control will look like. In other words, what were the exported functions in the custom control, and what messages did it send back to host apps – likely through the WM_NOTIFY messaging apparatus?
In terms of the exported functions from the custom control, you can check out your declares you use in the *.inc file associated with the custom control. These will become part of what might be termed the 'inbound' interface to the ActiveX Control, i.e., the typical case of function/method calls made into the COM object which causes it to do something or other.
In terms of messages sent from the control to the client/host app through WM_NOTIFY messaging, its a bit more involved. First realize that all messaging in Windows involves a function pointer arrangement; think of the WNDCLASSEX::lpfnWndProc member of your Window Classes. In the case of typical Win32 coding in PowerBASIC or C/C++ the mechanics of how this is setup and made to work through the Window Procedure is somewhat hidden within the proprietary API. With COM its a good bit more transparent in that every detail of it is visible in the ActiveX and client code - at least when coding it low level in PowerBASIC or C/C++. To make a long story short (at least at this point of just wanting to present the FHGrid1.idl file), the client has to create a legitimate COM Class containing what is termed a 'sink' interface, which is an interface that will be called by the COM object when something happens within it, such as the user clicking within a grid cell. Using this specific case as an example, what would happen there is that a WM_LBUTTONDOWN would be picked up within the Window Procedure of the grid; the grid would have access to a VTable/Interface pointer sent in from the client, and it would use this pointer to 'callback' into the client sink object. The direction of movement here is not your typical one of the client calling into the COM object, but rather the reverse as the COM object calls 'out' into the client. Therefore, these types of interfaces are termed 'outgoing' or 'source' interfaces.
Much of the complexity then of creating visual COM based controls is setting up this two way data transfer mechanism. The interfaces involved are IConnectionPointContainer, IConnectionPoint, IEnumConnectionPoints, and IEnumConnections. These later two can be practically done without in controls such as I'm building here. But in any case, here is the FHGrid1.idl file that must be run through the midl compiler to create an embeddable typelib for the grid ActiveX control...
// fhGrid1.idl
import "unknwn.idl";
[object, uuid(20000000-0000-0000-0000-000000000061), 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-000000000062), oleautomation] interface IGridEvents : IUnknown
{
HRESULT Grid_OnKeyPress([in] int KeyCode);
HRESULT Grid_OnKeyDown([in] int KeyCode);
HRESULT Grid_OnLButtonDown([in] int iRow, [in] int iCol);
HRESULT Grid_OnLButtonDblClk([in] int iRow, [in] int iCol);
HRESULT Grid_OnPaste([in] int iRow, [in] int iCol);
HRESULT Grid_OnVButtonClick([in] int iCellRow, [in] int iGridRow);
};
[uuid(20000000-0000-0000-0000-000000000063), helpstring("FHGrid1 TypeLib"), version(1.0)] library FHGrid1Library
{
importlib("stdole32.tlb");
interface IGrid;
interface IGridEvents;
[uuid(20000000-0000-0000-0000-000000000060)]
coclass FHGrid1
{
interface IGrid;
[source] interface IGridEvents;
}
};
Note in the above idl code there are two interfaces defined. First you have the IGrid interface, and the members of this relate almost exactly to the exported functions of the grid custom control previously posted. This interface will of course be implemented within the COM dll, and the client will only need to have its definition within itself to call 'into' it in the typical manner once it has an interface pointer to it's implementation within the dll. The second interface defined above is the IGridEvents interface, and the tables are reversed on this one, so to speak. The ActiveX control in the dll will have a definition of this interface within itself, but the interface will be implemented within a class in the client or host app, and the COM control will call 'out' to this interface, i.e., its an outgoing or source of events interface.
Finally, there is a library statement in the idl code for the 'FHGrid1Library'. Within this library declaration are statements of the existence of an inbound interface IGrid, and an outbound or source interface IGridEvents. With this information hosting languages such as high level PowerBASIC or Visual Basic can at runtime synthesize workable sink objects to 'absorb' the events fired by visual COM based controls.
I'll attach the generated FHGrid1.tlb file for those who do not have a C/C++ environment with midl to create it for themselves. With that tlb file you should be able to create the COM Control for yourself if you have preferably PowerBASIC 10.02. There is a resource statement at the top of FHGrid1.bas like so...
#Resource Typelib, 1, "FHGrid1.tlb"
That's basically what you need the above file for. If you have Visual Studio you can invoke the Microsoft Interface Definition Language (midl.exe ) compiler from the command line to create the type lib. Here is what it looks like for me on the command line using Visual Studio 6 where my development path for version 1 of the control is...
C:\Code\PwrBasic\PBWin10\COM\Grids\v1
C:\Code\PwrBasic\PBWin10\COM\Grids\v1>Midl FHGrid1.idl
Microsoft (R) MIDL Compiler Version 5.01.0164
Copyright (c) Microsoft Corp 1991-1997. All rights reserved.
Processing .\FHGrid1.idl
FHGrid1.idl
Processing C:\Program Files (x86)\Microsoft Visual Studio\VC98\include\unknwn.idl
unknwn.idl
Processing C:\Program Files (x86)\Microsoft Visual Studio\VC98\include\wtypes.idl
wtypes.idl
Processing C:\Program Files (x86)\Microsoft Visual Studio\VC98\include\oaidl.idl
oaidl.idl
Processing C:\Program Files (x86)\Microsoft Visual Studio\VC98\include\objidl.idl
objidl.idl
C:\Code\PwrBasic\PBWin10\COM\Grids\v1>
After getting the above output from midl I can then do a dir to see what files are in my v1 directory, which reveals this...
C:\Code\PwrBasic\PBWin10\COM\Grids\v1>dir
Volume in drive C is OSDisk
Volume Serial Number is 3E79-B713
Directory of C:\Code\PwrBasic\PBWin10\COM\Grids\v1
08/05/2011 03:02 PM <DIR> .
08/05/2011 03:02 PM <DIR> ..
08/05/2011 03:02 PM 809 dlldata.c
07/29/2011 03:09 PM 82,771 FHGrid1.bas
08/05/2011 02:49 PM 74 FHGrid1.bat
08/05/2011 03:02 PM 17,839 FHGrid1.h
08/05/2011 03:01 PM 1,570 FHGrid1.idl
08/05/2011 02:58 PM 4,225 FHGrid1.LNX
08/05/2011 03:01 PM 39 FHGrid1.rc
08/05/2011 03:02 PM 3,444 FHGrid1.tlb
08/05/2011 03:02 PM 1,215 FHGrid1_i.c
08/05/2011 03:02 PM 63,089 FHGrid1_p.c
10 File(s) 175,075 bytes
2 Dir(s) 158,641,577,984 bytes free
C:\Code\PwrBasic\PBWin10\COM\Grids\v1>
Note that FHGrid1.tlb is there, and that is what I needed. Having that, I can compile the code for the COM Control. Without further ado – iteration #1....
continued.....
Here is FHGrid1.bas...
#Compile Dll "FHGrid1.dll" 'Use Jose's Includes! Compiled With PowerBASIC 10.02
#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, "FHGrid1.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) As Long
Declare Function ptrKeyDown (Byval this As Dword Ptr, Byval iKeyCode As Long) As Long
Declare Function ptrLButtonDown (Byval this As Dword Ptr, Byval iRow As Long, Byval iCol As Long) As Long
Declare Function ptrLButtonDblClk (Byval this As Dword Ptr, Byval iRow As Long, Byval iCol As Long) As Long
Declare Function ptrPaste (Byval this As Dword Ptr, Byval iRow 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-000000000060}")
$IID_IFHGrid = Guid$("{20000000-0000-0000-0000-000000000061}")
$IID_IFHGrid_Events = Guid$("{20000000-0000-0000-0000-000000000062}")
$IID_LIBID_FHGrid = Guid$("{20000000-0000-0000-0000-000000000063}")
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 Grid
lpIGridVtbl As IGridVtbl Ptr
lpICPCVtbl As IConnectionPointContainerVtbl Ptr
lpICPVtbl As IConnectionPointVtbl Ptr
hContainer As Dword
hControl As Dword
m_cRef As Long
End Type
Type IEnumConnectionPointsVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Next As Dword Ptr
Skip As Dword Ptr
Reset As Dword Ptr
Clone As Dword Ptr
End Type
Type IEnumConnectionPoints1
lpVtbl As IEnumConnectionPointsVtbl Ptr
End Type
Type IEnumConnectionsVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Next As Dword Ptr
Skip As Dword Ptr
Reset As Dword Ptr
Clone As Dword Ptr
End Type
Type IEnumConnections1
lpVtbl As IEnumConnectionsVtbl Ptr
End Type
Type 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 g_ptrOutGoing As Dword Ptr 'This is an ultimate simplification of the IConnectionPoint interface where only one sink is possible.
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
Prnt " Entering IGrid_QueryInterface()"
@ppv=%NULL
Select Case iid
Case $IID_IUnknown
Prnt " Trying To Get IUnknown"
Call IGrid_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IGrid_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IFHGrid
Prnt " Trying To Get IFHGrid"
Call IGrid_AddRef(this)
@ppv=this
Prnt " this = " & Str$(this)
Prnt " Leaving IGrid_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPointContainer
Prnt " Trying To Get IConnectionPointContainer"
Prnt " this = " & Str$(this)
Incr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IGrid_QueryInterface()"
Function=%S_OK
Exit Function
Case $IID_IConnectionPoint
Prnt " Trying To Get IConnectionPoint"
Prnt " this = " & Str$(this)
Incr this : Incr this
@ppv=this
Call IConnectionPoint_AddRef(this)
Prnt " this = " & Str$(this)
Prnt " Leaving IComCtrl_QueryInterface()"
Function=%S_OK
Exit Function
Case Else
Prnt " Looking For Something I Ain't Got!"
Prnt " Leaving IGrid_QueryInterface()"
End Select
Function=%E_NoInterface
End Function
Function IGrid_AddRef(ByVal this As IGrid Ptr) As Long
Local pGrid As Grid 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 Grid 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.hControl)
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_SetRowCount(Byval this As IGrid Ptr, Byval iRowCount As Long, Byval blnForce As Long) As Long
Local pGrid As Grid Ptr
pGrid=this
If SetRowCount(@pGrid.hControl, 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 Grid Ptr
pGrid=this
If SetGrid(@pGrid.hControl,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 Grid Ptr
pGrid=this
strData=GetGrid(@pGrid.hControl,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 Grid Ptr
pGrid=this
If blnFlushEditControl(@pGrid.hControl) 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 Grid Ptr
pGrid=this
Call Refresh(@pGrid.hControl)
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 Grid Ptr
pGrid=this
pGridData=GetWindowLong(@pGrid.hControl,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 Grid Ptr
pGrid=this
hGrid=@pGrid.hControl
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
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,hHost As Dword
Local pGridData As GridData Ptr
Local iReturn,hr As Long
Local Vtbl As Dword Ptr
#If %Def(%DEBUG)
Print #fp, " Entering fnEditSubClass"
#EndIf
hCell=GetParent(hEdit) : hPane=GetParent(hCell)
hBase=GetParent(hPane) : hGrid=GetParent(hBase)
hHost=GetParent(hGrid) : pGridData=GetWindowLong(hPane,0)
Select Case As Long wMsg
Case %WM_CHAR
#If %Def(%DEBUG)
Print #fp, " Got WM_CHAR Message In fnEditSubClass!"
#EndIf
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[3] Using ptrKeyPress(g_ptrOutGoing, wParam) 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
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[4] Using ptrKeyDown(g_ptrOutGoing, wParam) To hr
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Print #fp, " Call Dword @Vtbl[4] Using ptrKeyPress() 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
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[7] Using ptrPaste(g_ptrOutGoing, @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
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[6] Using ptrLButtonDblClk(g_ptrOutGoing, @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 '%WM_LBUTTONDBLCLK
Local iRange,iCellBufferPos,iGridMemOffset,iRow,iCol,hr As Long
Local hPane,hBase,hGrid As Dword
Local pGridData As GridData Ptr
Local si As SCROLLINFO
Local pZStr As ZStr Ptr
Local Vtbl As Dword Ptr
Register i As Long
Register j As Long
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
@pGridData.iEditedRow=iRow+si.nPos-1
@pGridData.iEditedCol=iCol
Call SetFocus(@pGridData.hEdit)
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[5] Using ptrLButtonDown(g_ptrOutGoing, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Print #fp, " Call Dword @Vtbl[5] Using ptrLButtonDown() Succeeded!"
End If
#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
Code Too Long...Continued Next Post.....
continued...
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
Local iCellRow,iGridRow,hr As Long
Local pGridData As GridData Ptr
Local Vtbl 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
Vtbl=@g_ptrOutGoing
Call Dword @Vtbl[8] Using ptrVButtonClick(g_ptrOutGoing, 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 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=4
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 Grid Ptr
Local gd As GridData
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
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,10,10,570,218,Wea.hWnd,%IDC_GRID1,Wea.hInst,ByVal Varptr(grdData))
hGrid=CreateWindowEx _
( _
%WS_EX_OVERLAPPEDWINDOW, _
"Grid", _
Byval Strptr(strSetup), _
dwStyle, _
x, _
y, _
cx, _
cy, _
hContainer, _
g_CtrlId, _
g_hModule, _
ByVal Varptr(gd) _
)
Prnt " GetLastError() = " & Str$(GetLastError())
Prnt " hGrid = " & Str$(hGrid)
Incr g_CtrlId
pGrid=this
@pGrid.hContainer=hContainer
@pGrid.hControl=hGrid
Call SetFocus(hGrid)
Prnt " Leaving IGrid_CreateGrid()" : Prnt ""
Function=%S_OK
End Function
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 Grid 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 Grid 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.hControl)
#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 IConnectionPointContainer1 Ptr, Byval ppEnum As IEnumConnectionPoints1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPointContainer_FindConnectionPoint(ByVal this As IConnectionPointContainer1 Ptr, ByRef iid As Guid, ByVal ppCP As Dword Ptr) As Long
Local hr As Long
#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 Grid 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 Grid 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.hControl)
#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 IConnectionPoint1 Ptr, Byref iid As Guid) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPoint_GetConnectionPointContainer(Byval this As IConnectionPoint1 Ptr, Byval ppCPC As IConnectionPointContainer1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IConnectionPoint_Advise(Byval this As IConnectionPoint1 Ptr, Byval pUnkSink As Dword Ptr, Byval pdwCookie As Dword Ptr) As Long
Local Vtbl As Dword Ptr
Local hr As Long
#If %Def(%DEBUG)
Prnt " Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!"
Prnt " pUnkSink = " & Str$(pUnkSink)
Prnt " @pUnkSink = " & Str$(@pUnkSink)
#EndIf
Vtbl=@pUnkSink
#If %Def(%DEBUG)
Prnt " Vtbl = " & Str$(Vtbl)
Prnt " @Vtbl[0] = " & Str$(@Vtbl[0])
Prnt " g_ptrOutGoing = " & Str$(g_ptrOutGoing) & " << Before Call Of QueryInterface() On Sink"
#EndIf
Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(g_ptrOutGoing)) To hr
#If %Def(%DEBUG)
Prnt " g_ptrOutGoing = " & Str$(g_ptrOutGoing) & " << After Call Of QueryInterface() On Sink"
#EndIf
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 As Dword Ptr
Local iReturn As Long
#If %Def(%DEBUG)
Prnt " Entering IConnectionPoint_Unadvise()"
#EndIf
VTbl=@g_ptrOutGoing
Call Dword @Vtbl[2] Using ptrRelease(g_ptrOutGoing) To iReturn
#If %Def(%DEBUG)
Prnt " dwCookie = " & Str$(dwCookie)
#EndIf
If SUCCEEDED(iReturn) Then
#If %Def(%DEBUG)
Prnt " IGrid_Events::Release() Succeeded!"
#EndIf
End If
#If %Def(%DEBUG)
Prnt " Release() Returned " & Str$(iReturn)
Prnt " Leaving IConnectionPoint_Unadvise()"
#EndIf
Function=%NOERROR
End Function
Function IConnectionPoint_EnumConnections(Byval this As IConnectionPoint1 Ptr, Byval ppEnum As IEnumConnections1 Ptr) As Long
Function=%E_NOTIMPL
End Function
Function IClassFactory_AddRef(ByVal this As IClassFactory1 Ptr) As Long
#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 Grid 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(Grid))
#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.hContainer=0 : @pGrid.hControl=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
continued...
continued...
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 v1"
szVerIndProgID = "FHGrid1.Grid"
szProgID = "FHGrid1.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 = "FHGrid1.Grid"
szProgID = "FHGrid1.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\v1\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
End Code!
In all the code I'm presenting here and am going to discuss, there are two different debug outputs. First, my clients which connect with the COM control allocate a console, and output various diagnostic/debug statemnts to it. Second, on every run where the COM dll is accessed, there is a debug output file opened and there is a hard coded path to it as seen below. Look up in DllMain() just a few lines up and you'll see this reproduced again...
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\v1\Output.txt" For Output As #fp ''''''!!!! <<< Change This !!!!!!!!!
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
It is critically important that you change the above path where you run this code to reflect a path and location where you want to work with this code yourself on your computer. Otherwise, my guess is the control will neither register correctly nor run. Some debug output statements go to the console and others go to the output file. Most of the COM related calls print to the console, and most of the grid construction/destruction code that is basically Win32 Api code common with the grid custom control goes to the output file. You really need to take care of this step in fixing the Output.txt file path before you register the control; otherwise it likely won't register.
I'll just jump into the details of explaining it at this point. Perhaps it would be good to have the code open to both dllGrid.bas, i.e., the custom control, and FHGrid1.bas, the COM version. Comparing the initial screen of both programs you'll note this near the top of FHGrid1.bas....
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) As Long
Declare Function ptrKeyDown (Byval this As Dword Ptr, Byval iKeyCode As Long) As Long
Declare Function ptrLButtonDown (Byval this As Dword Ptr, Byval iRow As Long, Byval iCol As Long) As Long
Declare Function ptrLButtonDblClk (Byval this As Dword Ptr, Byval iRow As Long, Byval iCol As Long) As Long
Declare Function ptrPaste (Byval this As Dword Ptr, Byval iRow 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
...and this is in dllGrid.bas but also not in FHGrid1.bas
Type dllGridMessage 'Used for shipping data back to client through WM_NOTIFY message
lpnmh As NMHDR
ptCell As Points
iCol As Long
iRow As Long
wParam As Long
lParam As Long
End Type
The reason for this change is that those declares are going to be used as model declarations for Call Dword function pointer calls at the client's Sink object, which is the object notified when events occur in the control. The Type dllGridMessage was removed from the COM control because the WM_NOTIFY message is not used to notify the client of events. In COM, Sink objects are used. So there you have a fairly significant difference right up front. I'll have more to say about this.
The next thing you'll notice in the COM code are GUIDs....
$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-000000000060}")
$IID_IFHGrid = Guid$("{20000000-0000-0000-0000-000000000061}")
$IID_IFHGrid_Events = Guid$("{20000000-0000-0000-0000-000000000062}")
$IID_LIBID_FHGrid = Guid$("{20000000-0000-0000-0000-000000000063}")
This is just part of doing business in COM. You'll always have these. Note one needs class ids and guids for all the interfaces, both incoming and outgoing. An incoming interface is the standard kind. Its implemented in the server and provides services to the client. An outgoing interface is implemented rather in the client and the server calls 'out' into it. While its not implemented in the server we're discussing now, we need a guid (actually an iid) for it, and also interface definitions for it. So you can see all these guids above, but you won't find them in the custom control code.
The next thing you'll see in the COM control are lots of things like this....
Type IGridVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release As Dword Ptr
Initialize As Dword Ptr
SetRowCount As Dword Ptr
SetData As Dword Ptr
GetData As Dword Ptr
FlushData As Dword Ptr
Refresh As Dword Ptr
GethGrid As Dword Ptr
GetCtrlId As Dword Ptr
CreateGrid As Dword Ptr
End Type
Type IGrid
lpVtbl As IGridVtbl Ptr
End Type
Lots and lots of them. These are the low level definitions of the Vtable or interface structures that are needed to set up what the memory footprint must look like to qualify as a COM object. You'll find sets of these things in twos for each of the interfaces implemented by the COM grid control. Specifically, you'll have one set for the custom interface, i.e., one set for IGrid, and one each for IConnectionPointContainer and IConnectionPoint.
This...
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
...has nothing to do with COM and you'll find it in both the custom control and COM version. Obviously, it's a structure that maintains 'state' for the grid control, and functions exactly the same way in both versions. A pointer to it is stored at offset zero of the .cbWndExtra bytes for both versions.
Now this...
Type Grid
lpIGridVtbl As IGridVtbl Ptr
lpICPCVtbl As IConnectionPointContainerVtbl Ptr
lpICPVtbl As IConnectionPointVtbl Ptr
hContainer As Dword
hControl As Dword
m_cRef As Long
End Type
...you won't find in the custom control code. It's a COM class, and that's pretty important stuff. Clients never know anything of it – its structure is only defined within the deep recesses of the COM server. The client never gets a pointer to one; the best the client can ever do is get a pointer to an interface defined and maintained within the class. All the member variables of this entity are hidden from the client. All this is part of the design of COM to keep implementation details about the object away from clients. These 'class objects' are instantiated within the server and the best the client can do is get an interface pointer out of it if the client can pass a correct IID into a QueryInterface() call. This particular class, i.e., 'Grid', is able to pass out interface pointers to the IGrid interface, the IConnectionPointContainer Interface, and the IConnectionPoint interface. However, to get an IConnectionPoint Interface one must first call an IConnectionPointContainer member to get it.
A memory allocation for the 'Grid' class can be found down in IClassFactory_CreateInstance(). This function is never called directly by the client however. It is actually a function 'plugged into' IClassFactory::CreateInstance through the mysterious alchemy of Codeptr() down in DllGetClassObjectImpl(), which function executes when COM services do a LoadLibrary() on FHGrid1.dll and call DllGetClassObjexct().
Moving down a little in FHGrid.bas you'll find this...
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
An implementation of that entity isn't to be found in the custom control code. The reason for its lack there is it concerns the method of communication between the grid in the COM server and the client. As mentioned previously, custom controls routinely use Windows messaging apparatus involving the WM_NOTIFY message to transfer information back to a client. COM uses an event sink, which is a somewhat different affair. What happens is that a client can learn about a Server's 'source' or outgoing interface from a type library. The client of the COM object can then implement that interface within some class within itself, and pass a pointer to the class implementing the sink back to the COM server. Later I'll present various client programs showing all kinds of variations on this theme so that it is comprehensible to you.
An important distinction to keep in mind though is that the above two types are present in this server code only to allow it to make Call Dword function pointer calls on the client's sink object, once the client has passed a pointer to it into this server code. These two types are not instantiated here. The situation with Call Dword is something like deer hunting here in Pennsylvania; its a good idea to have the deer fairly in your sights and to know what your target looks like before pulling the trigger; the above type descriptions tell this code what the target looks like so that there is a good chance of hitting it.
Moving on down in FHGrid1.bas you'll see a bunch of functions which occur exactly as in dllGrid.bas – the custom control. These are the exported functions from the custom control, although here I removed the Export keyword, because they aren't being called from the client, but rather from within the COM control itself. These procedures are...
Function SetRowCount(Byval hGrid As Long, Byval iRowCount As Long, Byval blnForce As Long) As Long
Sub Refresh(Byval hGrid As Dword)
Function SetGrid(Byval hGrid As Long, Byval iRow As Long, Byval iCol As Long, Byval strData As BStr) As Long
Function GetGrid(Byval hGrid As Long, Byval iRow As Long, Byval iCol As Long) As BStr
Function blnFlushEditControl(Byval hGrid As Dword) As Long
After that are the actual IGrid interface functions whose addresses are set into the Vtable of the grid COM control, ActiveX control, whatever you want to call it, down in DllGetClassObjectImpl().....
Function IGrid_QueryInterface(....) As Long
Function IGrid_AddRef (....) As Long
Function IGrid_Release (....) As Long
Function IGrid_Initialize (....) As Long
Function IGrid_CreateGrid (....) As Long
Function IGrid_SetRowCount (....) As Long
Function IGrid_SetData (....) As Long
Function IGrid_GetData (....) As Long
Function IGrid_FlushData (....) As Long
Function IGrid_Refresh (....) As Long
Function IGrid_GetCtrlId (....) As Long
Function IGrid_GethGrid (....) As Long
Please take a brief look at all these functions. It goes without saying they are rather important. I'll try to explain how they fit into the big picture.
First, a client app never calls any of these functions directly. In my demo program is a variable declaration like so...
Global pGrid As IGrid
...and a member call on IGrid::CreateGrid like so...
pGrid.CreateGrid(Wea.hWnd,strSetup,10,10,570,218,12,5,28,strFontName,32,%FW_DONTCARE)
Here is what an IGridVtbl and an IGrid look like...
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
GethGrid As Dword Ptr
GetCtrlId As Dword Ptr
End Type
Type IGrid
lpVtbl As IGridVtbl Ptr
End Type
The way IGrid_CreateGrid() gets called by the client is that in DllGetClassObjectImple() a globally defined variable named IGrid_Vtbl of type IGridVtbl gets initialized in terms of its CreateGrid member by a CodePtr() call on IGrid_CreateGrid(). The client, upon successfully creating an object of "FHGrid.Grid" class, will have a pointer to its Vtable in pGrid. At the end of that pointer is the IGridVtbl. Up in the fifth one based slot (fourth zero based slot) in that Vtable sits a pointer to IGrid_CreateGrid. So the client is two levels of indirection removed from the actual function. This creates a tremendous level of insulation between code in the server and code in the client app. Its what COM is all about. Since the client never compiles or links against anything in the server, it doesn't matter what changes are made to it, as long as the interface remains unchanged everything should work. I'd recommend you examine closely all the details I just described in the server code if you want to have a fighting chance of understanding this. Below is the actual code to IGrid_CreateGrid()...
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 Grid Ptr
Local gd As GridData
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
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))
Prnt " hGrid = " & Str$(hGrid)
Incr g_CtrlId
pGrid=this
@pGrid.hContainer=hContainer
@pGrid.hControl=hGrid
Call SetFocus(hGrid)
Prnt " Leaving IGrid_CreateGrid()" : Prnt ""
Function=%S_OK
End Function
You should easily see in this finally how the custom control code integrates into the COM control code because in this function is the CreateWindowEx() call that is the necessary prelude to the creation of the grid and the use of all the grid related functions spoken of briefly by me and which make up the preponderance of the code in dllGrid.bas – the grid custom control. Now lets show some client code that uses the grid. We'll do something as simple as possible like my clients for the custom control code. Here is the inc file for the client...
'PBClient1_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 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 GridEvents As Event
Interface IGrid_Events $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
This code could have been produced by a COM Browser. Here is the main source...
#Compile Exe 'Used PBWin 10.02; Jose's Incs
#Dim All
$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
%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_v1.inc"
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
Global pSink As IGrid_Events
Global pGrid As IGrid
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
Let pGrid = NewCom "FHGrid1.Grid"
Call pGrid.Initialize()
strFontName="Times New Roman"
strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
pGrid.CreateGrid(Wea.hWnd,strSetup,10,10,570,218,12,5,28,strFontName,18,%FW_DONTCARE)
Let pSink = Class "GridEvents"
Events From pGrid Call pSink
For i=1 To 10
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i,j,strCoordinate)
Next j
Next i
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)
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_RETRIEVE
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt "Cell 3,2 Contains " & strData
Case %IDC_UNLOAD_GRID
Events End pSink
Set pGrid=Nothing : Set pSink=Nothing
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%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"
If IsObject(pGrid) Then
Set pGrid=Nothing
End If
If IsObject(pSink) Then
Events End pSink
Set pSink=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,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
Note I hid two globals...
Global pSink As IGrid_Events
Global pGrid As IGrid
...among the locals in fnWndProc_OnCreate(). Thought I'd be above board and warn you about that. In my opinion hiding globals among locals is slightly underhanded, but I did it here nonetheless. There are ways of getting rid of globals in all this, but I felt it would detract from what I'm trying to explain (hiding them in Set/GetWindowLong() or Set/GetProp() calls, and there are other issues unique to COM involved in this that I'd like to put off until later). The calls pertinent to creating an instance of the grid – from fnWndProc_OnCreate(), are as follows....
Let pGrid = NewCom "FHGrid1.Grid"
Call pGrid.Initialize()
StrSetup = "120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
pGrid.CreateGrid(Wea.hWnd, strSetup, 10, 10, 570, 218, 12, 5, 28, "", 32, %FW_DONTCARE)
Let pSink = Class "GridEvents"
Events From pGrid Call pSink
In my opinion, that isn't that much code. First, the class which implements the IGrid interface is instantiated from COM Services through PowerBASIC's NewCom keyword. The phrase "FHGrid1.Grid" is passed to this function as this phrase is the Program ID. Ordinarily you would want to do error checking such as IsTrue(IsObject)) on every call, but here I omitted it for the sake of brevity. After this call successfully completes pGrid will be a pointer to the IGrid interface. The next call...
PGrid.Initialize()
...registers the Window Classes for all the sub-components of the grid such as the cells, the pane, etc. After that you see a string initialized with the column setup information for the grid. Then you have the CreateGrid call on IGrid which creates the grid. It should be very easy for you to see how this translates into the CreateWindowEx() call in IGrid_CreateGrid() within the dll. The final two calls relate to connecting the client's sink up with the COM control. This is an area that always left me a bit wondering and confused, as quite a lot goes on 'behind the scenes' so to speak, and I feel I can do a good job of explaining it, but I'd prefer putting that off just a bit. In my third iteration of the COM control I'll present every possible variation on the connection point code imaginable as well as a lot of discussion. For now, lets just look at the console output from running PBClient_v1.exe.
First, of course, I ought to mention that "FHGrid1.Grid" ought to be registered with COM through putting it in the Windows Registry. For Vista/Win7 users you need to be careful to 'Run As Administrator'. What works for me is to create a batch file in my working directory (like where I ran midl from) that invokes cmd.exe and I right click on that to 'Run As Administrator', and then invoke RegSvr32.exe to register the control...
C:\Code\PwrBasic\PBWin10\COM\Grids\v1>RegSvr32 FHGrid1.dll
After doing that you'll hopefully get a message box telling you the dll registration was successful. I might point out that in x64 Windows the CLSID key won't list the GUID for the Control Class. Due to registry redirection its located under...
HKEY_CLASSES_ROOT\Wow6432Node\Clsid\{0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60}}
Assuming you've created the COM dll, successfully registered it, and compiled the client PBClient_v1.bas, here is the output you would expect to see in the console window (in addition to the grid) after executing the client. I've made considerable notes to the right explaining what is happening, and its significance...
Entering fnWndProc_OnCreate() In Host 'In WM_CREATE handler in Client
Entering DllGetClassObjectImpl() 'This is COM Services 'SCM' loading the dll from PB NewCom statement
Entering IClassFactory_QueryInterface() 'Getting IID_IUnknown or IID_IClassFactory
Entering IClassFactory_AddRef() 'One Class Factory Created and Referenced
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 9964228
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance() 'Now use FHGrid's IClassFactory::CreateInstance to create COM memory layout
pGrid = 1359424 'to support FHGrid. This involves a memory allocation for the class Grid,
Varptr(@pGrid.lpIGridVtbl) = 1359424 'which memory allocation involves 24 bytes; 12 bytes for three interface
Varptr(@pGrid.lpICPCVtbl) = 1359428 'pointers and 12 bytes for three class member variables. The three interface
Varptr(@pGrid.lpICPVtbl) = 1359432 'pointers are for the IGrid, IconnectionPointContainer, and IConnectionPoint
@ppv = 0 << Before QueryInterface() Call
Entering IGrid_QueryInterface() 'pointers. The three member variables are for the reference counter, the
Trying To Get IFHGrid 'hContainer, and the hControl (instance of grid) when its created.
Entering IGrid_AddRef()
@pGrid.m_cRef = 1
Leaving IGrid_AddRef()
this = 1359424
Leaving IGrid_QueryInterface()
@ppv = 1359424 << After QueryInterface() Call
Leaving IClassFactory_CreateInstance()
Entering IGrid_AddRef()
@pGrid.m_cRef = 2
Leaving IGrid_AddRef()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Entering IClassFactory_Release() 'At this point PowerBASIC released the Class Factory, seeing that no more
g_lObjs = 1 'grids were to be created. Bear in mind though that the grid hasn't been
Leaving IClassFactory_Release() 'actually created yet. What has been created so far is just COM infrastructure
'code to support the grid control.
Entering IGrid_QueryInterface()
Trying To Get IFHGrid
Entering IGrid_AddRef()
@pGrid.m_cRef = 2
Leaving IGrid_AddRef()
this = 1359424
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Entering Initialize() -- IGrid_Initialize() 'Here is where pGrid.Initialize() was called in the client. At this point
GetModuleHandle() = 9895936 'all the Window Classes used by the grid are registered (RegisterClassEx().
Leaving Initialize()
Entering IGrid_CreateGrid() 'Here is the important call to pGrid.CreateGrid(...) !!!!! IMPORTANT!!!!!!
this = 1359424
hContainer = 1180416
strSetup = 120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^
x = 10
y = 10 'The big CreateWindowEx() call that instantiates a "Grid" Window Class is
cx = 570 'in this procedure. Of course, if you know your Windows Api programming
cy = 218 'you'll know that the CreateWindowEx() call on the "Grid" Window Class will
iRows = 12 'cause fnGridProc_OnCreate() to execute, as well as all the WM_CREATE
iCols = 5 'handlers for the "Pane", the "Cell"s, so on and so forth, and momentarily
iRowHt = 28 'you'll have a grid on your client's window.
strFontName = Times New Roman
hGrid = 3932902
Leaving IGrid_CreateGrid()
Entering IGrid_QueryInterface() 'The next step after creating the windowing machinery for the
Trying To Get IconnectionPointContainer 'grid is to set up the outgoing interface and the event
this = 1359424 'handling machinery involving the client's sink object. This
Entering IConnectionPointContainer_AddRef() 'output at left would have been caused by the two lines in
@pGrid.m_cRef = 1 << Before 'client right after the CreateGrid() call. PowerBASIC would
@pGrid.m_cRef = 2 << After 'have done a QueryInterface() for IconnectionPointContainer,
Leaving IConnectionPointContainer_AddRef() 'which is in the 1st zero based slot in the class "Grid". The
this = 1359428 'IGrid Vtable pointer is at offset zero at 1359424 and the
Leaving IGrid_QueryInterface() 'IConnectionPointContainer slot is at 1359428 which is the...
Entering IConnectionPointContainer_FindConnectionPoint() 'number returned to the client from the QueryInterface() call.
this = 1359428 'The next thing PowerBASIC did was use the pointer just
@ppCP = 0 'returned to it to see if it can get an IConnectionPoint
Entering IConnectionPointContainer_QueryInterface() 'pointer based on the presence of $IID_IgridEvents. This it
Looking For IID_IConnectionPoint interface pointer. 'managed to do and the IconnectionPoint pointer is in zero
Entering IConnectionPoint_AddRef() 'based slot two of the "Grid" class at 1359432. One of the
@pGrid.m_cRef = 2 << Before 'member functions of IconnectionPoint is the Advise() method
@pGrid.m_cRef = 3 << After 'and that gets called next. The purpose and workings of
Leaving IConnectionPoint_AddRef() 'Advise() are to pass to the COM control the address of an
Leaving IConnectionPointContainer_QueryInterface() 'instantiated class in the client which implements the sink
@ppCP = 1359432 'interface of which the Server/Com Control has the
Leaving IConnectionPointContainer_FindConnectionPoint() 'definitions only, i.e. the IGridEventsVtbl Type previously
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
pUnkSink = 1371108 '...discussed. What might be confusing here is that it all looks somewhat un-necessary for the
@pUnkSink = 2109324 'server to do a QueryInterface() call back into the client from within Advise() to get the same
Vtbl = 2109324 'number that was originally passed to it from the client, i.e., 1371044, but it might not
@Vtbl[0] = 2115400 'always be like this if the class passed to the server has more than the $IID_IGridEvents
g_ptrOutGoing = 0 'interface implemented within it. In this unique and simple case where the GridEvents class
g_ptrOutGoing = 1371108 'only has the IGrid_Events interface implemented within it, the ptr to the event sink interface
Call Dword Succeeded! 'will be the same number as the address of the clients sink class. I hope I made and explained
Leaving IConnectionPoint_Advise() And Still In One Piece! 'this clear, although I fear I haven't!
Entering IGrid_AddRef()
@pGrid.m_cRef = 4
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 'The output you are seeing here is from me clicking in cell ( 3, 2 ) and deleting the
Got KeyPress From Grid! 114=r 'contents of the cell, then typing in my first name of fred. Then, while leaving the
Got KeyPress From Grid! 101=e 'cursor blinking in cell ( 3, 2 ), I clicked the 'Retrieve (3,2)" button in the client.
Got KeyPress From Grid! 100=d 'As I may have mentioned, leaving the cursor in a cell after an edit causes major
Cell 3,2 Contains fred 'problems with the grid control I'm now using. One can not retrieve the data from the
'cell under those conditions, and that is one of the reasons I decided to write my own
'grid control.
Entering IGrid_QueryInterface()
Trying To Get IconnectionPointContainer 'All this code here involves PowerBASIC releasing
this = 1359424 'all the interface pointers its presently holding
Entering IConnectionPointContainer_AddRef() 'so as to release the grid and dll and close down.
@pGrid.m_cRef = 2 << Before 'Apparently PowerBASIC released its
@pGrid.m_cRef = 3 << After 'IconnectionPointContainer and IConnectionPoint
Leaving IConnectionPointContainer_AddRef() 'interface pointers after setting up the connection
this = 1359428 'point to the sink in the client, for here it is
Leaving IGrid_QueryInterface() 're-acquiring them so as to release the Server's...
Entering IConnectionPointContainer_FindConnectionPoint() 'hold on its sink. The IconnectionPoint::Unadvise()
this = 1359428 'method does that.
@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 = 1359432
Leaving IConnectionPointContainer_FindConnectionPoint()
Entering IConnectionPoint_Unadvise()
this = 1359432
@pGrid.hControl = 3932902
dwPtr = 1371044
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() 'Here all the pointers have been released and there is a call
@pGrid.m_cRef = 2 << Before 'of CoFreeUnusedLibraries() in the client which causes Windows
@pGrid.m_cRef = 1 << After 'to call DllCanUnloadNow() in the server. The server will
Leaving IConnectionPointContainer_Release() 'indicate back to windows that it can be unloaded if there
'are no server locks on the server, and no outstanding objects
Entering IGrid_Release() 'left. In this case there aren't, so the server is unloaded
@pGrid.m_cRef = 1 << Before 'and the client closes.
@pGrid.m_cRef = 0 << After
Grid Was Deleted!
Leaving IGrid_Release()
Entering fnWndProc_OnClose() In Host
Entering DllCanUnloadNow()
I'm Outta Here!
Leaving DllCanUnloadNow()
Leaving fnWndProc_OnClose() In Host
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...
%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...
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...
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)...
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...
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.
'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....
'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....
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...
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...
Global pSink1 As IGridEvents
Global pGrid1 As IGrid
Global pSink2 As IGridEvents
Global pGrid2 As IGrid
Grid Creation Code...
'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...
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....
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...
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!
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.
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....
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()...
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...
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...
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...
// 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;
}
};
Without further ado here is version #2 of our grid COM Control (probably will need three posts to fit it all)...
#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
continued...
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
continued...
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
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...
$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...
'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...
'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...
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
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...
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!
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!
This is a topic I would really like to get into, but I am too busy with Phoenix at the moment.
Quote
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
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,
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
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.
'-------------------------------------------------------------------------------
'
' 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
Quote
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.
Quote
'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?
Quote
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.
Quote
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.
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...
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....
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.
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...
Quote
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!
Quote
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?
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.
Well Dominic, I thought it over and decided to get off my high horse and just implement it as you suggested. I'll work on it today. I still think its a feature of dubious value, i.e., a client creating an object, then setting up multiple sinks and calling Advise on the object multiple times, but maybe it would be useful in some other context than with a grid control.
I don't believe I'll do as sophisticated an arrangement as you have, but I'll come up with something as minimal as possible. I guess the part I wasn't seeing through clearly was the connection between messages coming through the Window Procedure for the grid, and firing event notifications at the correct sinks. But if I include a pointer to the whole object in my GridData UDT as you suggested, instead of a seperate pointer to the single outgoing interface as I now have it, then that will without the possibility of error allow me to retrieve from some sort of array of sink pointers the data I'll need to pull it off.
Quote
Well Dominic, I thought it over and decided to get off my high horse and just implement it as you suggested.
I'll work on it today. I still think its a feature of dubious value, i.e., a client creating an object, then
setting up multiple sinks and calling Advise on the object multiple times, but maybe it would be useful in some
other context than with a grid control.
It is not dubious. You do have the option of limiting the number of connections to only one sink, but the client
has to be warned of that fact. You cannot just return S_OK.
If you want to limit the outgoing interface to only one connection, then IConnectionPoint::Advise should return
CONNECT_E_ADVISELIMIT when the connection point already has a pointer to a sink or it has reached the limit of the number of connections it can accept.
Maybe I'm being too hard on the concept. In any case I have it implemented and will likely post it today as Version #4 followed by Version #3. Out of order perhaps, but I already had Version #3 done when I addressed your concerns about my Advise(). I will admit I had a lot of fun fixing it. It really works slick, and where I could see it as being of some use is where two forms are visible on the screen, and when the user interacts with one something needs to be updated on the other. The way I would have handled that might be more awkward than this way.
The other thing you mentioned in your first post about it being a strange setup of mine how a NewCom() call on the part of PowerBASIC fails to actually create a grid, i.e., after that call a CreateGrid() interface call is necessary, the reason for that is it doesn't seem like in the case of grids in particular any default construction would be in any way usable. If you think about the way a MSFlexGrid works in the Visual Basic visual designer, you could just drag one to your form and click the 'run' button and you would actually get a functioning but non-usable grid with something like one or two rows and one or two columns. Either at design time or run time you would then need to set the column headings, numbers of columns, numbers of rows, etc. I didn't feel like adding to my code bulk to allow for the setup of a non-usable grid, and the creation of a usable grid through later Interface calls. My hope was rather to simply mimic the usage of a custom control where the user would likely create the grid through a CreateWindowEx() call, likely passing into the grid its setup information through the lpCreateParams pointer of the CreateWindowEx() call. Since I specified in the Idl file that the interface was Automation compatible, and I hoped it would work with Visual Basic, I had to resort to all those parameters in the CreateGrid() interface method.
Putting piles of additional interface members in my IGrid interface to allow setting up the columns, rows, fonts, etc., would have radically changed my base custom control code, which didn't have those features (it was setup to allow for the grid creation to be completed in one fell swoop, rather than peicemeal). And one of my goals here was to show how a custom control could be converted to a COM based thing. So thats the reason for that. To put it simply, in the case of grids there is no default configuration that is in any way usable. If you were building a clock, for example, that would likely be usable as is, as I think most folks use a 24 hour clock with 60 minutes in an hour, etc. So you might have a different situation there.
The other thing is I'm extremely conscious of code size. I'm wanting as minimal and small a grid as possible that is still usable. Thanks for your input on this. I appreciate it.
Have you tried embedding your grid in Microsoft Excel/Word, or a web page, or using it from VBScript?
In my opinion, you control is not playing by the activation rules.
No. I know you are busy working on Phoenix Dominic, so I'm asumming you probably only skimmed my material. It is a lot - I know. Or maybe I'm asumming you've read my Version #4 - which I haven't posted yet. But I did try to make it fairly clear at the outset that my grid won't allow embedding, at least in the sense I understand that term. That is, no registry entries are being made for it under CLSID such as 'Control', 'Insertable', or 'MiscStatus' bits. Also, IDispatch isn't implemented. Nor are...
IOleObject
IOleInPlaceObject
IOleInPlaceActiveObject
IDataObject
IViewObject2
IPersistStream
So it won't show up under the 'Components' tab of Visual Basic's 'Project' menu, nor will it due to that be able to be represented as an icon in Visual Basic's Toolbox. Rather, it will show up in the 'References' dialog where non-visual com components are shown.
So you might question, "What good is it?" I believe I answered that in my first posts where I discussed the issues of using PowerBASIC custom controls in other languages such as C++. PowerBASIC doesn't create *.lib files that allow a C or C++ coder to easily use PowerBASIC binaries. On the other hand, its really pretty easy to use this COM based grid in C or C++ - even .NET. While it won't support drag and drop in a visual designer, its nonetheless a full fledged COM object, and all its methods and events show up perfectly well in .NET's code editor - intellisense, event procedures, object browser, etc.
So I guess you could say its kind of a hybrid of sorts. Its a COM object that has a visual interface but without supporting all the interfaces almost exclusively associated with embeddable visual components that were designed to work with visual designers. Because it doesn't have to carry all the code along with itself to support its 'design mode' functionality, and because it doesn't require an 'ActiveX Control Container', it is quite lightweight. The grid custom control I posted at the beginning of this thread has close to all the functionality I need in a grid control, and it compiles to only 28K. When I converted it over to a COM based control that brought it up to around 42K due to the necessary addition of registry and COM infrastructure code. However, compare 42K with something such as the MSFlexGrid or even other grid custom controls which are in the megabyte range, and you'll have to admit it shows that COM doesn't automatically equate with bloat. So yes, I'm after something different here.
Ok, I believe I've satisfactorily added the necessary capabilities to my Version #2 code to allow multiple Sink Classes to be connected to a single instance of the grid. So, Version #4 extends Version #2's ability to create multiple grids by allowing multiple connections per grid.
I've also reconsidered a good bit of all this. At the time Dominic Mitchell called into question my Connection Point code, I was of the opinion that multiple sink connections weren't worth the trouble. However, the code I'm now going to post not only solved the problem of handling multiple connections per grid object, but it also removes the need for me to even provide my already finished Version #3. My version #3 was created to allow the grid to work with Visual Basic .NET. So what I'm saying is that the changes I made to version #2 to allow for multiple sinks also as an added side bonus allowed the code to now work with .NET. I had some fuzzy thinking going on in my head about the whole issue that has now become clearer to me. Let me try to outline the issues.
The reason my Version #2 Grid wouldn't work with .NET is because in .NET it appears that the loading of the COM object and the setup of the connection point is done simultaneously. In other words, to use my grid in .NET one would first start up a .NET Windows Forms application, then go to the...
Project >>> Add References
dialog, where one would click on the COM tab. At that point .NET Visual Studio would search the Windows Registry for registered COM objects, and populate a control listing them. One would then locate FHGrid4 Typelib and select it. At that point Visual Studio would read the type library embedded within FHGrid4.dll, and it would learn about all the interfaces and interface methods within the type library. These would in our case include the IGrid interface methods of the inbound interface, and the event procedures of the IGridEvents outbound interface. If one were then to go to a code window behind the default Form1 provided, and code the following line at form module scope, which, I believe, is the only place it is allowed in .NET...
Public WithEvents pGrid As New FHGrid4Library.FHGrid4
...then this object will be created and an attempt made to set up the connection point before we've even had a chance to call the CreateGrid() method of the IGrid interface. The problem with this in terms of the Version #2 code I provided is that in that code, when IConnectionPoint::Advise() is called to set up the connection point, my code is looking for a window handle so as to store the address of the client's sink in the grid's .cbWndExtra bytes. Here is the Advise() method from Version #2 without the debug stuff...
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
Decr this : Decr this
pGrid=this
Vtbl=@pUnkSink
Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(dwPtr)) To hr
Call SetWindowLong(@pGrid.hWndCtrl,4,dwPtr) '<<<< This Won't Work In .NET!!!!!!
If SUCCEEDED(hr) Then
@pdwCookie=1
Else
@pdwCookie=0
End If
Function=hr
End Function
It worked fine in C++ or PowerBASIC simply because I was setting up the sink code after I had created a grid, e.g.,...
Let pGrid = NewCom "FHGrid3.Grid" 'This calls IClassFactory_CreateInstance() without setting up events
strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^" 'Row/column/positioning,font setup info for grid
pGrid.Create(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE) 'Method call on COM object to create grid; will result in window handle
pConnectionPointContainer = pGrid 'This causes a QueryInterface() for IConnectionPointContainer
EventGuid=$IID_IGridEvents 'This puts a binary Guid in a Guid variable from text representation
Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConnectionPoint)) 'This obtains a pointer to the Grid's IConnectionPoint interface
Let pSink = Class "CEventClass" 'This instantiates the sink class "CGridEvents"
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie) 'This passes the address of the sink class to the grid
So you can see the success of my code was dependant on a particular order of call or sequence of operations being followed which .NET didn't honor. And fixing this as I had done in my Version #3 code was rather nasty. What I really should have done was to not store the pointer to the sink in the .cbWndExtra bytes of the grid but rather within the "FHGrid4" COM Class. In all the examples I had seen in C++ what the authors had done was to wrap an array within a class and store a pointer to the class in the COM Class structure. But being as these were all non GUI worker objects, I thought I knew better with my GUI grid. I thought I'd store them in the window. The sink addresses really need to be stored in the COM Class though. But before I show that code, and in lieu of providing Version #3 which is now defunct, let me briefly describe what I did to solve the problem in terms of that failed paradigm.
Since my version #2 code's Advise method required a window handle so the client sink could be stored in the .cbWndExtra bytes of the window, I reasoned I'd give it a window handle but only that and nothing more - no grid. So instead of having the CreateWindowEx() call that creates the grid in IGrid_Create(), I put it in IClassFactory_CreateInstance(). By doing this it allowed my Advise() code to have a valid window handle to work with in the event the object was being used in .NET where the connection point was being set up before the grid GUI object was created. But if you recall, all the information to set up the grid, i.e., creation of the pane, the cells, the header control, the rows, the columns, etc., were being processed in the WM_CREATE handler for the grid class, and none of this information whatsoever would be available at the time of the premature CreateWindowEx() call in IClassFactory_CreateInstance()! Quite a dilemma!
The solution was to create a real zombie window with no functionality besides the ability to furnish a HWND and later create the grid outside the WM_CREATE handler and re-parent and attach it to the zombie window. Have you ever seen such a poor CreateWindow() call as this...
hGrid=CreateWindow("Grid","",0,0,0,0,0,0,0,hInstance,Byval 0)
Believe it or not, that works. Later in the code I re-parented the window with SetParent() and assigned the other window class attributes with SetWindowLong() and SetWindowPos(), all of which shows the extent to which a failed design can be salvaged with ingenious hacks!
But all that is pretty much moot at this point. Lets jump into the changes I made to Version #2 that allows the grid to now support multiple sinks, and work in Visual Studio .NET. Here is a description of the changes I made. I added a buffer to my CGrid class to store %MAX_CONNECTIONS sink addresses...
%MAX_CONNECTIONS = 4 'Maximum number of sinks which can be hooked up to connection point
....
....
Type CGrid
lpIGridVtbl As IGridVtbl Ptr
lpICPCVtbl As IConnectionPointContainerVtbl Ptr
lpICPVtbl As IConnectionPointVtbl Ptr
hWndCtrl As Dword
pISink As Dword Ptr <<< This addition stores client sink addresses
m_cRef As Long
End Type
Following through on this, it will need to be allocated in IClassFactory_CreateInstance()...
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
@ppv=%NULL
If pUnknown Then
hr=%CLASS_E_NOAGGREGATION
Else
pGrid=CoTaskMemAlloc(SizeOf(CGrid)) 'Allocate 24 bytes for CGrid
If pGrid Then
@pGrid.pISink=CoTaskMemAlloc(%MAX_CONNECTIONS * %SIZEOF_PTR) 'Allocate %MAX_CONNECTIONS x 4 bytes for sink addresses
If @pGrid.pISink Then
Call memset(Byval @pGrid.pISink,0,%MAX_CONNECTIONS*%SIZEOF_PTR) 'Zero out buffer
@pGrid.lpIGridVtbl = VarPtr(IGrid_Vtbl) 'Attach IGrid VTable
@pGrid.lpICPCVtbl = VarPtr(IConnPointContainer_Vtbl) 'Attach IConnectionPointContainer VTable
@pGrid.lpICPVtbl = Varptr(IConnPoint_Vtbl) 'Attach IConnectionPoint VTable
@pGrid.m_cRef = 0 'Initialize reference count
@pGrid.hWndCtrl = 0 'Null Window Handle
pIGrid=pGrid
hr= IGrid_QueryInterface(pIGrid,RefIID,ppv)
If SUCCEEDED(hr) Then
Call InterlockedIncrement(g_lObjs)
Else
Call CoTaskMemFree(pGrid)
End If
Call Initialize()
Else
Call CoTaskMemFree(Byval pGrid)
hr=%E_OutOfMemory
End If
Else
hr=%E_OutOfMemory
End If
End If
IClassFactory_CreateInstance=hr
End Function
Of course, a major change will be in IConnectionPoint::Advise(), which now will actually use the dwCookie parameter as an [out], and it will actually be the DWORD offset index in the CGrid::pISink buffer...
Function IConnectionPoint_Advise(Byval this As IConnectionPoint1 Ptr, Byval pUnkSink As Dword Ptr, Byval pdwCookie As Dword Ptr) As Long
Local blnFoundOpenSlot As Long
Local Vtbl,dwPtr As Dword Ptr
Local pGrid As CGrid Ptr
Register i As Long
Local hr As Long
Decr this : Decr this
pGrid=this
Vtbl=@pUnkSink
Call Dword @Vtbl[0] Using ptrQueryInterface(pUnkSink,$IID_IFHGrid_Events,Varptr(dwPtr)) To hr
If SUCCEEDED(hr) Then
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i]=0 Then 'If there is no sink address stored in a slot, then
blnFoundOpenSlot=%True 'it can be used. If the loop continues through to
Exit For 'the end and no empty spots are found, then return
End If '%CONNECT_E_ADVISELIMIT. Note that in the Unadvise()
Next i 'Method, if a slot is released, it can be nulled out
If blnFoundOpenSlot Then 'thus freeing up that slot for other use. This loop
@pGrid.@pISink[i]=dwPtr 'will find it.
@pdwCookie=i
hr=%S_Ok
Else
@pdwCookie=0
hr=%CONNECT_E_ADVISELIMIT
End If
End If
Function=hr
End Function
And the corresponding IConnectionPoint::Unadvise()...
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
Decr this : Decr this
pGrid=this
dwPtr=@pGrid.@pISink[dwCookie]
Vtbl=@dwPtr
Call Dword @Vtbl[2] Using ptrRelease(dwPtr) To iReturn
If SUCCEEDED(iReturn) Then
@pGrid.@pISink[dwCookie]=0 'Null out for possible re-use.
Function = %S_Ok
Else
Function=%E_FAIL
End If
End Function
Also, I believe this was Dominic's idea, but I added a class object pointer to my GridData UDT...
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
pComObj As Dword Ptr ' <<< Added pComObj, i.e., pointer to COM object
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 * 24
End Type
This effectively relates an entity, i.e., a GUI grid - which knows nothing about COM or what is going on in that sphere, to the memory allocation for the COM object which is driving it. And the flip side of the coin is that the CGrid UDT has a hWndCtrl member which relates COM stuff to a Window. Right near the very bottom of IGrid_Create() is where the pComObj member in GridData gets set...
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 pGridData As GridData Ptr
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 ' <<< Set hGrid into "FHGrid4.Grid" COM Class
pGridData=GetWindowLong(hGrid,0)
#If %Def(%DEBUG)
Prnt " pGridData = " & Str$(pGridData)
#EndIf
@pGridData.pComObj=this ' <<< Set .pComObj into GridData, which is Windowing stuff !
Call SetFocus(hGrid)
#If %Def(%DEBUG)
Prnt " Leaving IGrid_CreateGrid()" : Prnt ""
#EndIf
Function=%S_OK
End Function
There is a CreateWindowEx() call above which actually ties the whole thing together, i.e., the non-GUI COM infrastructure code, and the GUI Windowing machinery. The memory allocation for GridData is in the WM_CREATE handler for the CreateWindowEx() call that creates the grid.
Most of the calls the grid COM object makes into the client's event sink(s) originate from an edit control subclass procedure in the grid code, i.e., fnEditSubClass, that looks something like this....
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 pGrid As CGrid Ptr
Register i As Long
Local hr As Long
hCell=GetParent(hEdit) : hPane=GetParent(hCell)
hBase=GetParent(hPane) : hGrid=GetParent(hBase)
pGridData=GetWindowLong(hPane,0)
pGrid=@pGridData.pComObj
Select Case As Long wMsg
Case %WM_CHAR
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[3] Using ptrKeyPress(dwPtr, wParam, lParam, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
If wParam=%VK_RETURN Then
Call blnFlushEditControl(hGrid)
Call Refresh(hGrid)
Exit Function
Else
@pGridData.hEdit=hEdit
End If
Case %WM_KEYDOWN
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[4] Using ptrKeyDown(dwPtr, wParam, lParam, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
Case %WM_PASTE
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[7] Using ptrPaste(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
Case %WM_LBUTTONDBLCLK
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[6] Using ptrLButtonDblClk(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
End Select
Function=CallWindowProc(fnEditWndProc,hEdit,wMsg,wParam,lParam)
End Function
I think that's close to about it. I'll now provide a console output run, the client which produces it (which calls Advise() twice with two Sink classes), and finally FHGrid4.bas, which is the source for the COM Dll. Note this uses different GUIDs and Program IDs from the others. Here is a console output run...
Entering fnWndProc_OnCreate()
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 2693828
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pGrid = 5242056
Varptr(@pGrid.lpIGridVtbl) = 5242056
Varptr(@pGrid.lpICPCVtbl) = 5242060
Varptr(@pGrid.lpICPVtbl) = 5242064
@pGrid.pISink = 5237072
@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 = 5242056
Leaving IGrid_QueryInterface()
@ppv = 5242056 << After QueryInterface() Call
Entering Initialize() -- Initialize()
GetModuleHandle() = 2621440
Leaving Initialize()
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 = 5242056
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Entering IGrid_CreateGrid()
this = 5242056
hContainer = 590550
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 = 787046
pGridData = 4204880
Leaving IGrid_CreateGrid()
Entering IGrid_QueryInterface()
Trying To Get IConnectionPointContainer
this = 5242056
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 1 << Before
@pGrid.m_cRef = 2 << After
Leaving IConnectionPointContainer_AddRef()
this = 5242060
Leaving IGrid_QueryInterface()
Entering IConnectionPointContainer_FindConnectionPoint()
this = 5242060
@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 = 5242064
Leaving IConnectionPointContainer_FindConnectionPoint()
Objptr(pSink1) = 4202716
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
this = 5242064
pGrid = 5242056
@pGrid.hControl = 787046
pGridData = 4204880
@pGridData.pComObj = 5242056
pUnkSink = 4202716
Vtbl = 2110891
@Vtbl[0] = 2117752
dwPtr = 4202716
Call Dword Succeeded!
0 5237072 0 Found Open Slot!
Will Be Able To Store Connection Point!
Leaving IConnectionPoint_Advise() And Still In One Piece!
dwCookie1 = 0
Objptr(pSink2) = 4232812
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
this = 5242064
pGrid = 5242056
@pGrid.hControl = 787046
pGridData = 4204880
@pGridData.pComObj = 5242056
pUnkSink = 4232812
Vtbl = 2111059
@Vtbl[0] = 2117752
dwPtr = 4232812
Call Dword Succeeded!
0 5237072 4202716
1 5237076 0 Found Open Slot!
Will Be Able To Store Connection Point!
Leaving IConnectionPoint_Advise() And Still In One Piece!
dwCookie2 = 1
Leaving fnWndProc_OnCreate()
Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1(3,2)
Got WM_LBUTTONDOWN In Grid Cell From CGridEvents2(3,2)
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents2! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents2! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents2! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents2! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents2! 46=.
Got KeyDown From CGridEvents1! 70=F
Got KeyDown From CGridEvents2! 70=F
Got KeyPress From CGridEvents1! 102=f
Got KeyPress From CGridEvents2! 102=f
Got KeyDown From CGridEvents1! 82=R
Got KeyDown From CGridEvents2! 82=R
Got KeyPress From CGridEvents1! 114=r
Got KeyPress From CGridEvents2! 114=r
Got KeyDown From CGridEvents1! 69=E
Got KeyDown From CGridEvents2! 69=E
Got KeyPress From CGridEvents1! 101=e
Got KeyPress From CGridEvents2! 101=e
Got KeyDown From CGridEvents1! 68=D
Got KeyDown From CGridEvents2! 68=D
Got KeyPress From CGridEvents1! 100=d
Got KeyPress From CGridEvents2! 100=d
Entering fnWndProc_OnCommand()
Case %IDC_RETRIEVE
Cell 3,2 Contains fred
Leaving fnWndProc_OnCommand()
Entering fnWndProc_OnCommand()
Case %IDC_UNLOAD_GRID
Entering DestroyGrid()
Entering IConnectionPoint_Unadvise()
this = 5242064
dwCookie = 0
@pGrid.hWndCtrl = 787046
dwPtr = 4202716
IGrid_Events::Release() Succeeded!
Release() Returned 1
Leaving IConnectionPoint_Unadvise()
Entering IConnectionPoint_Unadvise()
this = 5242064
dwCookie = 1
@pGrid.hWndCtrl = 787046
dwPtr = 4232812
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
0 5237072 0
1 5237076 0
2 5237080 0
3 5237084 0
@pGrid.m_cRef = 0 << After
Grid Was Deleted!
Leaving IGrid_Release()
Leaving DestroyGrid()
Leaving fnWndProc_OnCommand()
Entering DestroyGrid()
'Everything Already Released!
Leaving DestroyGrid()
Entering DllCanUnloadNow()
I'm Outta Here! (dll is unloaded)
Leaving DllCanUnloadNow()
And here would be PBClient3_v4.bas which produced that output. Note two sink classes and two Advise() calls in fnWndProc_OnCreate()...
'PBClient3_v4.bas 'no include file with this one; its all here.
#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-000000000070}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000071}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000072}")
%IDC_RETRIEVE = 1500
%IDC_UNLOAD_GRID = 1505
#Include "Windows.inc"
#Include "ObjBase.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
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation
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 CGridEvents1 As Event
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
Prnt "You Clicked For Row #" & Str$(iGridRow) & " And This Courtesy CGridEvents1!"
End Method
End Interface
End Class
Class CGridEvents2 As Event
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got KeyPress From CGridEvents2!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got KeyDown From CGridEvents2!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents2" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
Prnt "You Clicked For Row #" & Str$(iGridRow) & " And This Courtesy CGridEvents2!"
End Method
End Interface
End Class
Global pSink1 As IGridEvents
Global pSink2 As IGridEvents
Global pGrid As IGrid
Global pConPtCon As IConnectionPointContainer
Global pConPt As IConnectionPoint
Global dwCookie1 As Dword
Global dwCookie2 As Dword
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()
Prnt "Entering fnWndProc_OnCreate()"
pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance
Let pGrid = NewCom "FHGrid4.Grid"
strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
pGrid.CreateGrid(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE)
pConPtCon = pGrid
EventGuid=$IID_IGridEvents
Call pConPtCon.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConPt))
'Connect Sink #1
Let pSink1 = Class "CGridEvents1"
Prnt " Objptr(pSink1) = " & Str$(Objptr(pSink1))
Call pConPt.Advise(Byval Objptr(pSink1), dwCookie1)
Prnt " dwCookie1 = " & Str$(dwCookie1)
'Connect Sink #2
Let pSink2 = Class "CGridEvents2"
Prnt " Objptr(pSink2) = " & Str$(Objptr(pSink2))
Call pConPt.Advise(Byval Objptr(pSink2), dwCookie2)
Prnt " dwCookie2 = " & Str$(dwCookie2)
'Fill Grid
For i=1 To 25
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
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)
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid()
Prnt " Entering DestroyGrid()"
If IsTrue(IsObject(pConPt)) Then
Call pConPt.Unadvise(dwCookie1)
Call pConPt.Unadvise(dwCookie2)
End If
If IsTrue(IsObject(pSink1)) Then
Set pSink1 = Nothing
End If
If IsTrue(IsObject(pSink2)) Then
Set pSink2 = 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
Prnt " Leaving DestroyGrid()"
End Sub
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_RETRIEVE
Prnt " Case %IDC_RETRIEVE"
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Case %IDC_UNLOAD_GRID
Prnt " 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
Prnt "Leaving fnWndProc_OnCommand()"
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 is FHGrid4.bas. Like with the others, if you want to compile it you had better deal with the path to the output log file in DllMain(). I'll attach the FHGrid4.tlb file after this post...
#Compile Dll "FHGrid4.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 "OleCtl.inc"
#Include "HeaderCtrl.inc"
#Include "Memory.inc"
#Resource Typelib, 1, "FHGrid4.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.
%MAX_CONNECTIONS = 4 'Maximum number of sinks which can be hooked up to connection point
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-000000000070}")
$IID_IFHGrid = Guid$("{20000000-0000-0000-0000-000000000071}")
$IID_IFHGrid_Events = Guid$("{20000000-0000-0000-0000-000000000072}")
$IID_LIBID_FHGrid = Guid$("{20000000-0000-0000-0000-000000000073}")
Type IGridVtbl
QueryInterface As Dword Ptr
AddRef As Dword Ptr
Release 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
pComObj As Dword Ptr
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 * 24
End Type
Type CGrid
lpIGridVtbl As IGridVtbl Ptr
lpICPCVtbl As IConnectionPointContainerVtbl Ptr
lpICPVtbl As IConnectionPointVtbl Ptr
hWndCtrl As Dword
pISink As Dword Ptr
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
Register i As Long
#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
#If %Def(%DEBUG)
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call DestroyWindow(@pGrid.hWndCtrl)
Call CoTaskMemFree(Byval @pGrid.pISink)
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_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 pGridData As GridData Ptr
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
pGridData=GetWindowLong(hGrid,0)
#If %Def(%DEBUG)
Prnt " pGridData = " & Str$(pGridData)
#EndIf
@pGridData.pComObj=this
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
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 pGrid As CGrid Ptr
Local iReturn,hr As Long
Register i 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)
pGrid=@pGridData.pComObj
Select Case As Long wMsg
Case %WM_CHAR
#If %Def(%DEBUG)
Print #fp, " Got WM_CHAR Message In fnEditSubClass!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[3] Using ptrKeyPress(dwPtr, wParam, lParam, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
#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
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[4] Using ptrKeyDown(dwPtr, wParam, lParam, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
#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
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[7] Using ptrPaste(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
#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
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[6] Using ptrLButtonDblClk(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
#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
Local pGrid As CGrid 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
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)
pGrid=@pGridData.pComObj
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
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
End If
Next i
#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 pGrid As CGrid Ptr
Local si As SCROLLINFO
Register i As Long
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Entering fnGridProc_OnCommand()"
Prnt ""
Prnt "Entering fnGridProc_OnCommand()"
Print #fp, " Lowrd(Wea.wParam) = " Lowrd(Wea.wParam)
#EndIf
If Lowrd(Wea.wParam)>20000 Then
pGridData=GetWindowLong(Wea.hWnd,0)
pGrid=@pGridData.pComObj
#If %Def(%DEBUG)
Prnt " pGridData = " & Str$(pGridData)
Prnt " @pGridData.pComObj = " & Str$(@pGridData.pComObj)
Prnt " pGrid = " & Str$(pGrid)
Prnt ""
Prnt " i pGrid.@pISink[i] @pGrid.@pISink[i]"
Prnt " ========================================="
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
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=@pGrid.@pISink[0]
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()"
Prnt "Leaving fnGridProc_OnCommand()"
Prnt ""
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
Sub Initialize()
Local szClassName As ZStr*16
Local wc As WNDCLASSEX
#If %Def(%DEBUG)
Prnt " Entering Initialize() -- 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
Call RegisterClassEx(wc)
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
Call RegisterClassEx(wc)
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
Call RegisterClassEx(wc)
szClassName="Grid"
wc.lpszClassName=VarPtr(szClassName) : wc.lpfnWndProc=CodePtr(fnGridProc)
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(%DKGRAY_BRUSH)
wc.lpszMenuName=%NULL
#If %Def(%DEBUG)
Prnt " GetModuleHandle() = " & Str$(wc.hInstance)
#EndIf
Call RegisterClassEx(wc)
Call AttachMessageHandlers()
#If %Def(%DEBUG)
Prnt " Leaving Initialize()"
#EndIf
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
Register i As Long
#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
#If %Def(%DEBUG)
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call DestroyWindow(@pGrid.hWndCtrl)
#If %Def(%DEBUG)
Prnt " @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
#EndIf
Call CoTaskMemFree(Byval @pGrid.pISink)
Call CoTaskMemFree(Byval 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
Register i As Long
#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
#If %Def(%DEBUG)
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call DestroyWindow(@pGrid.hWndCtrl)
#If %Def(%DEBUG)
Prnt " @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
#EndIf
Call CoTaskMemFree(Byval @pGrid.pISink)
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 blnFoundOpenSlot As Long
Local Vtbl,dwPtr As Dword Ptr
Local pGrid As CGrid Ptr
Register i As Long
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)
#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
If SUCCEEDED(hr) Then
#If %Def(%DEBUG)
Prnt " Call Dword Succeeded!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i]=0 Then
blnFoundOpenSlot=%True
#If %Def(%DEBUG)
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i]) & " Found Open Slot!"
#EndIf
Exit For
Else
#If %Def(%DEBUG)
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
#EndIf
End If
Next i
If blnFoundOpenSlot Then
#If %Def(%DEBUG)
Prnt " Will Be Able To Store Connection Point!"
#EndIf
@pGrid.@pISink[i]=dwPtr
@pdwCookie=i
hr=%S_Ok
Else
@pdwCookie=0
hr=%CONNECT_E_ADVISELIMIT
End If
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)
Prnt " dwCookie = " & Str$(dwCookie)
#EndIf
Decr this : Decr this
pGrid=this
#If %Def(%DEBUG)
Prnt " @pGrid.hWndCtrl = " & Str$(@pGrid.hWndCtrl)
#EndIf
dwPtr=@pGrid.@pISink[dwCookie]
Vtbl=@dwPtr
#If %Def(%DEBUG)
Prnt " dwPtr = " & Str$(dwPtr)
#EndIf
Call Dword @Vtbl[2] Using ptrRelease(dwPtr) To iReturn
If SUCCEEDED(iReturn) Then
@pGrid.@pISink[dwCookie]=0
#If %Def(%DEBUG)
Prnt " IGrid_Events::Release() Succeeded!"
#EndIf
End If
Prnt " Release() Returned " & Str$(iReturn)
Prnt " Leaving IConnectionPoint_Unadvise()" : Prnt ""
Function=%NOERROR
End Function
Function IConnectionPoint_EnumConnections(Byval this As Dword, Byval ppEnum As Dword) As Long
Function=%E_NOTIMPL
End Function
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.pISink=CoTaskMemAlloc(%MAX_CONNECTIONS * %SIZEOF_PTR)
If @pGrid.pISink Then
Call memset(Byval @pGrid.pISink,0,%MAX_CONNECTIONS*%SIZEOF_PTR)
@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))
Prnt " @pGrid.pISink = " & Str$(@pGrid.pISink)
#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
Call Initialize()
Else
Call CoTaskMemFree(Byval pGrid)
hr=%E_OutOfMemory
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
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 v4"
szVerIndProgID = "FHGrid4.Grid"
szProgID = "FHGrid4.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 = "FHGrid4.Grid"
szProgID = "FHGrid4.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\v4\Output.txt" For Output As #fp
Print #fp, "Entering DllMain() -- %DLL_PROCESS_ATTACH"
#EndIf
Call DisableThreadLibraryCalls(hInstance)
g_hModule = hInstance
g_CtrlId = 1500
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.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)
Case %DLL_PROCESS_DETACH
#If %Def(%DEBUG)
Print #fp, "Leaving DllMain() -- %DLL_PROCESS_DETACH"
Close #fp
#EndIf
End Select
DllMain=%TRUE
End Function
There were three posts above with the Dll code that will need to be combined. Attached here is the FHGrid4.tlb file.
I'll provide additional clients and discuss other interesting (at least to me) ideas in a bit.
Below are directions for trying the COM Grid Control out in Visual Basic .NET. I imagine C# would be somewhat similar. I have Visual Studio Professional 2008, just so you know. I guess yours could be different if you have another version.
1) Open Visual Studio and choose a new Visual Basic Windows Forms project;
2) Create the project wherever you want and you should end up with a default startup Form1;
3) I named the project prjFHGrid4 and the form frmFHGrid4. That will affect the names of the various procedures shown in the code below. I used the toolbox to create two buttons near the bottom of the form. The one on the lower left I named btnRetrieve and the one lower right I named btnDestroyGrid. The caption on the left one was "Retrieve (3, 2)" and the caption on the right one was "Destroy Grid";
4) Go to the 'Project' main menu item and choose 'Add Reference...'. A dialog will come up with various tabs. Select the 'COM' tab. It will take Visual Studio a bit of time to search through your registry looking for COM objects. You should be able eventually to find 'FHGrid4 Typelib'. Select it and click the OK button;
5) Here is the code in my code window behind frmFHGrid4...
Public Class frmFHGrid4
Public WithEvents pGrid As New FHGrid4Library.FHGrid4
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.CreateGrid(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 btnRetrieve_Click( ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnRetrieve.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 Object, ByVal e As System.EventArgs) Handles btnDestroyGrid.Click
pGrid = Nothing
End Sub
Private Sub frmFHGrid4_FormClosing( ByVal sender As System.Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles MyBase.FormClosing
pGrid = Nothing
End Sub
End Class
I've made a number of these and at times I've had to do various things to get them to run. Sometimes you need to go to...
Project >>> Properties >>>Application
and set the 'Start Up' object to your main form which in my case is frmFHGrid4. Also, on that screen I set the 'Application Type' to 'Console Application', even though it isn't a console application, but rather a 'Windows Forms Application'. The reason I do that is so I get a console window to display all my debug data.
Also, on the 'Compile' tab in the above described 'Properties' window at times I've had to turn 'Option Strict' Off. Then for 'Warning Configuration' I've turned these warnings off...
Implicit Conversion
Late binding; Call could fail at runtime
Implicit Type; Object Assumed
Everybody's Favorite Topic - Global Variables!
In every client program I've shown so far in this rather lengthy post of mine about grid custom controls and converting them to COM based controls, there has been one rather nasty thing in common - lots of global variables. Just in the last one, i.e., PBClient3_v4.bas we had these...
Global pSink1 As IGridEvents
Global pSink2 As IGridEvents
Global pGrid As IGrid
Global pConPtCon As IConnectionPointContainer
Global pConPt As IConnectionPoint
Global dwCookie1 As Dword
Global dwCookie2 As Dword
There are all kinds of opinions on this topic. Some of the real heavyweight software minds such as Bob Zale himself and Jose Roca have stated at various times in the Forums that globals have their place, just as any other programming construct. Some see no harm in using them anywhere, and others state they will use them nowhere. My position is pretty close to the latter, at least in terms of Windows Graphical User Interface Application Programs, and I'd like to take this opportunity to show you how you can rid your GUI programs of them - specifically COM object pointers returned by such PowerBASIC functions as NewCom(), AnyCom(), etc.
There are two related reasons you might want to do this. First, only beginners at BASIC or any other language are unknowledgeable enough to know of no other way to structure a program's data than through the use of globals for everything. Second, one of the principals of both procedural and object oriented programming is that data should be tightly associated with the algorithms that manipulate it. In other words, data shouldn't just be hanging out all over the place in a program where it is accessible to procedures which have no business messing with it. In OOP speak, data should be associated with the objects which manipulate that data. In Windows programs, the most noteworthy objects are windows. Therefore, what needs to happen is that data needs to be associated with windows.
In terms of the Windows operating system itself, all of the foundational ideas of Object Oriented Programming were in place at the time Windows was developed. C++ was not in widespread use in the early to mid 1980s but C was and that language was used to write Windows. So the type of object oriented programming used to create an object oriented system was C based - not C++ based. Therefore, the C struct rather than the C++ class was used to organize objects, and object 'accessors' and 'mutators' took on a C functional look as opposed to C++ isms. Therefore, Microsoft provided various methods a programmer could use to 'attach' data to Windows objects. You have the Get/SetProp() functions, and also the ability to store user data within an instantiated class structure itself.
This later technique is the one I prefer to use. Its basis is as follows (experienced coders can just skim this). When a Window Class is registered with Windows, one of the fields of the WNDCLASSEX User Defined Type (struct in C terminology) is the .cbWndExtra bytes field. You can set this number to whatever you want as far as I know, but I personally have never used more than 50 to 60 bytes, and generally a lot less. The reason you don't need much is because typically one stores pointers in this area of memory. So the typical drill in an application program is to define some type with fields that are useful to some application, then allocate using dynamic memory (a memory allocation function that returns a pointer to memory) one of these types. One then stores whatever data in the type as is advantageous, then stores the pointer in the .cbWndExtra bytes of memory.
In this manner data is associated with an instance of a Window, and the amount of data can be as little or as much as the application needs. Further, one can then instantiate as many instances of such a program or as many instances of such a class in a single program as one needs, and all data will be independent of all other data. This is a powerful idea.
I'm usually good for some C or C++ code, so here follows a C++ program showing this technique in use with our now grid COM object. I developed the program below using the open source MinGW compiler suite and Code::Blocks for an IDE. I'll discuss the issues involved first with C++ clients, then with several PowerBASIC clients. The reason I'm starting with a C++ client first is that there are some tricky issues involved with PowerBASIC, and I though showing a C++ client first would help. If you are at all interested in C++ but don't do it, but might want to follow along with my C++ example, you can download the Code::Blocks IDE and MinGW compiler suite from here...
http://www.codeblocks.org/
The file you want is this...
codeblocks-10.05mingw-setup.exe
After installing that, start up Code::Blocks and click on the main screen's 'Create A New Project' icon. Then from the list of available project types choose 'Win32 GUI Project'. Then another dialog will come up where you should choose to create a 'Frame Based' project. You will then be asked for a name for the project, and I choose...
CppClient1_v4
And this is the location I choose. I had to create a couple folders...
C:\Documents and Settings\freddie\My Documents\Code\CodeBlocks\cppClient1_v4
The full path to the project file name was...
C:\Documents and Settings\freddie\My Documents\Code\CodeBlocks\cppClient1_v4\cppClient1_v4.cbp
Code::Blocks uses *.cbp for its project filenames. Another screen you'll see specifies whether or not you want to produce both a Debug and Release configuration. I always uncheck the Debug configuration because I seldom use them. After that Code::Blocks will create for you a default Win32 application that will create a blank window. It'll be basic Win32 Sdk style Api code. You can click the little gear at top to compile it and the little green icon arrow to run it. We won't be using that, but you ought to give it a try to see if everything is working. In the project explorer/manager at left you should see details of your project listed, and you should see you have a file named main.cpp. You can delete that code and paste the following code into main.cpp...
#define UNICODE //Main.cpp
#define _UNICODE
#include <windows.h>
#include <tchar.h>
#include <ocidl.h>
#include <objbase.h>
#include "WinTypes.h"
#include "Strings.h"
#define IDC_BUTTON1 2000 //Control ID For Blue' Button
#define IDC_KILL_CTL1 2005 //Control ID For Kill COM Ctrl1
extern "C" const CLSID CLSID_FHGrid ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70}};
extern "C" const IID IID_IFHGrid ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x71}};
extern "C" const IID IID_IFHGrid_Events ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x72}};
extern "C" const IID IID_IUnknown ={0x00000000,0x0000,0x0000,{0xC0,0x00,0x00,0x00,0x00,0x00,0x00,0x46}};
extern "C" const IID IID_IConnectionPointContainer ={0xB196B284,0xBAB4,0x101A,{0xB6,0x9C,0x00,0xAA,0x00,0x34,0x1D,0x07}};
interface IGrid : IUnknown
{
virtual HRESULT __stdcall CreateGrid (int, BSTR,int,int,int,int,int,int,int,BSTR,int,int )=0;
virtual HRESULT __stdcall SetRowCount (int, int )=0;
virtual HRESULT __stdcall SetData (int, int, BSTR )=0;
virtual HRESULT __stdcall GetData (int, int, BSTR* )=0;
virtual HRESULT __stdcall FlushData ( )=0;
virtual HRESULT __stdcall Refresh ( )=0;
virtual HRESULT __stdcall GetCtrlId (int* )=0;
virtual HRESULT __stdcall GethGrid (int* )=0;
};
interface IGridEvents : IUnknown //Out Going Interface From Grid
{
virtual HRESULT __stdcall Grid_OnKeyPress (int KeyCode, int KeyData, int CellRow, int GridRow, int Col)=0;
virtual HRESULT __stdcall Grid_OnKeyDown (int KeyCode, int KeyData, int CellRow, int GridRow, int Col)=0;
virtual HRESULT __stdcall Grid_OnLButtonDown (int CellRow, int GridRow, int Col )=0;
virtual HRESULT __stdcall Grid_OnLButtonDblClk (int CellRow, int GridRow, int Col )=0;
virtual HRESULT __stdcall Grid_OnPaste (int CellRow, int GridRow, int Col )=0;
virtual HRESULT __stdcall Grid_OnVButtonClick (int iCellRow, int iGridRow )=0;
};
class CSink : public IGridEvents //CSink
{
public:
CSink();
~CSink();
HRESULT __stdcall QueryInterface (REFIID iid, void** ppv );
ULONG __stdcall AddRef ( );
ULONG __stdcall Release ( );
HRESULT __stdcall Grid_OnKeyPress (int KeyCode, int KeyData, int CellRow, int GridRow, int Col);
HRESULT __stdcall Grid_OnKeyDown (int KeyCode, int KeyData, int CellRow, int GridRow, int Col);
HRESULT __stdcall Grid_OnLButtonDown (int CellRow, int GridRow, int Col );
HRESULT __stdcall Grid_OnLButtonDblClk (int CellRow, int GridRow, int Col );
HRESULT __stdcall Grid_OnPaste (int CellRow, int GridRow, int Col );
HRESULT __stdcall Grid_OnVButtonClick (int iCellRow, int iGridRow );
private:
long m_cRef;
};
CSink::CSink() : m_cRef(0)
{
//Constructor
}
CSink::~CSink()
{
//Destructor
}
HRESULT CSink::QueryInterface(REFIID riid, void** ppv)
{
if(riid == IID_IUnknown)
*ppv = (IUnknown*)this;
else if(riid == IID_IFHGrid_Events)
*ppv = (IGridEvents*)this;
else
{
*ppv = NULL;
return E_NOINTERFACE;
}
AddRef();
return S_OK;
}
ULONG CSink::AddRef()
{
return ++m_cRef;
}
ULONG CSink::Release()
{
if(--m_cRef != 0)
return m_cRef;
else
delete this;
return 0;
}
HRESULT CSink::Grid_OnKeyPress(int KeyCode, int KeyData, int CellRow, int GridRow, int Col)
{
return S_OK;
}
HRESULT CSink::Grid_OnKeyDown(int KeyCode, int KeyData, int CellRow, int GridRow, int Col)
{
return S_OK;
}
HRESULT CSink::Grid_OnLButtonDown(int iCellRow, int iGridRow, int iCol)
{
return S_OK;
}
HRESULT CSink::Grid_OnLButtonDblClk(int iCellRow, int iGridRow, int iCol )
{
return S_OK;
}
HRESULT CSink::Grid_OnPaste(int iCellRow, int iGridRow, int iCol )
{
return S_OK;
}
HRESULT CSink::Grid_OnVButtonClick(int iCellRow, int iGridRow)
{
return S_OK;
}
long fnWndProc_OnCreate(lpWndEventArgs Wea) //Offset What's Stored There
{ //=======================================
IConnectionPointContainer* pConnectionPointContainer=NULL; //0 - 3 pGrid
IConnectionPoint* pConnectionPoint=NULL; //4 - 7 pConnectionPointContainer
BSTR strSetup,strFontName,strCoordinate; //8 - 11 pConnectionPoint
DWORD dwCookie=NULL; //12 - 15 dwCookie
CSink* pSink=NULL;
IGrid* pGrid=NULL;
String s1,s2,s3;
HWND hButton;
Wea->hIns=((LPCREATESTRUCT)Wea->lParam)->hInstance; //CoInitialize() is called by PowerBASIC's startup code.
CoInitialize(NULL); //CoCreateInstance() is about the closest analog to PB's
CoCreateInstance(CLSID_FHGrid,NULL,CLSCTX_INPROC_SERVER,IID_IFHGrid,(void**)&pGrid); //NewCom() function. However, NewCom() returns an interface
SetWindowLong(Wea->hWnd,0,(long)pGrid); //pointer; CoCreateInstance() returns the interface pointer
strFontName=SysAllocString(L"Times New Roman"); //as an [out, retval] parameter of the call itself. The '&'
strSetup= //business is like PB's Varptr() keyword. We're passing 'in'
SysAllocString(L"120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"); //the address so the function can return something to us through it.
pGrid->CreateGrid((int)Wea->hWnd,strSetup,10,10,570,218,12,5,28,strFontName,18,FW_DONTCARE); //Note that we're doing the same thing here with SetWindowLong()
SysFreeString(strSetup); //that we'll be doing with our PowerBASIC counterparts, i.e.,
SysFreeString(strFontName); //PBClient4_v4.bas and PBClient9_v4.bas. That is, storing interface
pGrid->QueryInterface(IID_IConnectionPointContainer,(void**)&pConnectionPointContainer); //pointers in instance memory allocated in the Window Class struct.
SetWindowLong(Wea->hWnd,4,(long)pConnectionPointContainer); //The interesting difference between this and the PowerBASIC programs
pConnectionPointContainer->FindConnectionPoint(IID_IFHGrid_Events, &pConnectionPoint); //though, is that we're doing something PowerBASIC won't allow us,
SetWindowLong(Wea->hWnd,8,(long)pConnectionPoint); //and that is "Reference Counting Optimization". In other words,
pSink = new CSink; //we're saying, "Hey! The Rules Don't Apply To Us! We Know Better
pConnectionPoint->Advise((IUnknown*)pSink, &dwCookie); //Than The Rules! When We Were Awarded An Interface Pointer Through
SetWindowLong(Wea->hWnd,12,(long)dwCookie); //Either Our CoCreateInstance() Call Or Our Various QueryInterface()
for(unsigned int i=1; i<=10; i++) //Calls, Those Interface Pointers Were AddRef()'ed, And We're Leaving
{ //It Just Like That And Not Releasing Them! And Being As This Is
s1=i; //C++ And C++ Does No One Any Favors, Those Reference Counts Aren't
for(unsigned int j=1; j<=5; j++) //Going To Get Changed Or Reduced Nohow! So There's No Need To
{ //Add Artificial AddRef() Or Release() Calls!
s2=j;
s3=s1+_T(',')+s2;
strCoordinate=SysAllocString(s3.lpStr());
pGrid->SetData(i,j,strCoordinate);
SysFreeString(strCoordinate);
}
}
pGrid->Refresh();
hButton=CreateWindowEx(0,_T("button"),_T("Retrieve Data"),WS_CHILD|WS_VISIBLE,150,240,100,30,Wea->hWnd,(HMENU)IDC_BUTTON1,Wea->hIns,0);
hButton=CreateWindowEx(0,_T("button"),_T("Release Grid"),WS_CHILD|WS_VISIBLE,350,240,100,30,Wea->hWnd,(HMENU)IDC_KILL_CTL1,Wea->hIns,0);
return 0;
}
void DestroyGrid(lpWndEventArgs Wea) //In C Or C++ this is as simple as it gets. Whatever the reference count was set to
{ //in fnWndProc_OnCreate(), that is what it will be when this procedure executes. There
IConnectionPointContainer* pConnectionPointContainer=NULL; //is no garbage collection or automatic reference counting going on here. The only
IConnectionPoint* pConnectionPoint=NULL; //way a reference count decremeents is when you call Release() and the only way it
DWORD dwCookie=NULL; //increments (other than through QueryInterface() calls) is when you explicitely call
IGrid* pGrid=NULL; //AddRef().
pConnectionPoint=(IConnectionPoint*)GetWindowLong(Wea->hWnd,8); //Call Unadvise() On Sink And Release() IConnectionPoint*
dwCookie=(DWORD)GetWindowLong(Wea->hWnd,12);
if(pConnectionPoint)
{
pConnectionPoint->Unadvise(dwCookie);
pConnectionPoint->Release();
SetWindowLong(Wea->hWnd,8,0);
}
pConnectionPointContainer=(IConnectionPointContainer*)GetWindowLong(Wea->hWnd,4); //Release IConnectionPointContainer*
if(pConnectionPointContainer)
{
pConnectionPointContainer->Release();
SetWindowLong(Wea->hWnd,4,0);
}
pGrid=(IGrid*)GetWindowLong(Wea->hWnd,0); //Release() IGrid*
if(pGrid)
{
pGrid->Release();
SetWindowLong(Wea->hWnd,0,0);
}
}
long fnWndProc_OnCommand(lpWndEventArgs Wea)
{
switch(LOWORD(Wea->wParam))
{
case IDC_BUTTON1:
{
IGrid* pGrid=(IGrid*)GetWindowLong(Wea->hWnd,0);
HRESULT hr=pGrid->FlushData();
if(SUCCEEDED(hr))
{
BSTR strCell=SysAllocString(L"");
hr=pGrid->GetData(3,2,&strCell);
if(SUCCEEDED(hr))
{
MessageBox(Wea->hWnd,strCell,_T("Cell (3,2)"),MB_OK);
SysFreeString(strCell);
}
}
break;
}
case IDC_KILL_CTL1:
{
DestroyGrid(Wea);
EnableWindow(GetDlgItem(Wea->hWnd,IDC_BUTTON1),FALSE);
EnableWindow(GetDlgItem(Wea->hWnd,IDC_KILL_CTL1),FALSE);
InvalidateRect(Wea->hWnd,NULL,TRUE);
break;
}
}
return 0;
}
long fnWndProc_OnDestroy(lpWndEventArgs Wea)
{
DestroyGrid(Wea);
CoFreeUnusedLibraries();
CoUninitialize();
PostQuitMessage(0);
return 0;
}
LRESULT CALLBACK fnWndProc(HWND hwnd, unsigned int msg, WPARAM wParam, LPARAM lParam)
{
WndEventArgs Wea;
for(unsigned int i=0; i<dim(EventHandler); i++)
{
if(EventHandler[i].Code==msg)
{
Wea.hWnd=hwnd, Wea.lParam=lParam, Wea.wParam=wParam;
return (*EventHandler[i].fnPtr)(&Wea);
}
}
return (DefWindowProc(hwnd,msg,wParam,lParam));
}
int __stdcall WinMain(HINSTANCE hIns, HINSTANCE hPrevIns, LPSTR lpszArgument, int iShow)
{
TCHAR szClassName[]=_T("AxGridCtrl");
WNDCLASSEX wc;
MSG messages;
HWND hWnd;
wc.lpszClassName=szClassName; wc.lpfnWndProc=fnWndProc;
wc.cbSize=sizeof (WNDCLASSEX); wc.style=CS_DBLCLKS;
wc.hIcon=LoadIcon(NULL,IDI_APPLICATION); wc.hInstance=hIns;
wc.hIconSm=LoadIcon(NULL, IDI_APPLICATION); wc.hCursor=LoadCursor(NULL,IDC_ARROW);
wc.hbrBackground=(HBRUSH)COLOR_BTNSHADOW; wc.cbWndExtra=16;
wc.lpszMenuName=NULL; wc.cbClsExtra=0;
RegisterClassEx(&wc);
hWnd=CreateWindowEx(0,szClassName,szClassName,WS_OVERLAPPEDWINDOW,200,200,600,320,HWND_DESKTOP,0,hIns,0);
ShowWindow(hWnd,iShow);
while(GetMessage(&messages,NULL,0,0))
{
TranslateMessage(&messages);
DispatchMessage(&messages);
}
return messages.wParam;
}
/*
#define UNICODE //Main.cpp
#define _UNICODE
#include <windows.h>
#include <tchar.h>
#include <fcntl.h>
#include <io.h>
#include <stdio.h>
#include <ocidl.h>
#include <objbase.h>
#include "WinTypes.h"
#include "Strings.h"
#define IDC_BUTTON1 2000 //Control ID For Blue' Button
#define IDC_KILL_CTL1 2005 //Control ID For Kill COM Ctrl1
extern "C" const CLSID CLSID_FHGrid ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70}};
extern "C" const IID IID_IFHGrid ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x71}};
extern "C" const IID IID_IFHGrid_Events ={0x20000000,0x0000,0x0000,{0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x72}};
extern "C" const IID IID_IUnknown ={0x00000000,0x0000,0x0000,{0xC0,0x00,0x00,0x00,0x00,0x00,0x00,0x46}};
extern "C" const IID IID_IConnectionPointContainer ={0xB196B284,0xBAB4,0x101A,{0xB6,0x9C,0x00,0xAA,0x00,0x34,0x1D,0x07}};
interface IGrid : IUnknown
{
virtual HRESULT __stdcall CreateGrid (int, BSTR,int,int,int,int,int,int,int,BSTR,int,int )=0;
virtual HRESULT __stdcall SetRowCount (int, int )=0;
virtual HRESULT __stdcall SetData (int, int, BSTR )=0;
virtual HRESULT __stdcall GetData (int, int, BSTR* )=0;
virtual HRESULT __stdcall FlushData ( )=0;
virtual HRESULT __stdcall Refresh ( )=0;
virtual HRESULT __stdcall GetCtrlId (int* )=0;
virtual HRESULT __stdcall GethGrid (int* )=0;
};
interface IGridEvents : IUnknown //Out Going Interface From Grid
{
virtual HRESULT __stdcall Grid_OnKeyPress (int KeyCode, int KeyData, int CellRow, int GridRow, int Col)=0;
virtual HRESULT __stdcall Grid_OnKeyDown (int KeyCode, int KeyData, int CellRow, int GridRow, int Col)=0;
virtual HRESULT __stdcall Grid_OnLButtonDown (int CellRow, int GridRow, int Col )=0;
virtual HRESULT __stdcall Grid_OnLButtonDblClk (int CellRow, int GridRow, int Col )=0;
virtual HRESULT __stdcall Grid_OnPaste (int CellRow, int GridRow, int Col )=0;
virtual HRESULT __stdcall Grid_OnVButtonClick (int iCellRow, int iGridRow )=0;
};
class CSink : public IGridEvents //CSink
{
public:
CSink();
~CSink();
HRESULT __stdcall QueryInterface (REFIID iid, void** ppv );
ULONG __stdcall AddRef ( );
ULONG __stdcall Release ( );
HRESULT __stdcall Grid_OnKeyPress (int KeyCode, int KeyData, int CellRow, int GridRow, int Col);
HRESULT __stdcall Grid_OnKeyDown (int KeyCode, int KeyData, int CellRow, int GridRow, int Col);
HRESULT __stdcall Grid_OnLButtonDown (int CellRow, int GridRow, int Col );
HRESULT __stdcall Grid_OnLButtonDblClk (int CellRow, int GridRow, int Col );
HRESULT __stdcall Grid_OnPaste (int CellRow, int GridRow, int Col );
HRESULT __stdcall Grid_OnVButtonClick (int iCellRow, int iGridRow );
private:
long m_cRef;
};
CSink::CSink() : m_cRef(0)
{
_tprintf(_T(" Entering CSink Constructor!\n"));
_tprintf(_T(" this = %u\n"),this);
_tprintf(_T(" Leaving CSink Constructor!\n\n"));
}
CSink::~CSink()
{
_tprintf(_T(" Entering CSink Destructor!\n"));
_tprintf(_T(" this = %u\n"),this);
_tprintf(_T(" Leaving CSink Destructor!\n"));
}
HRESULT CSink::QueryInterface(REFIID riid, void** ppv)
{
_tprintf(_T(" Entering CSink::QueryInterface() -- this = %u\n"),this);
if(riid == IID_IUnknown)
{
*ppv = (IUnknown*)this;
}
else if(riid == IID_IFHGrid_Events)
{
_tprintf(_T(" Client: CSink::QueryInterface() for IID_IFHGrid_Events -- this = %u\n"), (IGridEvents*)this);
*ppv = (IGridEvents*)this;
_tprintf(_T(" *ppv = %u\n"), *ppv);
}
else
{
*ppv = NULL;
return E_NOINTERFACE;
}
AddRef();
_tprintf(_T(" Leaving CSink::QueryInterface(): this = %u\n"),this);
return S_OK;
}
ULONG CSink::AddRef()
{
return ++m_cRef;
}
ULONG CSink::Release()
{
_tprintf(_T(" Entering CSink::Release()\n"));
_tprintf(_T(" this = %u\n"),this);
if(--m_cRef != 0)
{
_tprintf(_T(" m_cRef != 0 : m_cRef=%u\n"),m_cRef);
return m_cRef;
}
else
{
_tprintf(_T(" m_cRef == 0 And Will Now Delete CSink!\n"));
delete this;
}
_tprintf(_T(" Leaving CSink::Release()\n"));
return 0;
}
HRESULT CSink::Grid_OnKeyPress(int KeyCode, int KeyData, int CellRow, int GridRow, int Col)
{
_tprintf(_T("\nEntering CSink::Grid_OnKeyPress()\n"));
_tprintf(_T(" CSink::Grid_OnKeyPress is %u\n"), KeyCode);
_tprintf(_T("Leaving CSink::Grid_OnKeyPress()\n"));
return S_OK;
}
HRESULT CSink::Grid_OnKeyDown(int KeyCode, int KeyData, int CellRow, int GridRow, int Col)
{
_tprintf(_T("\nEntering CSink::Grid_OnKeyDown()\n"));
_tprintf(_T(" CSink::Grid_OnKeyDown is %u\n"), KeyCode);
_tprintf(_T("Leaving CSink::Grid_OnKeyDown()\n"));
return S_OK;
}
HRESULT CSink::Grid_OnLButtonDown(int iCellRow, int iGridRow, int iCol)
{
_tprintf(_T("\nEntering CSink::Grid_OnLButtonDown()\n"));
_tprintf(_T(" CSink::Grid_OnLButtonDown: iRow = %u\tiCol = %u\n"),iCellRow,iCol);
_tprintf(_T("Leaving CSink::Grid_OnLButtonDown()\n"));
return S_OK;
}
HRESULT CSink::Grid_OnLButtonDblClk(int iCellRow, int iGridRow, int iCol )
{
_tprintf(_T("\nEntering CSink::Grid_OnLButtonDblClk()\n"));
_tprintf(_T(" CSink::Grid_OnLButtonDblClk: iRow = %u\tiCol = %u\n"),iCellRow,iCol);
_tprintf(_T("Leaving CSink::Grid_OnLButtonDblClk()\n"));
return S_OK;
}
HRESULT CSink::Grid_OnPaste(int iCellRow, int iGridRow, int iCol )
{
_tprintf(_T("\nEntering CSink::Grid_OnPaste()\n"));
_tprintf(_T(" CSink::Grid_OnPaste: iRow=%u\tiCol=%u\n"), iCellRow,iCol);
_tprintf(_T("Leaving CSink::Grid_OnPaste()\n"));
return S_OK;
}
HRESULT CSink::Grid_OnVButtonClick(int iCellRow, int iGridRow)
{
_tprintf(_T("\nEntering CSink::Grid_OnVButtonClick()\n"));
_tprintf(_T(" CSink::Grid_OnVButtonClick: iCellRow=%u\tiGridRow=%u\n"),iCellRow,iGridRow);
_tprintf(_T("Leaving CSink::Grid_OnVButtonClick()\n"));
return S_OK;
}
long fnWndProc_OnCreate(lpWndEventArgs Wea)
{
IConnectionPointContainer* pConnectionPointContainer=NULL; //Offset What's Stored There
IConnectionPoint* pConnectionPoint=NULL; //=======================================
BSTR strSetup,strFontName,strCoordinate; //0 - 3 pGrid
DWORD dwCookie=NULL; //4 - 7 pConnectionPointContainer
CSink* mySink=NULL; //8 - 11 pConnectionPoint
IGrid* pGrid=NULL; //12 - 15 dwCookie
String s1,s2,s3;
HWND hButton;
HRESULT hr;
int hCrt;
FILE* hf;
Wea->hIns=((LPCREATESTRUCT)Wea->lParam)->hInstance;
AllocConsole();
hCrt=_open_osfhandle((long)GetStdHandle(STD_OUTPUT_HANDLE),_O_TEXT);
hf = _fdopen( hCrt, "w" );
_iob[1]=*hf;
_tprintf(_T("Entering fnWndProc_OnCreate()\n"));
_tprintf(_T(" Wea->hWnd = %u\n"),Wea->hWnd);
hr=CoInitialize(NULL);
if(SUCCEEDED(hr))
{
_tprintf(_T(" CoInitialize() Succeeded!\n"));
hr=CoCreateInstance(CLSID_FHGrid,NULL,CLSCTX_INPROC_SERVER,IID_IFHGrid,(void**)&pGrid);
if(SUCCEEDED(hr))
{
_tprintf(_T("\n CoCreateInstance() Succeeded! -- pGrid = %u\n"),pGrid);
SetWindowLong(Wea->hWnd,0,(long)pGrid);
strFontName=SysAllocString(L"Times New Roman");
strSetup=SysAllocString(L"120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^");
hr=pGrid->CreateGrid((int)Wea->hWnd,strSetup,10,10,570,218,12,5,28,strFontName,18,FW_DONTCARE);
SysFreeString(strSetup);
SysFreeString(strFontName);
if(SUCCEEDED(hr))
{
_tprintf(_T(" pGrid->Create() Succeeded!\n"));
hr=pGrid->QueryInterface(IID_IConnectionPointContainer,(void**)&pConnectionPointContainer);
if(SUCCEEDED(hr))
{
_tprintf(_T(" \nGot pConnectionPointContainer = %u\n\n"),(unsigned int)pConnectionPointContainer);
SetWindowLong(Wea->hWnd,4,(long)pConnectionPointContainer);
hr = pConnectionPointContainer->FindConnectionPoint(IID_IFHGrid_Events, &pConnectionPoint);
if(SUCCEEDED(hr))
{
_tprintf(_T(" Got pConnectionPoint = %u\n"),pConnectionPoint);
SetWindowLong(Wea->hWnd,8,(long)pConnectionPoint);
mySink = new CSink;
_tprintf(_T(" mySink = %u\n\n"),mySink);
hr=pConnectionPoint->Advise((IUnknown*)mySink, &dwCookie);
if(SUCCEEDED(hr))
{
_tprintf(_T(" pConnectionPoint->Advise() Succeeded!\n"));
SetWindowLong(Wea->hWnd,12,(long)dwCookie);
for(unsigned int i=1; i<=10; i++)
{
s1=i;
for(unsigned int j=1; j<=5; j++)
{
s2=j;
s3=s1+_T(',')+s2;
strCoordinate=SysAllocString(s3.lpStr());
_tprintf(_T(" "));
s3.Print(true);
pGrid->SetData(i,j,strCoordinate);
SysFreeString(strCoordinate);
}
}
_tprintf(_T("\n"));
pGrid->Refresh();
}
else
puts(" pConnectionPoint->Advise() Failed!");
}
else
_tprintf(_T(" Failed To Get pConnectionPoint!\n"));
}
else
_tprintf(_T(" Failed To Get IConnectionPointContainer*\n"));
_tprintf(_T("\n"));
}
else
_tprintf(_T(" pGrid->Create() Failed!\n"));
}
else
_tprintf(_T(" CoCreateInstance() Failed!\n"));
}
else
_tprintf(_T(" CoInitialize() Failed!\n"));
hButton=CreateWindowEx(0,_T("button"),_T("Retrieve Data"),WS_CHILD|WS_VISIBLE,150,240,100,30,Wea->hWnd,(HMENU)IDC_BUTTON1,Wea->hIns,0);
hButton=CreateWindowEx(0,_T("button"),_T("Release Grid"),WS_CHILD|WS_VISIBLE,350,240,100,30,Wea->hWnd,(HMENU)IDC_KILL_CTL1,Wea->hIns,0);
_tprintf(_T("Leaving fnWndProc_OnCreate()\n\n"));
return 0;
}
void DestroyGrid(lpWndEventArgs Wea)
{
IConnectionPointContainer* pConnectionPointContainer=NULL;
IConnectionPoint* pConnectionPoint=NULL;
DWORD dwCookie=NULL;
IGrid* pGrid=NULL;
_tprintf(_T("\n Entering DestroyGrid()\n"));
pConnectionPoint=(IConnectionPoint*)GetWindowLong(Wea->hWnd,8); //Call Unadvise() On Sink And Release() IConnectionPoint*
dwCookie=(DWORD)GetWindowLong(Wea->hWnd,12);
if(pConnectionPoint)
{
pConnectionPoint->Unadvise(dwCookie);
pConnectionPoint->Release();
SetWindowLong(Wea->hWnd,8,0);
}
else
_tprintf(_T(" IConnectionPoint* Apparently Released!\n"));
pConnectionPointContainer=(IConnectionPointContainer*)GetWindowLong(Wea->hWnd,4); //Release IConnectionPointContainer*
if(pConnectionPointContainer)
{
pConnectionPointContainer->Release();
SetWindowLong(Wea->hWnd,4,0);
}
else
_tprintf(_T(" IConnectionPointContainer* Apparently Released!\n"));
pGrid=(IGrid*)GetWindowLong(Wea->hWnd,0); //Release() IGrid*
if(pGrid)
{
pGrid->Release();
SetWindowLong(Wea->hWnd,0,0);
}
else
_tprintf(_T(" IGrid* Apparently Released!\n"));
_tprintf(_T(" Leaving DestroyGrid()\n"));
}
long fnWndProc_OnCommand(lpWndEventArgs Wea)
{
_tprintf(_T("\nEntering fnWndProc_OnCommand()\n"));
switch(LOWORD(Wea->wParam))
{
case IDC_BUTTON1:
{
IGrid* pGrid=(IGrid*)GetWindowLong(Wea->hWnd,0);
HRESULT hr=pGrid->FlushData();
if(SUCCEEDED(hr))
{
BSTR strCell=SysAllocString(L"");
hr=pGrid->GetData(3,2,&strCell);
if(SUCCEEDED(hr))
{
_tprintf(_T(" pGrid->GetData() Succeeded!\n"));
_tprintf(_T(" strCell = %s\n"),strCell);
SysFreeString(strCell);
}
else
_tprintf(_T(" pGrid->GetData() Failed!\n"));
}
break;
}
case IDC_KILL_CTL1:
{
DestroyGrid(Wea);
EnableWindow(GetDlgItem(Wea->hWnd,IDC_BUTTON1),FALSE);
EnableWindow(GetDlgItem(Wea->hWnd,IDC_KILL_CTL1),FALSE);
InvalidateRect(Wea->hWnd,NULL,TRUE);
break;
}
}
_tprintf(_T("Leaving fnWndProc_OnCommand()\n\n"));
return 0;
}
long fnWndProc_OnDestroy(lpWndEventArgs Wea)
{
_tprintf(_T("\nEntering fnWndProc_OnDestroy()\n"));
DestroyGrid(Wea);
CoFreeUnusedLibraries();
CoUninitialize();
_tprintf(_T("Leaving fnWndProc_OnDestroy()\n\n"));
MessageBox(Wea->hWnd,_T("Have Just Released Object! You Can Copy The Output From The Console If You Want Though!"),_T("Will Close App!"),MB_OK);
PostQuitMessage(0);
return 0;
}
LRESULT CALLBACK fnWndProc(HWND hwnd, unsigned int msg, WPARAM wParam, LPARAM lParam)
{
WndEventArgs Wea;
for(unsigned int i=0; i<dim(EventHandler); i++)
{
if(EventHandler[i].Code==msg)
{
Wea.hWnd=hwnd, Wea.lParam=lParam, Wea.wParam=wParam;
return (*EventHandler[i].fnPtr)(&Wea);
}
}
return (DefWindowProc(hwnd,msg,wParam,lParam));
}
int __stdcall WinMain(HINSTANCE hIns, HINSTANCE hPrevIns, LPSTR lpszArgument, int iShow)
{
TCHAR szClassName[]=_T("AxGridCtrl");
WNDCLASSEX wc;
MSG messages;
HWND hWnd;
wc.lpszClassName=szClassName; wc.lpfnWndProc=fnWndProc;
wc.cbSize=sizeof (WNDCLASSEX); wc.style=CS_DBLCLKS;
wc.hIcon=LoadIcon(NULL,IDI_APPLICATION); wc.hInstance=hIns;
wc.hIconSm=LoadIcon(NULL, IDI_APPLICATION); wc.hCursor=LoadCursor(NULL,IDC_ARROW);
wc.hbrBackground=(HBRUSH)COLOR_BTNSHADOW; wc.cbWndExtra=16;
wc.lpszMenuName=NULL; wc.cbClsExtra=0;
RegisterClassEx(&wc);
hWnd=CreateWindowEx(0,szClassName,szClassName,WS_OVERLAPPEDWINDOW,200,200,600,320,HWND_DESKTOP,0,hIns,0);
ShowWindow(hWnd,iShow);
while(GetMessage(&messages,NULL,0,0))
{
TranslateMessage(&messages);
DispatchMessage(&messages);
}
return messages.wParam;
}
*/
There are actually two programs above – a non-debug version first and following that a debug version that creates a console in addition to the grid and outputs a lot of diagnostic information. In C or C++ you can remark out whole sections of code with these symbols...
/*
commented out!!!
*/
After the WinMain() of the first program above you'll see those symbols remarking out the 2nd whole program.
To run that program you'll need three additional files which I'll attach and they are Strings.h, Strings.cpp, and WinTypes.h. I'll also post the code. To insert those files into the project so you can run it, go up to your project explorer/manager and right click on the project name and choose the selection 'Add Files...'. They should then show up in your project manager and you should be able to examine them. Something else I always do is go into Build Options >>> Compiler Settings and check the 'Strip Symbols From Executable (minimizes size)' and 'Optimize For Small Code' options. The next thing you'll have to do to be able to compile this is add a few import libraries for the linker. Go to the main menu and select...
Main Menu >> Project >>> Build Options...
In the dialog that comes up choose the 'Linker Settings' tab. Then click the 'Add' button under 'Link Libraries'. Then you'll be presented with a dialog box where you'll have to navigate to wherever you installed Code::Blocks and under its installation directory you'll find paths such as this...
C:\Program Files\CodeBlocks\MinGW\Lib
You'll have to go through this process twice so as to select...
Libole32.a
Liboleauto32.a
When asked whether or not to keep these as a 'Relative Path' choose yes. At that point you should be able to compile and run the code. Before you do that though go to the View Main Menu and check the 'Logs' option so you'll see the compiler output window. Then try to compile. Here are the three files you'll need in addition to the code I just posted...
//WinTypes.h
#ifndef WINTYPES_H
#define WINTYPES_H
#define dim(x) (sizeof(x) / sizeof(x[0]))
typedef struct WindowsEventArguments
{
HWND hWnd;
WPARAM wParam;
LPARAM lParam;
HINSTANCE hIns;
}WndEventArgs, *lpWndEventArgs;
long fnWndProc_OnCreate (lpWndEventArgs Wea);
long fnWndProc_OnCommand (lpWndEventArgs Wea);
long fnWndProc_OnDestroy (lpWndEventArgs Wea);
struct EVENTHANDLER
{
unsigned int Code;
long (*fnPtr)(lpWndEventArgs);
};
const EVENTHANDLER EventHandler[]=
{
{WM_CREATE, fnWndProc_OnCreate},
{WM_COMMAND, fnWndProc_OnCommand},
{WM_DESTROY, fnWndProc_OnDestroy}
};
#endif
//Strings.h
#if !defined(STRINGS_H)
#define STRINGS_H
#define EXPANSION_FACTOR 2
#define MINIMUM_ALLOCATION 16
class String
{
public:
friend String operator+(TCHAR*, String&);
String(); //Uninitialized Constructor
String(const TCHAR); //Constructor Initializes With A TCHAR.
String(const TCHAR*); //Constructor Initializes String With TCHAR*
String(const String&); //Constructor Initializes String With Another String (Copy Constructor)
String(const int, bool); //Constructor Creates String With User Specified Capacity and optionally nulls out
String(const int, const TCHAR); //Constructor initializes String with int # of TCHARs
String(int); //Constructor initializes String with int converted to String
String(unsigned int); //Constructor initializes String with unsigned int converted to String
String(double); //Constructor initializes String with double converted to String
String& operator=(const TCHAR); //Assign A TCHAR To A String
String& operator=(const TCHAR*); //Assign A Null Terminated TCHARacter Array To A String
String& operator=(const String&); //Assigns Another String To this One
String& operator=(int iNum); //Assigns an unsigned int to a String
String& operator=(unsigned int iNum); //Assigns an unsigned int to a String
String& operator=(double dblNum); //Assign a double to a String
String operator+(const TCHAR); //For adding TCHAR to String
String operator+(const TCHAR*); //Adds a TCHAR* to this
String operator+(String&); //Adds another String to this
String& operator+=(const TCHAR ch); //Add TCHAR to this
String& operator+=(const String&); //Adds a String to this and assigns it to left of equal sign
String& operator+=(const TCHAR*); //Adds a TCHAR*to this and assigns it to left of equal sign
bool operator==(String&); //Compares Strings For Case Sensitive Equality
bool operator==(const TCHAR*); //Compares String Against TCHAR* For Case Sensitive Equality
String& Make(const TCHAR ch, int iCount); //Returns reference to this with iCount ch TCHARs in it
String Left(int); //Returns String of iNum Left Most TTCHARs of this
String Right(int); //Returns String of iNum Right Most TTCHARs of this
String Mid(int, int); //Returns String consisting of number of TTCHARs from some offset
String Replace(TCHAR*, TCHAR*); //Returns String with 1st TCHAR* parameter replaced with 2nd TCHAR* parameter
String Remove(TCHAR*); //Returns A String With All The TCHARs In A TCHAR* Removed (Individual TCHAR removal)
String Remove(const TCHAR*, bool); //Returns a String with 1st parameter removed. 2nd is bool for case sensitivity.
int InStr(const TCHAR*, bool); //Returns one based offset of a particular TTCHAR pStr in a String
int InStr(const String&, bool); //Returns one based offset of where a particular String is in another String
int ParseCount(const TCHAR); //Returns count of Strings delimited by a TTCHAR passed as a parameter
void Parse(String*, TCHAR); //Returns array of Strings in first parameter as delimited by 2nd TTCHAR delimiter
void SetTCHAR(int, TCHAR); //Sets TCHAR at zero based offset in this
void LTrim(); //Returns String with leading spaces/tabs removed
void RTrim(); //Returns String with spaces/tabs removed from end
void Trim(); //Returns String with both leading and trailing whitespace removed
int iVal(); //Returns integral value of String
int Len(); //Returns Length Of String Controlled By this
int Capacity(); //Returns Maximum Permissable TCHARacter Count (One Less Than Allocation).
TCHAR* lpStr(); //Returns TCHAR* To String
void Print(bool); //Outputs String To Console With Or Without CrLf.
~String(); //String Destructor
private:
TCHAR* lpBuffer;
int iLen;
int iCapacity;
};
String operator+(TCHAR* lhs, String& rhs);
#endif //#if !defined(STRINGS_H)
//Strings.cpp
#define UNICODE
#define _UNICODE
#include <stdlib.h>
#include <cstdio>
#include <tchar.h>
#include <math.h>
#include <string.h>
#include "Strings.h"
String operator+(TCHAR* lhs, String& rhs) //global function
{
String sr=lhs;
sr=sr+rhs;
return sr;
}
String::String()
{
lpBuffer=new TCHAR[MINIMUM_ALLOCATION];
lpBuffer[0]=_T('\0');
this->iCapacity=MINIMUM_ALLOCATION-1;
this->iLen=0;
}
String::String(const TCHAR ch) //Constructor: Initializes with TCHAR
{
this->iLen=1;
int iNewSize=MINIMUM_ALLOCATION;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
this->lpBuffer[0]=ch, this->lpBuffer[1]=_T('\0');
}
String::String(const TCHAR* pStr) //Constructor: Initializes with TCHAR*
{
this->iLen=_tcslen(pStr);
int iNewSize=(this->iLen/16+1)*16;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
_tcscpy(lpBuffer,pStr);
}
String::String(const String& s) //Constructor Initializes With Another String, i.e., Copy Constructor
{
int iNewSize=(s.iLen/16+1)*16;
this->iLen=s.iLen;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
_tcscpy(this->lpBuffer,s.lpBuffer);
}
String::String(const int iSize, bool blnFillNulls) //Constructor Creates String With Custom Sized
{ //Buffer (rounded up to paragraph boundary)
int iNewSize=(iSize/16+1)*16;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
this->iLen=0;
this->lpBuffer[0]=_T('\0');
if(blnFillNulls)
{
for(int i=0; i<this->iCapacity; i++)
this->lpBuffer[i]=0;
}
}
String::String(int iCount, const TCHAR ch)
{
int iNewSize=(iCount/16+1)*16;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
for(int i=0; i<iCount; i++)
this->lpBuffer[i]=ch;
this->lpBuffer[iCount]=_T('\0');
this->iLen=iCount;
}
String::String(int iNum)
{
this->lpBuffer=new TCHAR[16];
this->iCapacity=15;
this->iLen=_stprintf(this->lpBuffer,_T("%d"),iNum);
}
String::String(unsigned int iNum)
{
this->lpBuffer=new TCHAR[16];
this->iCapacity=15;
this->iLen=_stprintf(this->lpBuffer,_T("%u"),iNum);
}
String::String(double dblNum)
{
this->lpBuffer=new TCHAR[32];
this->iCapacity=31;
this->iLen=_stprintf(this->lpBuffer,_T("%10.14f"),dblNum);
}
String& String::operator=(double dblNum)
{
if(this->iCapacity<32)
{
delete [] this->lpBuffer;
lpBuffer=new TCHAR[32];
this->iCapacity=31;
}
this->iLen=_stprintf(this->lpBuffer,_T("%10.14f"),dblNum);
return *this;
}
void String::SetTCHAR(int iOffset, TCHAR ch) //zero based!
{
if(iOffset<this->iCapacity)
{
this->lpBuffer[iOffset]=ch;
if(ch==_T('\0'))
{
if(iOffset<this->iLen || this->iLen==0)
this->iLen=iOffset;
}
}
}
String& String::operator=(const TCHAR ch)
{
this->lpBuffer[0]=ch, this->lpBuffer[1]=_T('\0');
this->iLen=1;
return *this;
}
String& String::operator=(const TCHAR* pStr)
{
int iNewLen=_tcslen(pStr);
if(iNewLen>this->iCapacity)
{
delete [] this->lpBuffer;
int iNewSize=(iNewLen*EXPANSION_FACTOR/16+1)*16;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
}
_tcscpy(this->lpBuffer,pStr);
this->iLen=iNewLen;
return *this;
}
String& String::operator=(const String& strAnother)
{
if(this==&strAnother)
return *this;
if(strAnother.iLen>this->iCapacity)
{
delete [] this->lpBuffer;
int iNewSize=(strAnother.iLen*EXPANSION_FACTOR/16+1)*16;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
}
_tcscpy(this->lpBuffer,strAnother.lpBuffer);
this->iLen=strAnother.iLen;
return *this;
}
String& String::operator=(int iNum)
{
if(this->iCapacity>=15)
this->iLen=_stprintf(this->lpBuffer,_T("%d"),iNum);
else
{
delete [] this->lpBuffer;
this->lpBuffer=new TCHAR[16];
this->iCapacity=15;
this->iLen=_stprintf(this->lpBuffer,_T("%d"),iNum);
}
return *this;
}
String& String::operator=(unsigned int iNum)
{
if(this->iCapacity>=15)
this->iLen=_stprintf(this->lpBuffer,_T("%d"),iNum);
else
{
delete [] this->lpBuffer;
this->lpBuffer=new TCHAR[16];
this->iCapacity=15;
this->iLen=_stprintf(this->lpBuffer,_T("%d"),iNum);
}
return *this;
}
String String::operator+(const TCHAR ch)
{
int iNewLen=this->iLen+1;
String s(iNewLen,false);
_tcscpy(s.lpBuffer,this->lpBuffer);
s.lpBuffer[iNewLen-1]=ch;
s.lpBuffer[iNewLen]=_T('\0');
s.iLen=iNewLen;
return s;
}
String String::operator+(const TCHAR* pStr)
{
int iNewLen=_tcslen(pStr)+this->iLen;
String s(iNewLen,false);
_tcscpy(s.lpBuffer,this->lpBuffer);
_tcscat(s.lpBuffer,pStr);
s.iLen=iNewLen;
return s;
}
String String::operator+(String& strRef)
{
int iNewLen=strRef.iLen+this->iLen;
String s(iNewLen,false);
_tcscpy(s.lpBuffer,this->lpBuffer);
_tcscat(s.lpBuffer,strRef.lpBuffer);
s.iLen=iNewLen;
return s;
}
String& String::operator+=(const TCHAR ch)
{
int iTot=this->iLen+1;
if(iTot>this->iCapacity)
{
int iNewSize=(iTot*EXPANSION_FACTOR/16+1)*16;
TCHAR* pNew=new TCHAR[iNewSize];
_tcscpy(pNew,this->lpBuffer);
delete [] this->lpBuffer;
this->lpBuffer=pNew;
this->lpBuffer[iTot-1]=ch;
this->lpBuffer[iTot]=_T('\0');
this->iCapacity=iNewSize-1;
this->iLen=iTot;
}
else
{
this->lpBuffer[iTot-1]=ch;
this->lpBuffer[iTot]=_T('\0');
this->iLen=iTot;
}
return *this;
}
String& String::operator+=(const TCHAR* pStr)
{
int iStrlen=_tcslen(pStr);
int iTot=iStrlen+this->iLen;
if(iTot>this->iCapacity)
{
int iNewSize=(iTot*EXPANSION_FACTOR/16+1)*16;
TCHAR* pNew=new TCHAR[iNewSize];
_tcscpy(pNew,this->lpBuffer);
delete [] this->lpBuffer;
this->lpBuffer=pNew;
_tcscat(pNew,pStr);
this->iCapacity=iNewSize-1;
this->iLen=iTot;
}
else
{
_tcscat(this->lpBuffer,pStr);
this->iLen=iTot;
}
return *this;
}
String& String::operator+=(const String& strRef)
{
int iTot=strRef.iLen+this->iLen;
if(iTot>this->iCapacity)
{
int iNewSize=(iTot*EXPANSION_FACTOR/16+1)*16;
TCHAR* pNew=new TCHAR[iNewSize];
_tcscpy(pNew,this->lpBuffer);
delete [] this->lpBuffer;
this->lpBuffer=pNew;
_tcscat(pNew,strRef.lpBuffer);
this->iCapacity=iNewSize-1;
this->iLen=iTot;
}
else
{
_tcscat(this->lpBuffer,strRef.lpBuffer);
this->iLen=iTot;
}
return *this;
}
bool String::operator==(String& strRef)
{
if(_tcscmp(this->lpStr(),strRef.lpStr())==0)
return true;
else
return false;
}
bool String::operator==(const TCHAR* pStr)
{
if(_tcscmp(this->lpStr(),pStr)==0)
return true;
else
return false;
}
String& String::Make(const TCHAR ch, int iCount) //Creates (Makes) a String with iCount TCHARs
{
if(iCount>this->iCapacity)
{
delete [] lpBuffer;
int iNewSize=(iCount*EXPANSION_FACTOR/16+1)*16;
this->lpBuffer=new TCHAR[iNewSize];
this->iCapacity=iNewSize-1;
}
for(int i=0; i<iCount; i++)
this->lpBuffer[i]=ch;
this->lpBuffer[iCount]=0;
this->iLen=iCount;
return *this;
}
String String::Left(int iNum) // strncpy = _tcsncpy
{
if(iNum<this->iLen)
{
int iNewSize=(iNum*EXPANSION_FACTOR/16+1)*16;
String sr(iNewSize,false);
_tcsncpy(sr.lpBuffer,this->lpBuffer,iNum);
sr.lpBuffer[iNum]=0;
sr.iLen=iNum;
return sr;
}
else
{
String sr=*this;
return sr;
}
}
String String::Right(int iNum) //Returns Right$(strMain,iNum)
{
if(iNum<this->iLen)
{
int iNewSize=(iNum*EXPANSION_FACTOR/16+1)*16;
String sr(iNewSize,false);
_tcsncpy(sr.lpBuffer,this->lpBuffer+this->iLen-iNum,iNum);
sr.lpBuffer[iNum]=_T('\0');
sr.iLen=iNum;
return sr;
}
else
{
String sr=*this;
sr.iLen=this->iLen;
return sr;
}
}
String String::Mid(int iStart, int iCount)
{
if(iStart<1)
{
String sr;
return sr;
}
if(iCount+iStart>this->iLen)
iCount=this->iLen-iStart+1;
String sr(iCount,false);
_tcsncpy(sr.lpBuffer,this->lpBuffer+iStart-1,iCount);
sr.lpBuffer[iCount]=_T('\0');
sr.iLen=iCount;
return sr;
}
String String::Replace(TCHAR* pMatch, TCHAR* pNew) //strncmp = _tcsncmp
{
int i,iLenMatch,iLenNew,iCountMatches,iExtra,iExtraLengthNeeded,iAllocation,iCtr;
iLenMatch=_tcslen(pMatch);
iCountMatches=0, iAllocation=0, iCtr=0;
iLenNew=_tcslen(pNew);
if(iLenNew==0)
{
String sr=this->Remove(pMatch,true); //return
return sr;
}
else
{
iExtra=iLenNew-iLenMatch;
for(i=0; i<this->iLen; i++)
{
if(_tcsncmp(lpBuffer+i,pMatch,iLenMatch)==0)
iCountMatches++; //Count how many match strings
}
iExtraLengthNeeded=iCountMatches*iExtra;
iAllocation=this->iLen+iExtraLengthNeeded;
String sr(iAllocation,false);
for(i=0; i<this->iLen; i++)
{
if(_tcsncmp(this->lpBuffer+i,pMatch,iLenMatch)==0)
{
_tcscpy(sr.lpBuffer+iCtr,pNew);
iCtr+=iLenNew;
i+=iLenMatch-1;
}
else
{
sr.lpBuffer[iCtr]=this->lpBuffer[i];
iCtr++;
}
sr.lpBuffer[iCtr]=_T('\0');
}
sr.iLen=iCtr;
return sr;
}
}
String String::Remove(TCHAR* pStr)
{
unsigned int i,j,iStrLen,iParamLen;
TCHAR *pThis, *pThat, *p;
bool blnFoundBadTCHAR;
iStrLen=this->iLen; //The length of this
String sr((int)iStrLen,false); //Create new String big enough to contain original String (this)
iParamLen=_tcslen(pStr); //Get length of parameter (pStr) which contains TCHARs to be removed
pThis=this->lpBuffer;
p=sr.lpStr();
for(i=0; i<iStrLen; i++)
{
pThat=pStr;
blnFoundBadTCHAR=false;
for(j=0; j<iParamLen; j++)
{
if(*pThis==*pThat)
{
blnFoundBadTCHAR=true;
break;
}
pThat++;
}
if(!blnFoundBadTCHAR)
{
*p=*pThis;
p++;
*p=_T('\0');
}
pThis++;
}
sr.iLen=_tcslen(sr.lpStr());
return sr;
}
String String::Remove(const TCHAR* pMatch, bool blnCaseSensitive)
{
int i,iCountMatches=0,iCtr=0;
int iLenMatch=_tcslen(pMatch);
for(i=0; i<this->iLen; i++)
{
if(blnCaseSensitive)
{
if(_tcsncmp(lpBuffer+i,pMatch,iLenMatch)==0) //_tcsncmp
iCountMatches++;
}
else
{
if(_tcsnicmp(lpBuffer+i,pMatch,iLenMatch)==0) //__tcsnicmp
iCountMatches++;
}
}
int iAllocation=this->iLen-(iCountMatches*iLenMatch);
String sr(iAllocation,false);
for(i=0; i<this->iLen; i++)
{
if(blnCaseSensitive)
{
if(_tcsncmp(this->lpBuffer+i,pMatch,iLenMatch)==0)
i+=iLenMatch-1;
else
{
sr.lpBuffer[iCtr]=this->lpBuffer[i];
iCtr++;
}
sr.lpBuffer[iCtr]=_T('\0');
}
else
{
if(_tcsnicmp(this->lpBuffer+i,pMatch,iLenMatch)==0)
i+=iLenMatch-1;
else
{
sr.lpBuffer[iCtr]=this->lpBuffer[i];
iCtr++;
}
sr.lpBuffer[iCtr]=_T('\0');
}
}
sr.iLen=iCtr;
return sr;
}
int String::ParseCount(const TCHAR c) //returns one more than # of
{ //delimiters so it accurately
int iCtr=0; //reflects # of strings delimited
TCHAR* p; //by delimiter.
p=this->lpBuffer;
while(*p)
{
if(*p==c)
iCtr++;
p++;
}
return ++iCtr;
}
void String::Parse(String* pStr, TCHAR delimiter)
{
unsigned int i=0;
TCHAR* pBuffer=0;
TCHAR* c;
TCHAR* p;
pBuffer=new TCHAR[this->iLen+1];
if(pBuffer)
{
pBuffer[0]=0, p=pBuffer;
c=this->lpBuffer;
while(*c)
{
if(*c==delimiter)
{
pStr[i]=pBuffer, p=pBuffer;
i++, pBuffer[0]=0;
}
else
{
*p=*c, p++;
*p=0;
}
c++;
}
pStr[i]=pBuffer;
delete [] pBuffer;
}
}
int String::InStr(const TCHAR* pStr, bool blnCaseSensitive)
{
int i,iParamLen,iRange;
if(*pStr==0)
return 0;
iParamLen=_tcslen(pStr);
iRange=this->iLen-iParamLen;
if(iRange>=0)
{
for(i=0;i<=iRange;i++)
{
if(blnCaseSensitive)
{
if(_tcsncmp(lpBuffer+i,pStr,iParamLen)==0) //_tcsncmp
return i+1;
}
else
{
if(_tcsnicmp(lpBuffer+i,pStr,iParamLen)==0) //__tcsnicmp
return i+1;
}
}
}
return 0;
}
int String::InStr(const String& s, bool blnCaseSensitive)
{
int i,iParamLen,iRange;
if(s.iLen==0)
return 0;
iParamLen=s.iLen;
iRange=this->iLen-iParamLen;
if(iRange>=0)
{
for(i=0; i<=iRange; i++)
{
if(blnCaseSensitive)
{
if(_tcsncmp(this->lpBuffer+i,s.lpBuffer,iParamLen)==0) //_tcsncmp
return i+1;
}
else
{
if(_tcsnicmp(this->lpBuffer+i,s.lpBuffer,iParamLen)==0) //__tcsnicmp
return i+1;
}
}
}
return 0;
}
void String::LTrim()
{
int iCt=0;
for(int i=0; i<this->iLen; i++)
{
if(this->lpBuffer[i]==32 || this->lpBuffer[i]==9)
iCt++;
else
break;
}
if(iCt)
{
for(int i=iCt; i<=this->iLen; i++)
this->lpBuffer[i-iCt]=this->lpBuffer[i];
}
this->iLen=this->iLen-iCt;
}
void String::RTrim()
{
int iCt=0;
for(int i=this->iLen-1; i>0; i--)
{
if(this->lpBuffer[i]==9||this->lpBuffer[i]==10||this->lpBuffer[i]==13||this->lpBuffer[i]==32)
iCt++;
else
break;
}
this->lpBuffer[this->iLen-iCt]=0;
this->iLen=this->iLen-iCt;
}
void String::Trim()
{
this->LTrim();
this->RTrim();
}
int String::iVal()
{
return _ttoi(this->lpBuffer); //_ttoi
}
int String::Len(void)
{
return this->iLen;
}
int String::Capacity(void)
{
return this->iCapacity;
}
TCHAR* String::lpStr()
{
return lpBuffer;
}
void String::Print(bool blnCrLf)
{
_tprintf(_T("%s"),lpBuffer);
if(blnCrLf)
_tprintf(_T("\n"));
}
String::~String() //String Destructor
{
delete [] lpBuffer;
lpBuffer=0;
}
Pretty lot of code, isn't it? Well, you can't really do much without a string class in C++, so I had to post all that. Hopefully you've been able to run the program a few times to get a feel for it. Anyway, getting back to our topic of eliminating global variables, look up in fnWndProc_OnCreate(). You'll see these two lines...
CoCreateInstance(CLSID_FHGrid,NULL,CLSCTX_INPROC_SERVER,IID_IFHGrid,(void**)&pGrid);
SetWindowLong(Wea->hWnd,0,(long)pGrid);
What CoCreateInstance() does is about like NewCom() in PowerBASIC – it creates an object from a Clsid. If successful the call will return the grid interface pointer in pGrid. Right after CoCreateInstance() is a call to SetWindowLong() which stores the pGrid pointer at offset zero in the instantiated window's structure. To elaborate on this a bit, when my main window class was registered down in WinMain() I specified the class name for the program's main window as "AxGridTrial"...
TCHAR szClassName[]=_T("AxGridCtrl");
Then I specified 16 extra .cbWndExtra bytes in the class structure that will apply to each instance of a window created...
wc.cbWndExtra=16;
This little blurb from fnWndProc_OnCreate() shows what my intentions were in terms of storing grid related data in the instance data...
//Offset What's Stored There
//=======================================
//0 - 3 pGrid
//4 - 7 pConnectionPointContainer
//8 - 11 pConnectionPoint
//12 - 15 dwCookie
So there you can see we stored our pGrid pointer at offset zero. There were formerly four global pieces of data that we are now associating with the window, so all four of these variables are local to fnWndProc_OnCreate(), and these variables will go out of scope and be destroyed when this procedure terminates. Its critical to realize though that although these variables have been destroyed, their former contents live on and are still valid in their storage in the .cbWndExtra bytes. In terms of reference counting, QueryInterface calls were made on the COM object "FHGrid4.Grid" and we racked up a total tally of three AddRef()s within the grid dll. Here is some output from a program run. Note specifically that about three quarters of the way down, after fnWndProc_OnCreate() terminates, our reference count on pGrid is 3 – one AddRef() for pGrid, one AddRef() for pConnectionPointContainer, and one for pConnectionPoint...
@pGrid.m_cRef = 3 << After
continued....
....continued
Here's the program run...
Entering fnWndProc_OnCreate()
Wea->hWnd = 1245844
CoInitialize() Succeeded!
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 10885828
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pGrid = 2455792
Varptr(@pGrid.lpIGridVtbl) = 2455792
Varptr(@pGrid.lpICPCVtbl) = 2455796
Varptr(@pGrid.lpICPVtbl) = 2455800
@pGrid.pISink = 2455928
@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 = 2455792
Leaving IGrid_QueryInterface()
@ppv = 2455792 << After QueryInterface() Call
Entering Initialize() -- Initialize()
GetModuleHandle() = 10813440
Leaving Initialize()
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 = 2455792
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
CoCreateInstance() Succeeded! -- pGrid = 2455792
Entering IGrid_CreateGrid()
this = 2455792
hContainer = 1245844
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 = 262782
pGridData = 2384784
Leaving IGrid_CreateGrid()
pGrid->Create() Succeeded!
Entering IGrid_QueryInterface()
Trying To Get IConnectionPointContainer
this = 2455792
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 1 << Before
@pGrid.m_cRef = 2 << After
Leaving IConnectionPointContainer_AddRef()
this = 2455796
Leaving IGrid_QueryInterface()
Got pConnectionPointContainer = 2455796
Entering IConnectionPointContainer_FindConnectionPoint()
this = 2455796
@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 = 2455800
Leaving IConnectionPointContainer_FindConnectionPoint()
Got pConnectionPoint = 2455800
Entering CSink Constructor!
this = 9775240
Leaving CSink Constructor!
mySink = 9775240
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
this = 2455800
pGrid = 2455792
@pGrid.hControl = 262782
pUnkSink = 9775240
Vtbl = 4233152
@Vtbl[0] = 4203056
Entering CSink::QueryInterface() -- this = 9775240
Client: CSink::QueryInterface() for IID_IFHGrid_Events -- this = 9775240
*ppv = 9775240
Leaving CSink::QueryInterface(): this = 9775240
dwPtr = 9775240
Call Dword Succeeded!
0 2455928 0 Found Open Slot!
Will Be Able To Store Connection Point!
Leaving IConnectionPoint_Advise() And Still In One Piece!
pConnectionPoint->Advise() Succeeded!
1,1
1,2
1,3
1,4
1,5
2,1
...
...
9,4
9,5
10,1
10,2
10,3
10,4
10,5
Leaving fnWndProc_OnCreate()
Entering CSink::Grid_OnLButtonDown()
CSink::Grid_OnLButtonDown: iRow = 2 iCol = 2
Leaving CSink::Grid_OnLButtonDown()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 46
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 46
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 46
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 46
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 46
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 70
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyPress()
CSink::Grid_OnKeyPress is 102
Leaving CSink::Grid_OnKeyPress()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 82
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyPress()
CSink::Grid_OnKeyPress is 114
Leaving CSink::Grid_OnKeyPress()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 69
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyPress()
CSink::Grid_OnKeyPress is 101
Leaving CSink::Grid_OnKeyPress()
Entering CSink::Grid_OnKeyDown()
CSink::Grid_OnKeyDown is 68
Leaving CSink::Grid_OnKeyDown()
Entering CSink::Grid_OnKeyPress()
CSink::Grid_OnKeyPress is 100
Leaving CSink::Grid_OnKeyPress()
Entering fnWndProc_OnCommand()
pGrid->GetData() Succeeded!
strCell = fred
Leaving fnWndProc_OnCommand()
Entering fnWndProc_OnCommand()
Entering DestroyGrid()
Entering IConnectionPoint_Unadvise()
this = 2455800
dwCookie = 0
@pGrid.hWndCtrl = 262782
dwPtr = 9775240
Entering CSink::Release()
this = 9775240
m_cRef == 0 And Will Now Delete CSink!
Entering CSink Destructor!
this = 9775240
Leaving CSink Destructor!
Leaving CSink::Release()
IGrid_Events::Release() Succeeded!
Release() Returned 0
Leaving IConnectionPoint_Unadvise()
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
0 2455928 0
1 2455932 0
2 2455936 0
3 2455940 0
@pGrid.m_cRef = 0 << After
Grid Was Deleted!
Leaving IGrid_Release()
Leaving DestroyGrid()
Leaving fnWndProc_OnCommand()
Entering fnWndProc_OnDestroy()
Entering DestroyGrid()
IConnectionPoint* Apparently Released!
IConnectionPointContainer* Apparently Released!
IGrid* Apparently Released!
Leaving DestroyGrid()
Entering DllCanUnloadNow()
I'm Outta Here! (dll is unloaded)
Leaving DllCanUnloadNow()
Leaving fnWndProc_OnDestroy()
There is a 'RULE' you should be aware of. Its a RULE whose basis is in object lifetime management, which is an important concept. The RULE states that when an interface pointer is copied by a client, the client is responsible for calling AddRef() on it. For example, CoCreateInstance, if successful, will hand out to you an interface pointer upon which QueryInterface() within the COM server called AddRef(). So at that point you have a reference count of 1. If in your client code you have these variable declarations...
IUnknown* pUnk1; //this is C code!
IUnknown* pUnk2;
...and your CoCreateInstance() call initialized pUnk1, then at the point you do this...
pUnk2 = pUnk1;
...then, by the rules of QueryInterface you need to call pUnk2->AddRef() right after the point of assignment or copy. The reference count then becomes 2 on the object instance, and its methods can be called from either pointer. Upon finishing with the pointers you then have two Release() calls to make. Don't forger we're talking C or C++ here - not PowerBASIC. We'll get to that in a bit.
The reason for all this is to correctly manage object lifetime. If you mess it up your app is pretty much shot. You'll either have memory leaks, crashes, or both. Crashes will come from the server prematurely unloading the dll while you are still holding on to interface pointers you think are still valid. Memory leaks will come from the object failing to call clean up code and release itself because its still holding on to reference counts which you never released.
Having said all that, let me ask you a question. Do you think my assignment of my pGrid interface pointer to offset zero within the .cbWndExtra bytes of the class instance structure constitutes an interface copy operation requiring an AddRef() call on it per the QueryInterface() rules I stipulated? If you answered 'Yes' you are correct. However, if you examine the code you see I didn't do it. Also, if an AddRef() should have been called on pGrid then logic dictates it should also apply to pConnectionPointContainer and pConnectionPoint too!
My excuse for not doing it is another interesting COM concept known as (you guessed it, there's a name for it!) 'Reference Counting Optimization'. The idea is as follows. If the logic of an application is so simple that there is no danger of a reference counting foul up, then just ignore calling AddRef() followed by immediate Release() calls in the name of simplicity and perhaps sanity. For example, in our relatively simple client we are just storing three interface pointers in a WM_CREATE handler and releasing those same three in a WM_DESTROY handler. There isn't any conditional branch logic anywhere where interface pointers are being passed as parameters to other functions, and those functions passing them to still other functions, which depending on conditions at the time, may or may not do various things with them affecting object lifetimes. So its a matter of making a judgment in the app you are developing whether or not you can safely get away with it without wrecking havoc upon yourself. In the code I posted I got away with it just fine. When you get to PowerBASIC though, you are likely going to have to at least understand this.
Lets now turn to a PowerBASIC example of the same thing. But lets look first at some problems we are going to run into right away in attempting to do what I did in the C++ program above. Remember, we started with these two lines...
CoCreateInstance(CLSID_FHGrid,NULL,CLSCTX_INPROC_SERVER,IID_IFHGrid,(void**)&pGrid);
SetWindowLong(Wea->hWnd,0,(long)pGrid);
In PowerBASIC, we would like to code it this way...
Let pGrid = NewCom "FHGrid4.Grid"
Call SetWindowLong(Wea.hWnd, 0, pGrid)
Let me gently break the first piece of bad news. That won't compile. PowerBASIC won't allow you to put an interface pointer in the 3rd parameter of a SetWindowLong() Api function call which function call requires a Long instead. This can actually be solved fairly easily; PowewBASIC has the Objptr() function to retrieve an address out of an interface pointer, so you can try this instead...
Let pGrid = NewCom "FHGrid4.Grid"
Call SetWindowLong(Wea.hWnd, 0, Objptr(pGrid))
That will work as far as that goes, but it doesn't end your problems by any means. Getting it in is only half the battle. You also have to be able to get it out where you need it and be able to use it there. The getting it out part isn't too bad but the making use of it part is a real killer. Recall in our C++ app above part of the user interface involved a button that when clicked would retrieve the contents out of the grid in Row 3, Column 2? Here is the pertinent code for that...
IGrid* pGrid=(IGrid*)GetWindowLong(Wea->hWnd,0); //Retrieve interface pointer from instance memory
pGrid->FlushData(); //If data is in edit control, flush it back to grid memory
BSTR strCell=SysAllocString(L""); //Do a C++ thing to allocate a BSTR
pGrid->GetData(3,2,&strCell); //Do interface member call to retrieve Cell (3,2)
MessageBox(Wea->hWnd,strCell,_T("Cell (3,2)"),MB_OK); //Show it in a message box
SysFreeString(strCell); //Release the BSTR memory
To implement that in PowerBASIC, which has such nice String functions, we would like to do something like this...
Local pGrid As IGrid
Local strData As WString
pGrid=GetWindowLong(Wea.hWnd,0)
pGrid.FlushData()
strData=pGrid.GetData(3,2)
MsgBox("Cell 3,2 Contains " & strData)
Boy, how I hate to break the bad news! As logical as that all looks, it won't even close to work! PowerBASIC will absolutely and unconditionally refuse to allow you to initialize the pGrid object variable that way. It provides the NewCom(), AnyCom(), and GetCom() functions for that, and GetWindowLong() isn't in that list. You can holler and scream all you like. If it makes you feel better you can even output the address held in the interface pointer up in WM_CREATE before you stored it using SetWindowLong(), and you can check it out against what is coming out of GetWindowLong() in the WM_COMMAND button click handler to be sure they are the same, and they will be. But you won't be able to assign it back into another local IGrid object variable using the equal sign. And don't even think about using GetCom, because that won't work with in process servers.
If you are thinking this is bad - you are right. However, if you are suspecting there might still be a way to do it, you are right again (or I wouldn't be writing this, would I?).
I'm sure at some point in the past you've used the PowerBASIC VariantVt function. If you check out the PowerBASIC Help file on VariantVt it lists all the types of variables which can be held in a Variant, and several of them are objects of one form or another. In particular though, it can hold a generic interface pointer in the form of IUnknown. One should hopefully be able to assume then that if PowerBASIC allows one to store an interface pointer in a variant, it will allow one to reassign it to an object variable when one takes it out. Indeed, this is the case. So, before I present a full working program showing this, let me describe how it works.
First, one must allocate a local variant into which the interface pointer is going to be stored. However, a simple local variant won't work, because we are now going to have to store the address of the variant in the window's .cbWndExtra bytes instance data, and a locally allocated variable will also go out of scope too after our WM_CREATE handler exits. So what we are going to have to do is allocate a variant dynamically, or on the heap or free store, using a memory allocation function, and we are going to have to store the interface pointer in that using pointer notation, i.e.,
Local pVnt As Variant Ptr 'Allocate a local Variant Pointer
Local pGrid As IGrid 'Allocate a local interface pointer
pVnt=GlobalAlloc(%GPTR,16) 'The size of a Variant is 16 bytes - allocate a pointer to a 16 byte chunk
If pVnt Then '
Let pGrid = NewCom "FHGrid4.Grid" 'Create the COM Object, and get your 1st pointer to it.
@pVnt=pGrid 'Use pointer notation to assign it to your Variant memory block
Call SetWindowLong(Wea.hWnd,0,pVnt) 'Store the Variant ptr in .cbWndExtra bytes. The memory block the pointer is pointing
Else 'to contains the pGrid interface pointer
MsgBox("Memory Allocation Failure!!!")
Function=-1 : Exit Function
End If
There's more! Recall above I discussed the issue with reference counting vis a vis copying interface pointers? Well, PowerBASIC will recognize the assignment above as an interface pointer assignment, and will do an AddRef() on pGrid when it is assigned to the Variant memory block. This AddRef() will increment the reference count on pGrid to 2, so that when the local pGrid goes out of scope at the termination of the WM_CREATE handler, the reference count will fall only to 1 - not zero, and the object stored in the .cbWndExtra bytes will stay alive - for further use elsewhere, which is the point of all this.
Of course, the above code (or its equivalent) will be in our WM_CREATE handler. In every procedure where we need to retrieve the pGrid interface pointer we are going to have to use GetWindowLong() to retrieve first the Variant Ptr, then retrieve the interface pointer out of the variant memory block. PowerBASIC will recognize all this copying and retrieval of interface pointers for what it is, and automatically handle all reference counting. Here then is PBClient4_v4.bas which demonstrates this functionality. Right afterwards I'll provide the console output from the running of this program with debug output statements included. The source code has a duplicated version remarked out underneath it which has the debug output statements included, so you can run it and produce your own output if you want to demonstrate to yourself that its working as I state)...
continued....
'PBClient4_v4.bas 'Uses Jose's Declares 'This program takes a crack at eliminating global object variables
#Compile Exe "PBClient4_v4.exe" 'like we've been using up to this point in all these programs.
#Dim All 'Uses PBWin 10.02 'This is one area that is actually easier to do in C or C++ than in
%UNICODE = 1 'PowerBASIC. The source of the difficulty in PowerBASIC is its
#If %Def(%UNICODE) 'automatic reference counting. For example, so far we've had a
Macro ZStr = WStringz 'globally allocated IGrid interface pointer. If we allocate it
Macro BStr = WString 'locally, it will go out of scope and be released by PowerBASIC
%SIZEOF_CHAR = 2 'after our WM_CREATE message handler exits. Typically, to make a
#Else 'variable persist across invocations of functions, one stores the
Macro ZStr = Asciiz 'variable's value in Windows memory allocated through .cbWndExtra
Macro BStr = String 'bytes, or Windows Properties, i.e., Get/SetProp(). We can do this
%SIZEOF_CHAR = 1 'here, but we need to first call pGrid.AddRef() on the interface...
#EndIf
$CLSID_FHGrid = GUID$("{20000000-0000-0000-0000-000000000070}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000071}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000072}")
%IDC_RETRIEVE = 1500
%IDC_UNLOAD_GRID = 1505 '...pointer so that the object itself doesn't get destroyed if the
#Include "Windows.inc" 'pGrid.Release() call PowerBASIC makes at the exit of the WM_CREATE
#Include "ObjBase.inc" 'handler causes its reference count to fall to zero. Sad to say,
'that isn't the only problem; there's another one that's even worse.
Type WndEventArgs 'To begin with, even if you use Objptr() to assign the address of
wParam As Long 'the object variable within storage in the .cbWndExtra bytes, you
lParam As Long 'won't be able to easily retrieve that value and assign it back into
hWnd As Dword 'another locally allocated object variable. PowerBASIC simply
hInst As Dword 'won't allow it. You'll get a compile error. One way around this
End Type 'is to store the object variable, i.e., interface pointer, in a
'variant. There are two object types in the variant union; IDispatch
Declare Function FnPtr(wea As WndEventArgs) As Long 'and IUnknown. Of course, to do this it won't do any good to
'create a local variant, because it would go out of scope too. So
Type MessageHandler 'you need to do a memory allocation for 16 bytes, which is the size
wMessage As Long 'of a variant, and use pointer notation to store the interface
dwFnPtr As Dword 'pointer in the variant. Then you store the memory allocation in
End Type 'the Window Class Instance or Window Properties. The added benifit
Global MsgHdlr() As MessageHandler 'of this is that the PowerBASIC Compiler recognizes this operation
'as an interface copy, and by the RULES of COM and QueryInterface()
'it automatically does an AddRef() on the interface pointer so that
Interface IGrid $IID_IFHGrid : Inherit IAutomation 'when the locally defined one goes out of scope, the object won't
Method CreateGrid _ 'be destroyed/released as it would if its reference count fell to
( _ 'zero. But alas, you still have to deal with the hassle of allo-
Byval hParent As Long, _ 'cating the memory for the Variant, and releasing it when done. All
Byval strSetup As WString, _ 'in all, it isn't pretty.
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 iKeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
'Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
'Prnt "Got KeyDown From CGridEvents1!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
'Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow 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) & " And This Courtesy CGridEvents1!")
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long 'What's Stored Where
Local pConnectionPointContainer As IConnectionPointContainer
Local pConnectionPoint As IConnectionPoint 'Offset Item
Local pCreateStruct As CREATESTRUCT Ptr '=================================================================================
Local strSetup,strCoordinate As BStr '0 - 3 IGrid Ptr - pGrid
Local pSink As IGridEvents '4 - 7 IConnectionPoint Ptr - pConnectionPoint
Local pVnt As Variant Ptr '8 - 11 IConnectionPointContainer Ptr - pConnectionPointContainer
Local EventGuid As Guid '12 - 15 Connection Cookie - dwCookie
Local dwCookie As Dword
Local pGrid As IGrid 'According to the 'Rules' of QueryInterface(), the copying of an interface pointer
Local hCtl As Dword 'requires that an AddRef() call be done on it. Consider that when QueryInterface()
Register i As Long 'is called successfully and returns an interface pointer to the caller, an AddRef()
Register j As Long 'has already been done on it, and its the caller's responsibility to Release() it.
'In using C or C++ this must be done manually, but PowerBASIC handles these details
pCreateStruct=wea.lParam 'itself. One of several possible ways to store an interface pointer returned by
Wea.hInst=@pCreateStruct.hInstance 'PowerBASIC in a Window's internal storage, i.e., in .cbWndExtra bytes, or in Window
Let pGrid = NewCom "FHGrid4.Grid" 'Properties, is to allocate memory for a Variant, and store the interface pointer in
pVnt=GlobalAlloc(%GPTR, 16) 'the Variant. To see this being done, look exactly left << from here in the source
@pVnt=pGrid 'code. Variants can store IDispatch and generic object pointers as IUnknown.
Call SetWindowLong(Wea.hWnd,0,pVnt) 'However, the PowerBASIC compiler will recognize an expression such as @pVnt=pGrid
strSetup= _ 'as an interface pointer copy operation, and will do an AddRef() on it just as the
"120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^" 'RULES for QueryInterface dictate. Think about it for a moment. If all of the
pGrid.CreateGrid(Wea.hWnd,strSetup,10,10,570,222,25,5,20,"",18,%FW_DONTCARE) 'interface pointers are locally allocated such as in this program, PowerBASIC -
pConnectionPointContainer = pGrid 'whose goal is to relieve the coder of the tedium of reference counting, is going
pVnt=GlobalAlloc(%GPTR, 16) 'to have to automatically call a Release() on any local interface variables when
@pVnt=pConnectionPointContainer 'they go out of scope. So if one's goal is to preserve the life of an interface
Call SetWindowLong(Wea.hWnd,8,pVnt) 'variable by obtaining it and storing it in Window Properties or .cbWndExtra bytes,
EventGuid=$IID_IGridEvents 'then an AddRef() is going to have to be done on it when it is stored in the
Call pConnectionPointContainer.FindConnectionPoint _ 'variant pointer that is actually going to be stored. At that point the reference
( _ 'count on the object will be 2, and when the local object goes out of scope and a
Byval Varptr(EventGuid), _ 'Release() is called on it, it will decrease to 1, i.e., the one being stored.
Byval Varptr(pConnectionPoint) _ 'That may be all that is necessary to keep the object alive, and the COM Dll in
) 'memory. So as you can see (or will soon see), the elimination of global variables
pVnt=GlobalAlloc(%GPTR, 16) 'if they be object variables (interface pointers) tends to get a bit tricky in
@pVnt=pConnectionPoint : Call SetWindowLong(Wea.hWnd,4,pVnt) 'PowerBASIC. Likely one of the few things that's easier to do in C or C++. The
Let pSink = Class "CGridEvents" 'basic procedure is going to require you to dimension a local Variant Ptr, allocate
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie) '16 bytes to point the pointer at, then assign the interface pointer to the Variant
Call SetWindowLong(Wea.hWnd,12,dwCookie) 'memory. At that point you'll then be able to store the Variant Pointer wherever
For i=1 To 25 'and however you want, and the AddRef() PowerBASIC does on the interface copy will
For j=1 To 5 'keep the object alive when PowerBASIC calls Release() on the locally dimensioned
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")" 'interface pointer. Also, only through the use of this technique will it be possible
pGrid.SetData(i, j, strCoordinate) 'to re-assign the interface pointer held in the variant back into another object
Next j 'variable in another procedure. If you are laboring under the assumption that you
Next i 'can bypass all this hassle and just store an interface pointer in .cbWndExtra bytes
pGrid.Refresh() 'and in some other procedure copy it back into another object variable - well, I
hCtl=CreateWindow _ 'recommend you just try it once and see how far you get! Actually, there is a way
( _ 'to do it, but its tricky!
"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(Wea As WndEventArgs) 'If you've decided to use the Variant approach to eliminating
Local pConnectionPointContainer As IConnectionPointContainer 'globally allocated object variables from your PowerBASIC COM
Local pConnectionPoint As IConnectionPoint 'programs, then in any procedure where you wish to retrieve an
Local pVnt As Variant Ptr 'object variable you'll do as just left where you see the
Local dwCookie As Dword 'Variant Ptr being retrieved in this case from .cbWndExtra bytes
Local pGrid As IGrid 'and used in a normal fashion. Be aware though that PowerBASIC
dwCookie=GetWindowLong(Wea.hWnd,12) 'is doing an AddRef() on your object variable when it assigns
pVnt=GetWindowLong(Wea.hWnd,4) 'it back into a locally allocated object. The logic is somewhat
If pVnt Then 'tricky in this case just left because its the job of DestroyGrid()
pConnectionPoint=@pVnt 'to destroy the grid, and it looks like the three .Release() calls
Call pConnectionPoint.Unadvise(dwCookie) 'are doing just that. But what is actually happening is that the
Call pConnectionPoint.Release() 'reference count on FHGrid4.Grid will be 3 coming into this
Call SetWindowLong(Wea.hWnd,4,0) 'procedure from the allocation and storage of an IGrid Ptr, an
Call GlobalFree(pVnt) 'IConnectionPointContainer Ptr and a IConnectionPoint Ptr in
End If 'fnWndProc_OnCreate(). But when this procedure runs the reference
pVnt=GetWindowLong(Wea.hWnd,8) 'count will increment from 3 to 4 three times as PowerBASIC does
If pVnt Then 'its 'hidden' AddRef() when each pointer is retrieved from the
pConnectionPointContainer=@pVnt '.cbWndExtra bytes of the Window Class Instance. So when this
Call pConnectionPointContainer.Release() 'procedure finally exits, the reference count will still be 3 in
Call SetWindowLong(Wea.hWnd,8,0) 'spite of the 3 .Release() calls (they were counterbalanced by the
Call GlobalFree(pVnt) '3 hidden AddRefs). However, when the procedure exits PowerBASIC
End If 'will clean up the stack and call three more Releases on the 3
pVnt=GetWindowLong(Wea.hWnd,0) 'local interface pointers. That is what will drive the reference
If pVnt Then 'count on the object down to zero and force its destruction in
pGrid=@pVnt 'memory. So yes, it does what it looks like, but be aware of the
Call pGrid.Release() 'circuitous route it follows to do so. Also note that the three
Call SetWindowLong(Wea.hWnd,0,0) 'variant pointer memory allocations need to be cleaned up so as
Call GlobalFree(pVnt) 'to prevent a memory leak.
End If
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local pVnt As Variant Ptr
Local strData As BStr
Local pGrid As IGrid
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
pGrid.FlushData()
strData=pGrid.GetData(3,2)
MsgBox("Cell 3,2 Contains " & strData)
Case %IDC_UNLOAD_GRID
Call DestroyGrid(Wea)
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(Wea)
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=16
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
Function=msg.wParam
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Debug Version Of Above
''PBClient4_v4.bas
'#Compile Exe "PBClient4_v4.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-000000000070}")
'$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000071}")
'$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000072}")
'%IDC_RETRIEVE = 1500
'%IDC_UNLOAD_GRID = 1505
'#Include "Windows.inc"
'#Include "ObjBase.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
'
'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
'
'Interface IGrid $IID_IFHGrid : Inherit IAutomation
' 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 CGridEvents As Event
' Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
' Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
' End Method
' Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Prnt "Got KeyDown From CGridEvents1!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
' End Method
' Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
' End Method
' Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' ' Insert your code here
' End Method
' Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' ' Insert your code here
' End Method
' Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
' Prnt "You Clicked For Row #" & Str$(iGridRow) & " And This Courtesy CGridEvents1!"
' End Method
' End Interface
'End Class
'
'
'Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long 'What's Stored Where
' Local pConnectionPointContainer As IConnectionPointContainer
' Local pConnectionPoint As IConnectionPoint 'Offset Item
' Local pCreateStruct As CREATESTRUCT Ptr '=====================================================================
' Local strSetup,strCoordinate As BStr '0 - 3 IGrid Ptr - pGrid
' Local pSink As IGridEvents '4 - 7 IConnectionPoint Ptr - pConnectionPoint
' Local pVnt As Variant Ptr '8 - 11 IConnectionPointContainer Ptr - pConnectionPointContainer
' Local EventGuid As Guid '12 - 15 Connection Cookie - dwCookie
' Local dwCookie As Dword
' Local pGrid As IGrid
' Local hCtl As Dword
' Register i As Long
' Register j As Long
'
' Call AllocConsole()
' Prnt "Entering fnWndProc_OnCreate()"
' pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance
' Let pGrid = NewCom "FHGrid4.Grid"
' pVnt=GlobalAlloc(%GPTR, 16)
' Prnt " pVnt = " & Str$(pVnt)
' @pVnt=pGrid : Call SetWindowLong(Wea.hWnd,0,pVnt)
' strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
' pGrid.CreateGrid(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE)
' pConnectionPointContainer = pGrid
' pVnt=GlobalAlloc(%GPTR, 16)
' Prnt " pVnt = " & Str$(pVnt)
' @pVnt=pConnectionPointContainer : Call SetWindowLong(Wea.hWnd,8,pVnt)
' EventGuid=$IID_IGridEvents
' Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConnectionPoint))
' pVnt=GlobalAlloc(%GPTR, 16)
' Prnt " pVnt = " & Str$(pVnt)
' @pVnt=pConnectionPoint : Call SetWindowLong(Wea.hWnd,4,pVnt)
' Let pSink = Class "CGridEvents"
' Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
' Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
' Prnt " dwCookie = " & Str$(dwCookie)
' Call SetWindowLong(Wea.hWnd,12,dwCookie)
' For i=1 To 25
' For j=1 To 5
' strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
' pGrid.SetData(i, j, strCoordinate)
' Next j
' Next i
' 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)
' Prnt "Leaving fnWndProc_OnCreate()"
'
' fnWndProc_OnCreate=0
'End Function
'
'
'Sub DestroyGrid(Wea As WndEventArgs)
' Local pConnectionPointContainer As IConnectionPointContainer
' Local pConnectionPoint As IConnectionPoint
' Local pVnt As Variant Ptr
' Local dwCookie As Dword
' Local hr,iCnt As Long
' Local pGrid As IGrid
'
' Prnt " Entering DestroyGrid()"
' dwCookie=GetWindowLong(Wea.hWnd,12)
' pVnt=GetWindowLong(Wea.hWnd,4)
' Prnt " pVnt = " & Str$(pVnt)
' If pVnt Then
' pConnectionPoint=@pVnt
' Call pConnectionPoint.Unadvise(dwCookie) To hr
' Prnt " hr = " & Str$(hr)
' Call pConnectionPoint.Release() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Call SetWindowLong(Wea.hWnd,4,0)
' Call GlobalFree(pVnt)
' Else
' Prnt " pConnectionPoint Was Already Released!"
' End If
' pVnt=GetWindowLong(Wea.hWnd,8)
' Prnt " pVnt = " & Str$(pVnt)
' If pVnt Then
' pConnectionPointContainer=@pVnt
' Call pConnectionPointContainer.Release() To iCnt
' Prnt " iCnt = " & Str$(hr)
' Call SetWindowLong(Wea.hWnd,8,0)
' Call GlobalFree(pVnt)
' Else
' Prnt " pConnectionPointContainer Was Already Released!"
' End If
' pVnt=GetWindowLong(Wea.hWnd,0)
' Prnt " pVnt = " & Str$(pVnt)
' If pVnt Then
' pGrid=@pVnt
' Call pGrid.Release() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Call SetWindowLong(Wea.hWnd,0,0)
' Call GlobalFree(pVnt)
' Else
' Prnt " pGrid Was Already Released!"
' End If
' Prnt " Leaving DestroyGrid()"
'End Sub
'
'
'Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
' Local pVnt As Variant Ptr
' Local strData As BStr
' Local pGrid As IGrid
'
' Prnt "Entering fnWndProc_OnCommand()"
' Select Case As Long Lowrd(Wea.wParam)
' Case %IDC_RETRIEVE
' Prnt " Case %IDC_RETRIEVE"
' pVnt=GetWindowLong(Wea.hWnd,0) : pGrid=@pVnt
' pGrid.FlushData()
' strData=pGrid.GetData(3,2)
' Prnt " Cell 3,2 Contains " & strData
' Case %IDC_UNLOAD_GRID
' Prnt " Case %IDC_UNLOAD_GRID"
' Call DestroyGrid(Wea)
' 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
' Prnt "Leaving fnWndProc_OnCommand()"
'
' fnWndProc_OnCommand=0
'End Function
'
'
'Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
' Prnt "Entering fnWndProc_OnDestroy()"
' Call DestroyGrid(Wea)
' Call CoFreeUnusedLibraries()
' Call PostQuitMessage(0)
' Prnt "Leaving fnWndProc_OnDestroy()"
' 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=16
' 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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Here then is the console output from the above program. What might be instructive for you to examine closely are the three AddRef() /Release() calls on the three local interface pointers that occur when an assignment is made to the Variant Ptr memory, and in terms of the Release() calls, when a procedure exits and PowerBASIC calls Release() on the local object pointers. I'll try to mark it out for you in the below output........
Entering fnWndProc_OnCreate()
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 2693828
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pGrid = 5504200
Varptr(@pGrid.lpIGridVtbl) = 5504200
Varptr(@pGrid.lpICPCVtbl) = 5504204
Varptr(@pGrid.lpICPVtbl) = 5504208
@pGrid.pISink = 5499216
@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 = 5504200
Leaving IGrid_QueryInterface()
@ppv = 5504200 << After QueryInterface() Call
Entering Initialize() -- Initialize()
GetModuleHandle() = 2621440
Leaving Initialize()
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 = 5504200
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
pVnt = 5499240
Entering IGrid_QueryInterface()
Looking For Something I Ain't Got!
Leaving IGrid_QueryInterface()
Entering IGrid_QueryInterface() 'Here is where PowerBASIC is doing an AddRef() on the
Trying To Get IUnknown 'copy operation it just saw being done when the pGrid
Entering IGrid_AddRef() 'pointer was stored in the Variant!
@pGrid.m_cRef = 1 << Before
@pGrid.m_cRef = 2 << After
Leaving IGrid_AddRef()
this = 5504200
Leaving IGrid_QueryInterface()
Entering IGrid_CreateGrid()
this = 5504200
hContainer = 2294940
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 = 2622038
pGridData = 4340256
Leaving IGrid_CreateGrid()
Entering IGrid_QueryInterface()
Trying To Get IConnectionPointContainer
this = 5504200
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPointContainer_AddRef()
this = 5504204
Leaving IGrid_QueryInterface()
pVnt = 4345408
Entering IConnectionPointContainer_QueryInterface()
Looking For Something I Ain't Got!
Leaving IConnectionPointContainer_QueryInterface()
Entering IConnectionPointContainer_QueryInterface() 'Here is the next AddRef() PowerBASIC is doing
Looking For IID_IUnknown 'on your or my behalf when it catches us
Entering IGrid_AddRef() 'copying pConnectionPointContainer to
@pGrid.m_cRef = 3 << Before 'a variant. Note at this point we have a
@pGrid.m_cRef = 4 << After 'reference count of 4.
Leaving IGrid_AddRef()
Leaving IConnectionPointContainer_QueryInterface()
Entering IConnectionPointContainer_FindConnectionPoint()
this = 5504204
@ppCP = 0
Entering IConnectionPointContainer_QueryInterface()
Looking For IID_IConnectionPoint
Entering IConnectionPoint_AddRef()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 5 << After
Leaving IConnectionPoint_AddRef()
Leaving IConnectionPointContainer_QueryInterface()
@ppCP = 5504208
Leaving IConnectionPointContainer_FindConnectionPoint()
pVnt = 4345432
Entering IConnectionPoint_QueryInterface()
Looking For Something I Ain't Got!
Leaving IConnectionPoint_QueryInterface()
Entering IConnectionPoint_QueryInterface() 'Now PowerBASIC catches us storing
Entering IGrid_AddRef() 'pConnectionPointContainer in a variant, and
@pGrid.m_cRef = 5 << Before 'that drives the reference count up to 6!
@pGrid.m_cRef = 6 << After
Leaving IGrid_AddRef()
Looking For IID_IUnknown
Leaving IConnectionPoint_QueryInterface()
Objptr(pSink) = 4338092
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
this = 5504208
pGrid = 5504200
@pGrid.hControl = 2622038
pUnkSink = 4338092
Vtbl = 2111209
@Vtbl[0] = 2119368
dwPtr = 4338092
Call Dword Succeeded!
0 5499216 0 Found Open Slot!
Will Be Able To Store Connection Point!
Leaving IConnectionPoint_Advise() And Still In One Piece!
dwCookie = 0
Leaving fnWndProc_OnCreate()
Entering IGrid_Release() 'Here's the really interesting part!
@pGrid.m_cRef = 6 << Before 'At the exact point fnWndProc_OnCreate() exits,
@pGrid.m_cRef = 5 << After 'the reference count was driven up to 6 due
Leaving IGrid_Release() 'to the three AddRef()s PowerBASIC did on the
'three interface pointers, i.e., pGrid,
Entering IConnectionPoint_Release() 'pConnectionPointContainer, and pConnectionPoint.
@pGrid.m_cRef = 5 << Before 'Because these three interface pointers were
@pGrid.m_cRef = 4 << After 'locals, PowerBASIC, in its effort to prevent
Leaving IConnectionPoint_Release() 'memory leaks, will call Release() on each of
'these three variables. That will reduce the
Entering IConnectionPointContainer_Release() 'reference count back to the 3 it was after the
@pGrid.m_cRef = 4 << Before 'C++ program I posted above without all this
@pGrid.m_cRef = 3 << After 'reference counting hokus - pokus! Has it begun
Leaving IConnectionPointContainer_Release() 'to dawn on you yet the concept of 'Reference
'Counting Optimazation?'
Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1(3,2)
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 70=F
Got KeyPress From CGridEvents1! 102=f
Got KeyDown From CGridEvents1! 82=R
Got KeyPress From CGridEvents1! 114=r
Got KeyDown From CGridEvents1! 69=E
Got KeyPress From CGridEvents1! 101=e
Got KeyDown From CGridEvents1! 68=D
Got KeyPress From CGridEvents1! 100=d
Entering fnWndProc_OnCommand() 'Here you can see where PowerBASIC drove the reference count up
Case %IDC_RETRIEVE 'to 4 again when it retrieved the Variant Ptr from instance
Entering IGrid_QueryInterface() 'memory, and assigned the interface pointer in it to pGrid so
Trying To Get IFHGrid 'it could be used to reference the grid methods.
Entering IGrid_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IGrid_AddRef()
this = 5504200
Leaving IGrid_QueryInterface()
Cell 3,2 Contains fred
Leaving fnWndProc_OnCommand()
Entering IGrid_Release() 'And then here you can see where PowerBASIC called Release() on
@pGrid.m_cRef = 4 << Before 'the local pGrid object when the procedure exited and it cleaned
@pGrid.m_cRef = 3 << After 'up its stack.
Leaving IGrid_Release()
Entering fnWndProc_OnCommand()
Case %IDC_UNLOAD_GRID
Entering DestroyGrid() 'Finally, this code shows again how the reference count
pVnt = 4345432 'continually bounced from 3 to 4 and back down to 3 after
'each assignment and release of the pointers from variant
Entering IGrid_QueryInterface() 'memory. It was only after this WM_COMMAND message ends
Trying To Get IConnectionPoint 'that the three releases caused the reference count to fall
this = 5504200 'to zero and the object itself and the dll to be released.
Entering IConnectionPoint_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IConnectionPoint_AddRef()
this = 5504208
Leaving IGrid_QueryInterface()
Entering IConnectionPoint_Unadvise()
this = 5504208
dwCookie = 0
@pGrid.hWndCtrl = 2622038
dwPtr = 4338092
IGrid_Events::Release() Succeeded!
Release() Returned 1
Leaving IConnectionPoint_Unadvise()
hr = 0
Entering IConnectionPoint_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPoint_Release()
iCnt = 3
pVnt = 4345408
Entering IGrid_QueryInterface()
Trying To Get IConnectionPointContainer
this = 5504200
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IConnectionPointContainer_AddRef()
this = 5504204
Leaving IGrid_QueryInterface()
Entering IConnectionPointContainer_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPointContainer_Release()
iCnt = 0
pVnt = 5499240
Entering IGrid_QueryInterface()
Trying To Get IFHGrid
Entering IGrid_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IGrid_AddRef()
this = 5504200
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IGrid_Release()
iCnt = 3
Leaving DestroyGrid()
Entering IGrid_Release() 'These three Release() calls triggered by exit of
@pGrid.m_cRef = 3 << Before 'the DestroyGrid() routine is what finally causes
@pGrid.m_cRef = 2 << After 'the grid to be destroyed due to the bizarre series
Leaving IGrid_Release() 'of AddRef()/Release() calls involving interface
'pointer copy operations.
Entering IConnectionPoint_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
@pGrid.m_cRef = 1 << Before
0 5499216 0
1 5499220 0
2 5499224 0
3 5499228 0
@pGrid.m_cRef = 0 And Will Now Delete pGrid!
Leaving IConnectionPointContainer_Release()
Leaving fnWndProc_OnCommand()
Entering fnWndProc_OnDestroy()
Entering DestroyGrid()
pVnt = 0
pConnectionPoint Was Already Released!
pVnt = 0
pConnectionPointContainer Was Already Released!
pVnt = 0
pGrid Was Already Released!
Leaving DestroyGrid()
Entering DllCanUnloadNow() 'The client calls CoFreeUnusedLibraries() and
I'm Outta Here! (dll is unloaded) 'if there is no lock count or object count the
Leaving DllCanUnloadNow() 'COM Dll will be released from memory.
Leaving fnWndProc_OnDestroy()
After suffering through all those complications, I can well imagine that you've come to the conclusion that you'll just live with global variables for all your COM objects! There is an easier way, however. You might wonder why I didn't show you the easier way, then, rather than having you suffer through all those memory allocations, reference counting complications, so on and so forth. Well, I did that so as to make you realize the nature of the underlying complications involving reference counting. And using the above technique you really didn't have to do much of it on your own; PowerBASIC was recognizing fully what you were doing at all times, and it was handling it for you. The only three Release() calls you needed to make were the three at the end to 'undue' the three reference counts you picked up in the WM_CREATE handler in creating the object and setting up the connection point. If there is such a thing as the 'approved' PowerBASIC way of eliminating globals what I showed you using Variants is likely it. What I'll show you now is the 'unapproved' but easier way of doing it. What it will save you is having to allocate memory and use pointers to store the interface pointers in Variants. And of course, since you won't be allocating GlobalAlloc() memory, you won't have to worry about releasing that. The thing you will have to do yourself though using this new technique is take care of all the reference counting yourself using AddRef() and Release(), because we're completely 'going behind PowerBASIC's back', so to speak, and this is the 'unapproved' way of doing it. Nonetheless it works.
I didn't come up with this technique myself. I had an interesting exchange with Steven Pringels over in the PowerBASIC Forums about it, and he is the one showed it to me. However, he stated he got it from either Edwin Knoppert or Jose Roca.
If you followed my discussions above you should have picked up on the fact that the whole problem in leaving interface pointers go out of scope is that you are going to have excruciating difficulties in restoring them into an object variable even if you saved them. Related to that is the need to keep the object alive by not allowing its reference count to fall to zero, which condition would likely cause the object to be released, invalidating any pointers to the now dead object which you might have saved somewhere. The whole point of using the Variant approach was that PowerBASIC apparently worked out the code for whatever reason (likely to support object parameters) to support transfer of interface pointers into and out of variants.
This new method is based on the idea that we'll simply allocate a local object pointer and copy the address of the the existing and still valid pointer which we've retrieved from window instance memory into the local variable ourselves using Poke or some other memory copy operation. We'll do this because the PowerBASIC compiler simply refuses to allow a simple assignment - no matter how valid it is. Once we get the local initialized - behind PowerBASIC's back, so to speak, we'll have to take care of the reference counting ourselves. The end result though, even considering the AddRef() and Release() calls we'll now have to make, is less code. Here is how the technique will now look in WM_CREATE...
Let pGrid = NewCom "FHGrid4.Grid" 'Create object and get object reference in pGrid
Call SetWindowLong(Wea.hWnd,0,Objptr(pGrid)) 'Assign object reference to window instance memory
pGrid.AddRef() 'Interface copied - so AddRef() it ourselves
Then, when you need to reinstate the interface pointer for use in some procedure such as where my program accesses Cell 3, 2 in the grid, do this...
Local strData As BStr
Local pGrid As IGrid
Local dwPtr As Dword
dwPtr=GetWindowLong(Wea.hWnd,0) 'Get pointer to Grid in dwPtr saved in .cbWndExtra bytes
Poke Dword, pGrid, dwPtr 'PowerBASIC won't allow an assign to pGrid so we have to
Call pGrid.AddRef() 'Poke it in ourselves!
pGrid.FlushData()
strData=pGrid.GetData(3,2)
MsgBox("Cell 3,2 Contains " & strData)
That Poke Dword thing reminds me of a need for another PowerBASIC conversion function to add to its existing complement of such things as CInt, CLng, CSng, etc. This new one would be CObj though, i.e., convert an interface pointer address into an object reference, kind of the reverse of Objptr(). Since I don't see one I made my own with a macro...
Macro CObj(pUnk, dwAddr) = Poke Dword, Varptr(pUnk), dwAddr
So the above code could be this instead...
Local strData As BStr
Local pGrid As IGrid
Local dwPtr As Dword
dwPtr=GetWindowLong(Wea.hWnd,0) 'Get pointer to Grid in dwPtr saved in .cbWndExtra bytes
CObj(pGrid, dwPtr) 'PowerBASIC won't allow an assign to pGrid, so 'Poke'
pGrid.FlushData() 'it in ourselves!
strData=pGrid.GetData(3,2)
MsgBox("Cell 3,2 Contains " & strData)
Here is the whole program implementing this with a commented out debug version after...
'PBClient9_v4.bas Uses Jose's Includes And PBWin 10.02
#Compile Exe "PBClient9_v4.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-000000000070}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000071}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000072}")
%IDC_RETRIEVE = 1500
%IDC_UNLOAD_GRID = 1505
#Include "Windows.inc"
#Include "ObjBase.inc"
Type WndEventArgs 'This program shows what's likely the best and easiest way
wParam As Long 'to eliminate global object variales from your program.
lParam As Long 'What we're doing here, instead of allocating a variant
hWnd As Dword 'dynamically like in PBClient4_v4.bas, is to just directly
hInst As Dword 'store the object's address in .cbWndExtra bytes. We then
End Type 'need to do our own AddRef() on the pointer to prevent it
'from going out of scope, but at least we save ourselves a
Declare Function FnPtr(wea As WndEventArgs) As Long 'memory allocation. Then we need to get real tricky when
'we want to use that address in some other procedure. I
Type MessageHandler 'learned of this technique from Steven Pringels, and he
wMessage As Long 'attributed it to either Jose Roca or Edwin Knoppert.
dwFnPtr As Dword 'It works quite
End Type 'well. What you need to do when you extract the interface
'pointer's address from .cbWndExtra bytes or Window Properties
Global MsgHdlr() As MessageHandler 'is use Poke Dword to Poke the Address into a locally
Macro CObj(pUnk, dwAddr) = Poke Dword, Varptr(pUnk), dwAddr 'allocated object variable. Or, look at my Macro CObj() <<
'just left! That's really underhanded, isn't it? I bet
'stuff like that is just about enough to give Mr. Zale an
Interface IGrid $IID_IFHGrid : Inherit IAutomation 'ulcer!
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 CGridEvents As Event
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
'Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
'Prnt "Got KeyDown From CGridEvents1!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
'Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow 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) & " And This Courtesy CGridEvents1!")
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long 'What's Stored Where
Local pConnectionPointContainer As IConnectionPointContainer
Local pConnectionPoint As IConnectionPoint 'Offset Item
Local pCreateStruct As CREATESTRUCT Ptr '====================================================================
Local strSetup,strCoordinate As BStr '0 - 3 IGrid Ptr - pGrid
Local pSink As IGridEvents '4 - 7 IConnectionPoint Ptr - pConnectionPoint
Local EventGuid As Guid '8 - 11 IConnectionPointContainer Ptr - pConnectionPointContainer
Local dwCookie As Dword '12 - 15 Connection Cookie - dwCookie
Local pGrid As IGrid
Local hCtl As Dword
Register i As Long
Register j As Long
pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance 'Create object with PB's NewCom() and immediately store it in
Let pGrid = NewCom "FHGrid4.Grid" 'instance Window Class memory with ObjPtr(). ObjPtr() returns
Call SetWindowLong(Wea.hWnd,0,Objptr(pGrid)) 'the address of a pointer to an interface. For IGrid Ptr pGrid
pGrid.AddRef() 'lets stick it at offset zero. We then absolutely need to do
strSetup= _ 'an AddRef() on pGrid because when this procedure exits Power-
"120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^" 'BASIC is going to clean up the stack and call Release() on the
pGrid.CreateGrid(Wea.hWnd,strSetup,10,10,570,222,25,5,20,"",18,%FW_DONTCARE) 'Local pGrid as IGrid Ptr. If the reference count on such an
pConnectionPointContainer = pGrid 'object would only be '1', that Release() would decrement the
Call SetWindowLong(Wea.hWnd,8,Objptr(pConnectionPointContainer)) 'reference count to zero and the object would automatically
pConnectionPointContainer.AddRef() 'delete itself. The code for that is in the COM Server. If
EventGuid=$IID_IGridEvents 'you're interested, look in FHGrid4.bas proc IGrid_Release().
Call pConnectionPointContainer.FindConnectionPoint _ 'This same sequence is going to have to be repeated for all the
( _ 'interface pointers, i.e., pConnectionPointContainer,
Byval Varptr(EventGuid), _ 'and pConnectionPoint.
Byval Varptr(pConnectionPoint) _
)
Call SetWindowLong(Wea.hWnd,4,Objptr(pConnectionPoint))
pConnectionPoint.AddRef()
Let pSink = Class "CGridEvents"
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
Call SetWindowLong(Wea.hWnd,12,dwCookie)
For i=1 To 25
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
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(Wea As WndEventArgs) 'Here we need to Destroy the Grid And Release() the object.
Local pConnectionPointContainer As IConnectionPointContainer 'We'll retrieve out pointers from within the .cbWndExtra
Local pConnectionPoint As IConnectionPoint 'bytes of instance Window Class memory and do whatever we
Local dwCookie,dwPtr As Dword 'need to do, no matter how bizarre, to get the address
Local pGrid As IGrid 'situated back in an Object Pointer that PowerBASIC is
'willing to deal with. My little CObj() macro uses Poke
dwCookie=GetWindowLong(Wea.hWnd,12) 'Dword to do this. The logic is exactly the same as with
dwPtr=GetWindowLong(Wea.hWnd,4) 'PBClient4_v4.bas, where the sequence of AddRef() and
If dwPtr Then 'Release() calls only results in a reference count of zero
CObj(pConnectionPoint,dwPtr) 'after DestroyGrid() exits, and PowerBASIC's automatic stack
Call pConnectionPoint.AddRef() 'clean up releases the local object pointers. Then the
Call pConnectionPoint.Unadvise(dwCookie) 'object releases itself.
Call pConnectionPoint.Release()
Call SetWindowLong(Wea.hWnd,4,0)
End If
dwPtr=GetWindowLong(Wea.hWnd,8)
If dwPtr Then
CObj(pConnectionPointContainer,dwPtr)
Call pConnectionPointContainer.AddRef()
Call SetWindowLong(Wea.hWnd,8,0)
Call pConnectionPointContainer.Release()
End If
dwPtr=GetWindowLong(Wea.hWnd,0)
If dwPtr Then
CObj(pGrid,dwPtr)
Call pGrid.AddRef()
Call SetWindowLong(Wea.hWnd,0,0)
Call pGrid.Release()
End If
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local strData As BStr
Local pGrid As IGrid
Local dwPtr As Dword
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
dwPtr=GetWindowLong(Wea.hWnd,0)
CObj(pGrid,dwPtr)
Call pGrid.AddRef()
pGrid.FlushData()
strData=pGrid.GetData(3,2)
MsgBox("Cell 3,2 Contains " & strData)
Case %IDC_UNLOAD_GRID
Call DestroyGrid(Wea)
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(Wea)
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=16
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
Function=msg.wParam
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'debug version
'#Compile Exe "PBClient9_v4.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-000000000070}")
'$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000071}")
'$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000072}")
'%IDC_RETRIEVE = 1500
'%IDC_UNLOAD_GRID = 1505
'#Include "Windows.inc"
'#Include "ObjBase.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
'Macro CObj(pUnk, dwAddr) = Poke Dword, Varptr(pUnk), dwAddr
'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
'Interface IGrid $IID_IFHGrid : Inherit IAutomation
' 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 CGridEvents As Event
' Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
' Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
' End Method
' Method Grid_OnKeyDown(Byval KeyCode As Long, Byval iKeyData As Long, Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Prnt "Got KeyDown From CGridEvents1!" & Str$(KeyCode) & "=" & Chr$(KeyCode)
' End Method
' Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
' End Method
' Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' ' Insert your code here
' End Method
' Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' ' Insert your code here
' End Method
' Method Grid_OnVButtonClick(Byval iCellRow As Long, Byval iGridRow As Long)
' Prnt "You Clicked For Row #" & Str$(iGridRow) & " And This Courtesy CGridEvents1!"
' End Method
' End Interface
'End Class
''What's Stored Where
''Offset Item
''=====================================================================
''0 - 3 IGrid Ptr - pGrid
''4 - 7 IConnectionPoint Ptr - pConnectionPoint
''8 - 11 IConnectionPointContainer Ptr - pConnectionPointContainer
''12 - 15 Connection Cookie - dwCookie
'Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long
' Local pConnectionPointContainer As IConnectionPointContainer
' Local pConnectionPoint As IConnectionPoint
' Local pCreateStruct As CREATESTRUCT Ptr
' Local strSetup,strCoordinate As BStr
' Local pSink As IGridEvents
' Local EventGuid As Guid
' Local dwCookie As Dword
' Local pGrid As IGrid
' Local hCtl As Dword
' Register i As Long
' Register j As Long
' Call AllocConsole()
' Prnt "Entering fnWndProc_OnCreate()"
' pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance
' Let pGrid = NewCom "FHGrid4.Grid"
' Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid))
' Call SetWindowLong(Wea.hWnd,0,Objptr(pGrid))
' pGrid.AddRef()
' strSetup="120:Column 1:^,130:Column 2:^,140:Column 3:^,150:Column 4:^,160:Column 5:^"
' pGrid.CreateGrid(Wea.hWnd, strSetup, 10, 10, 570, 222, 25, 5, 20, "", 18, %FW_DONTCARE)
' pConnectionPointContainer = pGrid
' Call SetWindowLong(Wea.hWnd,8,Objptr(pConnectionPointContainer))
' pConnectionPointContainer.AddRef()
' EventGuid=$IID_IGridEvents
' Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid), Byval Varptr(pConnectionPoint))
' Call SetWindowLong(Wea.hWnd,4,Objptr(pConnectionPoint))
' pConnectionPoint.AddRef()
' Let pSink = Class "CGridEvents"
' Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
' Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
' Prnt " dwCookie = " & Str$(dwCookie)
' Call SetWindowLong(Wea.hWnd,12,dwCookie)
' For i=1 To 25
' For j=1 To 5
' strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
' pGrid.SetData(i, j, strCoordinate)
' Next j
' Next i
' 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)
' Prnt "Leaving fnWndProc_OnCreate()"
' fnWndProc_OnCreate=0
'End Function
'Sub DestroyGrid(Wea As WndEventArgs)
' Local pConnectionPointContainer As IConnectionPointContainer
' Local pConnectionPoint As IConnectionPoint
' Local dwCookie,dwPtr As Dword
' Local hr,iCnt As Long
' Local pGrid As IGrid
' Prnt " Entering DestroyGrid()"
' dwCookie=GetWindowLong(Wea.hWnd,12)
' dwPtr=GetWindowLong(Wea.hWnd,4)
' Prnt " dwPtr = " & Str$(dwPtr)
' If dwPtr Then
' CObj(pConnectionPoint,dwPtr)
' Call pConnectionPoint.AddRef() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Call pConnectionPoint.Unadvise(dwCookie) To hr
' Prnt " hr = " & Str$(hr)
' Call pConnectionPoint.Release() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Call SetWindowLong(Wea.hWnd,4,0)
' Else
' Prnt " pConnectionPoint Was Already Released!"
' End If
' dwPtr=GetWindowLong(Wea.hWnd,8)
' Prnt " dwPtr = " & Str$(dwPtr)
' If dwPtr Then
' CObj(pConnectionPointContainer,dwPtr)
' Call pConnectionPointContainer.AddRef() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Call SetWindowLong(Wea.hWnd,8,0)
' Call pConnectionPointContainer.Release() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Else
' Prnt " pConnectionPointContainer Was Already Released!"
' End If
' dwPtr=GetWindowLong(Wea.hWnd,0)
' Prnt " dwPtr = " & Str$(dwPtr)
' If dwPtr Then
' CObj(pGrid,dwPtr)
' Call pGrid.AddRef() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Call SetWindowLong(Wea.hWnd,0,0)
' Call pGrid.Release() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' Else
' Prnt " pGrid Was Already Released!"
' End If
' Prnt " Leaving DestroyGrid()"
'End Sub
'Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
' Local strData As BStr
' Local pGrid As IGrid
' Local dwPtr As Dword
' Local iCnt As Long
' Prnt "Entering fnWndProc_OnCommand()"
' Select Case As Long Lowrd(Wea.wParam)
' Case %IDC_RETRIEVE
' Prnt " Case %IDC_RETRIEVE"
' dwPtr=GetWindowLong(Wea.hWnd,0)
' Prnt " dwPtr = " & Str$(dwPtr)
' CObj(pGrid,dwPtr)
' Call pGrid.AddRef() To iCnt
' Prnt " iCnt = " & Str$(iCnt)
' pGrid.FlushData()
' strData=pGrid.GetData(3,2)
' Prnt " Cell 3,2 Contains " & strData
' Case %IDC_UNLOAD_GRID
' Prnt " Case %IDC_UNLOAD_GRID"
' Call DestroyGrid(Wea)
' 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
' Prnt "Leaving fnWndProc_OnCommand()"
' fnWndProc_OnCommand=0
'End Function
'Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
' Prnt "Entering fnWndProc_OnDestroy()"
' Call DestroyGrid(Wea)
' Call CoFreeUnusedLibraries()
' Call PostQuitMessage(0)
' Prnt "Leaving fnWndProc_OnDestroy()"
' 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=16
' 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
I'll let you be the judge as to which technique is best. And here would be a console output from a program run with the debug output...
Entering fnWndProc_OnCreate()
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 2693828
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pGrid = 4845256
Varptr(@pGrid.lpIGridVtbl) = 4845256
Varptr(@pGrid.lpICPCVtbl) = 4845260
Varptr(@pGrid.lpICPVtbl) = 4845264
@pGrid.pISink = 4582528
@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 = 4845256
Leaving IGrid_QueryInterface()
@ppv = 4845256 << After QueryInterface() Call
Entering Initialize() -- Initialize()
GetModuleHandle() = 2621440
Leaving Initialize()
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 = 4845256
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Objptr(pGrid) = 4845256
Entering IGrid_AddRef()
@pGrid.m_cRef = 1 << Before
@pGrid.m_cRef = 2 << After
Leaving IGrid_AddRef()
Entering IGrid_CreateGrid()
this = 4845256
hContainer = 328532
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 = 720942
pGridData = 4860464
Leaving IGrid_CreateGrid()
Entering IGrid_QueryInterface()
Trying To Get IConnectionPointContainer
this = 4845256
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPointContainer_AddRef()
this = 4845260
Leaving IGrid_QueryInterface()
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IConnectionPointContainer_AddRef()
Entering IConnectionPointContainer_FindConnectionPoint()
this = 4845260
@ppCP = 0
Entering IConnectionPointContainer_QueryInterface()
Looking For IID_IConnectionPoint
Entering IConnectionPoint_AddRef()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 5 << After
Leaving IConnectionPoint_AddRef()
Leaving IConnectionPointContainer_QueryInterface()
@ppCP = 4845264
Leaving IConnectionPointContainer_FindConnectionPoint()
Entering IConnectionPoint_AddRef()
@pGrid.m_cRef = 5 << Before
@pGrid.m_cRef = 6 << After
Leaving IConnectionPoint_AddRef()
Objptr(pSink) = 4858300
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
this = 4845264
pGrid = 4845256
@pGrid.hControl = 720942
pUnkSink = 4858300
Vtbl = 2111205
@Vtbl[0] = 2117896
dwPtr = 4858300
Call Dword Succeeded!
0 4582528 0 Found Open Slot!
Will Be Able To Store Connection Point!
Leaving IConnectionPoint_Advise() And Still In One Piece!
dwCookie = 0
Leaving fnWndProc_OnCreate()
Entering IGrid_Release()
@pGrid.m_cRef = 6 << Before
@pGrid.m_cRef = 5 << After
Leaving IGrid_Release()
Entering IConnectionPoint_Release()
@pGrid.m_cRef = 5 << Before
@pGrid.m_cRef = 4 << After
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPointContainer_Release()
Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1(3,2)
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 46=.
Got KeyDown From CGridEvents1! 70=F
Got KeyPress From CGridEvents1! 102=f
Got KeyDown From CGridEvents1! 82=R
Got KeyPress From CGridEvents1! 114=r
Got KeyDown From CGridEvents1! 69=E
Got KeyPress From CGridEvents1! 101=e
Got KeyDown From CGridEvents1! 68=D
Got KeyPress From CGridEvents1! 100=d
Entering fnWndProc_OnCommand()
Case %IDC_RETRIEVE
dwPtr = 4845256
Entering IGrid_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IGrid_AddRef()
iCnt = 4
Cell 3,2 Contains fred
Leaving fnWndProc_OnCommand()
Entering IGrid_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IGrid_Release()
Entering fnWndProc_OnCommand()
Case %IDC_UNLOAD_GRID
Entering DestroyGrid()
dwPtr = 4845264
Entering IConnectionPoint_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IConnectionPoint_AddRef()
iCnt = 4
Entering IConnectionPoint_Unadvise()
this = 4845264
dwCookie = 0
@pGrid.hWndCtrl = 720942
dwPtr = 4858300
IGrid_Events::Release() Succeeded!
Release() Returned 0
Leaving IConnectionPoint_Unadvise()
hr = 0
Entering IConnectionPoint_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPoint_Release()
iCnt = 3
dwPtr = 4845260
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IConnectionPointContainer_AddRef()
iCnt = 4
Entering IConnectionPointContainer_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPointContainer_Release()
iCnt = 3
dwPtr = 4845256
Entering IGrid_AddRef()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 4 << After
Leaving IGrid_AddRef()
iCnt = 4
Entering IGrid_Release()
@pGrid.m_cRef = 4 << Before
@pGrid.m_cRef = 3 << After
Leaving IGrid_Release()
iCnt = 3
Leaving DestroyGrid()
Entering IGrid_Release()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 2 << After
Leaving IGrid_Release()
Entering IConnectionPoint_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IConnectionPoint_Release()
Entering IConnectionPointContainer_Release()
@pGrid.m_cRef = 1 << Before
0 4582528 0
1 4582532 0
2 4582536 0
3 4582540 0
@pGrid.m_cRef = 0 And Will Now Delete pGrid!
Leaving IConnectionPointContainer_Release()
Leaving fnWndProc_OnCommand()
Entering fnWndProc_OnDestroy()
Entering DestroyGrid()
dwPtr = 0
pConnectionPoint Was Already Released!
dwPtr = 0
pConnectionPointContainer Was Already Released!
dwPtr = 0
pGrid Was Already Released!
Leaving DestroyGrid()
Entering DllCanUnloadNow()
I'm Outta Here! (dll is unloaded)
Leaving DllCanUnloadNow()
Leaving fnWndProc_OnDestroy()
Just as an interesting tid-bit of information, the C++ program above compiled for me to about 30 K. My PBClient4_v4.exe comes in around 28 K, and PBClient9_v4.exe about 26 K. So even with the extra reference counting hassles in the PowerBASIC programs, they are still coming in smaller than the C++ program. And that's using my string class. If I were using the STL Basic String Class that is a part of the C++ Standard Library, you would be able to add another 30 to 40 K for that.
Version 8 Grid And More On Object Destruction Issues
Looks like its been since last summer (2011) that I posted anything on my grid COM control. Last I posted it was at version 4, but I'll shortly post version 8 which has a delete routine now, the ability to include a combo box control in any column, ability to select/deselect rows (only one at a time), and the ability to set the background and text color of cells. After posting the control code as it now stands, I'll post several clients. I've found it interesting the past few days revisiting some of the material I posted last summer concerning object lifetime, and how one must deal with AddRef(), Release(), and Let object = Nothing type idioms when one is storing object references within the .cbWndExtra bytes or Window Properties of a hosting window. I've always been somewhat 'hazy' about what PowerBASIC is actually doing in the background regarding object cleanup, i.e., garbage collection, vis a vie deallocating local objects and so forth. I think I've made some progress at that, and if any of my readers are like me confused about it, perhaps my examples will help clear things up. Can't absolutely guarantee that, but I'm hopeful!
Here is the grid code as it now stands. Under no circumstances should PBWin 10.03 be used. Only compile with PBWin 10.01 or 10.02. It can be compiled in either the debug or release version depending on whether the %DEBUG = 1 equate on the 3rd line is commented out or not. Compiled for release I'm coming in with about a 48K binary, which compacts down to about 22K with the UPX packer utility. For my purposes, this grid control is about finished, as it meets all my needs.
#Compile Dll "FHGrid8.dll" 'This ActiveX Grid Control compiles to about 48 K as a release
#Dim All 'build, and 90 K as a debug build. With UPX binary packer the
%DEBUG = 1 'release build can be compacted to 22 K. The control can at this
%UNICODE = 1 'time only be used if compiled with PowerBASIC Windows 10.01 or
#If %Def(%UNICODE) '10.02. PBWin 10.03 builds malfunction in various ways.
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 "Win32api.inc"
#Include "ObjBase.inc"
#Resource Typelib, 1, "FHGrid8.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.
%IDC_COMBO = 1705 'If a combo box is used in some column it becomes a child of the cell.
%MAX_CONNECTIONS = 4 'Maximum number of sinks which can be hooked up to connection point
%GRID_CELL_CTRL_NONE = 0 'Not used yet I don't believe.
%GRID_CELL_CTRL_EDIT = 1 'Most typical case, i.e., an edit control set as child of cell.
%GRID_CELL_CTRL_COMBO = 2 'Combo Box used as child of cell.
%GRID_CELL_CTRL_CHECK = 3 'Not implemented yet.
%CONNECT_E_FIRST = &H80040200
%CONNECT_E_ADVISELIMIT = %CONNECT_E_FIRST + 1
%MAX_COLORS = 15 'Maximum number of brushes, i.e., colors that can be created.
Declare Function ptrQueryInterface _ 'Model procedure declares for Call Dword need to be created, as this
( _ 'control is implemented with low level COM, i.e., it goes 'underneath'
Byval this As Dword Ptr, _ 'the PowerBASIC's high level COM implementation.
Byref iid As Guid, _
Byval pUnknown As Dword _
) As Long
Declare Function ptrRelease _ 'If it is important for you to understand this code, and you don't, let
( _ 'me say it is indeed complicated stuff. Here is how I learned it. The
Byval this As Dword Ptr _ 'three main books I used were "Indide COM" by Dale Rogerson, "Inside DCOM"
) As Long 'by Guy And Henry Eddon, and "Developers Workshop To COM And ATL 3.0" by
'Andrew W. Troelsen. Also very noteworthy was "COM In Plain C" by Jeff
Declare Function ptrKeyPress _ 'Glatt. You can do an internet search for "COM In Plain C" and you should
( _ 'be able to locate Jeff's code and tutorial. In terms of what the
Byval this As Dword Ptr, _ 'translations of all that to PowerBASIC look like, I had to rough that out
Byval iKeyCode As Long, _ 'myself, and it was hard and long. My COM Tutorials on Jose Roca's site
Byval iKeyData As Long, _ 'give details of that. It took me years to figure this stuff out, so keep
Byval iRow As Long, _ 'that in mind if you are having difficulties.
Byval iCol As Long, _
Byref blnCancel As Long _
) As Long
Declare Function ptrKeyDown _
( _
Byval this As Dword Ptr, _
Byval iKeyCode As Long, _
Byval iKeyData As Long, _
Byval iRow As Long, _
Byval iCol As Long, _
Byref blnCancel 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 ptrRowSelection _
( _
Byval this As Dword Ptr, _
Byval iRow As Long, _
Byval iAction As Long _
) As Long
Declare Function ptrDelete _
( _
Byval this As Dword Ptr, _
Byval iRow 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-000000000084}")
$IID_IFHGrid = Guid$("{20000000-0000-0000-0000-000000000085}")
$IID_IFHGrid_Events = Guid$("{20000000-0000-0000-0000-000000000086}")
$IID_LIBID_FHGrid = Guid$("{20000000-0000-0000-0000-000000000087}")
Type IGridVtbl ' One of these becomes one of the few global variables
QueryInterface As Dword Ptr ' in this code...
AddRef As Dword Ptr '
Release As Dword Ptr ' Global IGrid_Vtbl As IGridVtbl
CreateGrid As Dword Ptr '
SetRowCount As Dword Ptr ' The individual variables or in actuality 'members' of
SetData As Dword Ptr ' this Type get set down in DllMain(), for example ...
GetData As Dword Ptr '
FlushData As Dword Ptr ' IGrid_Vtbl.QueryInterface = CodePtr(IGrid_QueryInterface)
Refresh As Dword Ptr ' IGrid_Vtbl.AddRef = CodePtr(IGrid_AddRef)
GetCtrlId As Dword Ptr ' IGrid_Vtbl.Release = CodePtr(IGrid_Release)
GethGrid As Dword Ptr ' IGrid_Vtbl.CreateGrid = CodePtr(IGrid_CreateGrid)
GethComboBox As Dword Ptr '
SetCellAttributes As Dword Ptr ' So in that sense you can see that an Interface is really
DeleteRow As Dword Ptr ' just a block of memory holding addresses or pointers to
End Type ' the functions that are called when an object member call
' is made. And the Interface pointer itself, or, if you
Type IGrid ' will - VTable pointer, is just a Type holding a lone
lpVtbl As IGridVtbl Ptr ' pointer to one of the above as seen just left.
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 'This object is used to maintain 'state' in the grid control.
iCtrlID As Long 'Each instantiation of a grid object will cause one of these
hParent As Dword 'to be dynamically allocated, and the pointer to the allocated
hGrid As Dword 'storage will be stored at offset zero in the grid object's
hBase As Dword 'WNDCLASSEX::cbWndExtra bytes. The IGrid Interface has a method
hPane As Dword 'named CreateGrid() implemented in IGrid_CreateGrid(), and it is
hCtrlInCell As Dword 'there where the CreateWindowEx() call is made that starts
cx As Dword 'construction of the grid. The actual grid construction code
cy As Dword 'is largely contained in function fnGridProc_OnCreate(), which
hHeader As Dword 'is the WM_CREATE handler for objects of class "Grid".
iCols As Dword
iRows As Dword 'GridData::pComObj is particularly noteworthy. GridData, which
iVisibleRows As Dword 'holds mostly GUI specific data, holds this pointer to the COM
iRowHeight As Dword 'specific data of the IGrid Interface. Likewise, the CGrid object,
iPaneHeight As Dword 'which holds COM specific data relating to the COM plumbing of the
iEditedCellRow As Long 'grid, i.e., the addresses of the various VTables, also stores the
iEditedRow As Long 'hWnd of the grid there in CGrid::hWndCtrl. In a sense, this is
iEditedCol As Long 'the interface or conduit between these two types of objects created
pComObj As Dword Ptr 'by an instantiation of a grid in a host object.
pColWidths As Dword Ptr
pCellCtrlTypes As Dword Ptr
pCellHandles As Dword Ptr
pGridMemory As Dword Ptr 'Will be storing ZStr Ptrs here
pTextColor As Dword Ptr 'Will be storing RGB values here
pBackColor As Dword Ptr 'Will be storing HBRUSHs here. May be zero for default brush.
pCreatedColors As Dword Ptr 'Colors so far asked for by user per grid instance
pCreatedBrushes As Dword Ptr 'Will be storing created HBRUSHs here. Accumulate them.
pVButtons As Dword Ptr
pCtrlHdls As Dword Ptr
iSelectionBackColor As Long
iSelectionTextColor As Long
blnRowSelected As Long
iSelectedRow As Long
iFontSize As Long
iFontWeight As Long
hFont As Dword
szFontName As ZStr * 28
End Type
Type CGrid 'This is the 'Class' of the grid, and each
lpIGridVtbl As IGridVtbl Ptr 'IClassFactory::CreateInstance() call will
lpICPCVtbl As IConnectionPointContainerVtbl Ptr 'cause one of these to be created. Note one
lpICPVtbl As IConnectionPointVtbl Ptr 'of the members is CGrid::hWndCtrl. This
hWndCtrl As Dword 'member will be filled in after a call of the
pISink As Dword Ptr 'IGrid::CreateGrid member, which represents
m_cRef As Long 'the Window Grid Control object of a CGrid
End Type 'instantiation.
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_OnRowSelection As Dword Ptr
Grid_OnDelete 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) * @pGridData.iCols + (c-1) 'Used to relate two dimensional (row,col) grid coordinates
Global CDClassFactory As IClassFactory1 'to a linear address space
Global IClassFactory_Vtbl As IClassFactoryVtbl
Global IGrid_Vtbl As IGridVtbl
Global IConnPointContainer_Vtbl As IConnectionPointContainerVtbl
Global IConnPoint_Vtbl As IConnectionPointVtbl
Global g_hModule As Dword
Global g_lLocks As Long
Global g_lObjs As Long
Global g_CtrlId As Long
Global fnEditWndProc As Dword 'Used for edit control subclassing
#If %Def(%DEBUG)
Global fp As Long
#EndIf
#If %Def(%DEBUG)
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
#EndIf
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 IGrid_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
Register i As Long
#If %Def(%DEBUG)
Prnt " Entering IGrid_Release()"
#EndIf
pGrid=this
#If %Def(%DEBUG)
Prnt " pGrid = " & Str$(pGrid)
Prnt " @pGrid.m_cRef = " & Str$(@pGrid.m_cRef) & " << Before"
#EndIf
Decr @pGrid.m_cRef
If @pGrid.m_cRef=0 Then
#If %Def(%DEBUG)
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call DestroyWindow(@pGrid.hWndCtrl)
Call CoTaskMemFree(@pGrid.@pISink) ' Or, Less Insane ... Call CoTaskMemFree(Byval @pGrid.pISink)
Call CoTaskMemFree(@this) ' Or, Less Insane ... 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_CreateGrid _ ' This is one of the IGrid Interface methods. The act of invoking something like this in the client ...
( _ '
ByVal this As IGrid Ptr, _ ' pGrid = NewCom "FHGrid8.Grid"
Byval hContainer As Long, _ '
Byval strSetup As BStr, _ ' doesn't directly crete a visible grid. What the above statement does is load the dll and cause
Byval x As Long, _ ' all the internal COM related plumbing to be constructed, such as creation of virtual function
Byval y As Long, _ ' tables, etc. If a call such as the above succeeds and a viable pGrid object returned, then a call
Byval cx As Long, _ ' such as this ...
Byval cy As Long, _ '
Byval iRows As Long, _ ' pGrid.CreateGrid(Wea.hWnd,strSetup,10,10,570,141,%NUMBER_ROWS,%NUMBER_COLUMNS,20,0,0,"Courier New",10,%FW_BOLD)
Byval iCols As Long, _ '
Byval iRowHt As Long, _ ' will eventuate in this procedure being called. The whole thing below with 'Local gd As GridData' is rather
Byval iSelectionBackColor As Long, _ ' nonsense, as I won't use global variables unless I have to, and so gd is filled out from the parameters of
Byval iSelectionTextColor As Long, _ ' IGrid_CreateGrid, and the Varptr(gd) passed into the CreateWindowEx() lpCreateParams of the aforementioned
Byval strFontName As BStr, _ ' call. That is how the parameters of IGrid_CreateGrid manage to get into the WM_CREATE handler for the
Byval iFontSize As Long, _ ' grid object created through the CreateWindowEx() call just below. Ridiculous, I agree. But I can't
Byval iFontWeight As Long _ ' help myself! Also note, not too far below this call ...
) As Long '
Local pGridData As GridData Ptr ' hGrid=CreateWindowEx(%WS_EX_OVERLAPPEDWINDOW,"Grid",Byval Strptr(strSetup),dwStyle,x,y,cx,cy,hContainer,g_CtrlId,g_hModule,ByVal Varptr(gd))
Local hGrid,dwStyle As Dword '
Local pGrid As CGrid Ptr ' which call creates the grid, is this call ...
Local gd As GridData '
' pGridData=GetWindowLong(hGrid,0)
#If %Def(%DEBUG)
Prnt " Entering IGrid_CreateGrid()" ' The 'state' data for the Window Grid Object is, as has previously been mentioned, a GridData object allocated
Prnt " this = " & Str$(this) ' in fnGridProc_OnCreate(). That object becomes available here after the CreateWindowEx() call just above, and
Prnt " hContainer = " & Str$(hContainer) ' more of the fields of it are filled out. Note particularly that CGrid::hWndCtrl gets filled out, as well as this ...
Prnt " strSetup = " & strSetup '
Prnt " x = " & Str$(x) ' @pGridData.pComObj=this
Prnt " y = " & Str$(y) '
Prnt " cx = " & Str$(cx) ' In this way you can see how connections are set up between two different types of memory allocations representing
Prnt " cy = " & Str$(cy) ' the grid, i.e., the memory allocation for COM related infrastructure such as virtual function tables, and for
Prnt " iRows = " & Str$(iRows) ' Windows GUI object stuff such as HANDLE of the grid, HANDLEs of grid cells, etc.
Prnt " iCols = " & Str$(iCols)
Prnt " iRowHt = " & Str$(iRowHt)
Prnt " iSelectionBackColor = " & Hex$(iSelectionBackColor)
Prnt " iSelectionTextColor = " & Hex$(iSelectionTextColor)
Prnt " strFontName = " & strFontName
Prnt " iFontSize = " & Str$(iFontSize)
Prnt " iFontWeight = " & Str$(iFontWeight)
#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
gd.iSelectionBackColor = iSelectionBackColor
gd.iSelectionTextColor = iSelectionTextColor
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 " hGrid = " & Str$(hGrid)
#EndIf
Incr g_CtrlId
pGrid=this
@pGrid.hWndCtrl=hGrid
pGridData=GetWindowLong(hGrid,0)
#If %Def(%DEBUG)
Prnt " pGridData = " & Str$(pGridData)
#EndIf
@pGridData.pComObj=this
If iSelectionBackColor=0 Then ' Here is where @pGridData.iSelectionBackColor and @pGridData.iSelectionTextColor
@pGridData.iSelectionBackColor=%RGB_ROYALBLUE ' are set.
End If
If iSelectionTextColor=0 Then
@pGridData.iSelectionTextColor=%RGB_MAROON
End If
Call IGrid_SetCellAttributes(this,0,0,@pGridData.iSelectionBackColor,@pGridData.iSelectionTextColor)
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 pGridData As GridData Ptr
Local iSize,blnFree As Long
Local pGrid As CGrid Ptr
Local si As SCROLLINFO
Register i As Long
pGrid=this
#If %Def(%DEBUG)
Print #fp, " Entering IGrid_SetRowCount()"
Print #fp,
Print #fp, " i blnFree"
Print #fp, " ================="
#EndIf
pGridData=GetWindowLong(@pGrid.hWndCtrl,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
blnFree=GlobalFree(@pGridData.pTextColor)
#If %Def(%DEBUG)
Print #fp, " GlobalFree(@pGridData.pTextColor) = " blnFree
#EndIf
blnFree=GlobalFree(@pGridData.pBackColor)
#If %Def(%DEBUG)
Print #fp, " GlobalFree(@pGridData.pBackColor) = " blnFree
#EndIf
'Create New Memory Block ' This is the way its going to have to be! I lost several days fighting
If iRowCount < @pGridData.iVisibleRows Then ' with the fundamental restructuring of the grid to support a
#If %Def(%DEBUG) ' pGridData.iRows < pGridData.iVisibleRows, and I can tell you for a fact
Print #fp, " Got In Where iRowCount < iVisibleRows" ' it isn't worth it!!!! So here I'm just going to modify the user's iRowCount
#EndIf ' parameter so that a grid instance will never have an iRows member less
iRowCount=@pGridData.iVisibleRows+1 ' than the .iVisibleRows number. In this way the grid will always have a
@pGridData.iRows=@pGridData.iVisibleRows+1 ' verticle scrollbar, and I won't have to deal with funkiness caused by
End If ' a blank area where the verticle scroll bar used to be (other funkiness too).
iSize=iRowCount * @pGridData.iCols
@pGridData.pGridMemory=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR) ' Maybe someday I'll revisit this situation, but I doubt it.
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(@pGrid.hWndCtrl,%SB_VERT,si,%TRUE)
@pGridData.pTextColor=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
#If %Def(%DEBUG)
Print #fp, " @pGridData.pTextColor = " @pGridData.pTextColor
#EndIf
If @pGridData.pTextColor=0 Then
Function=%E_FAIL : Exit Function
End If
@pGridData.pBackColor=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
#If %Def(%DEBUG)
Print #fp, " @pGridData.pBackColor = " @pGridData.pBackColor
#EndIf
If @pGridData.pBackColor=0 Then
Function=%E_FAIL : Exit Function
End If
#If %Def(%DEBUG)
Print #fp, " Leaving IGrid_SetRowCount()"
Print #fp,
#EndIf
Function=%S_OK : Exit Function
End If
#If %Def(%DEBUG)
Print #fp, " Leaving IGrid_SetRowCount()"
Print #fp,
#EndIf
Function=%E_FAIL
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 pGridData As GridData Ptr
Local pGrid As CGrid Ptr
Local pStr As ZStr Ptr
Local iIndex As Long
pGrid=this : pGridData=GetWindowLong(@pGrid.hWndCtrl,0)
If iRow <= @pGridData.iRows And iCol <=@pGridData.iCols Then
If iRow>0 And iCol>0 Then
iIndex=dwIdx(iRow,iCol)
pStr=@pGridData.@pGridMemory[iIndex]
If @pStr<>strData Then
Call GlobalFree(pStr)
pStr=GlobalAlloc(%GPTR, (Len(strData)+1)*%SIZEOF_CHAR )
If pStr Then
@pStr=strData
@pGridData.@pGridMemory[iIndex]=pStr
Function=%S_OK
Else
Function=%S_FALSE
End If
Else
Function=%S_OK
End If
Else
Function=%S_FALSE
End If
Else
Function=%S_FALSE
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 pGridData As GridData Ptr
Local pGrid As CGrid Ptr
Local pZStr As ZStr Ptr
Local iIndex As Long
pGrid=this
pGridData=GetWindowLong(@pGrid.hWndCtrl,0)
If iRow <= @pGridData.iRows And iRow > 0 Then
If iCol<=@pGridData.iCols And iCol>0 Then
iIndex=dwIdx(iRow,iCol)
pZStr=@pGridData.@pGridMemory[iIndex]
strData=@pZStr
Function=%S_OK : Exit Function
Else
Function=%E_FAIL : Exit Function
End If
Else
Function=%E_FAIL : Exit Function
End If
End Function
Function IGrid_FlushData(Byval this As IGrid Ptr) As Long
Local pGridData As GridData Ptr
Local pGrid As CGrid Ptr
Local pZStr As ZStr Ptr
Local strData As BStr
Local hGrid As Dword
Local iLen As Long
#If %Def(%DEBUG)
Print #fp, " Entering IGrid_FlushData()"
#EndIf
pGrid=this : hGrid=@pGrid.hWndCtrl : pGridData=GetWindowLong(hGrid,0)
#If %Def(%DEBUG)
Print #fp, " pGrid = " pGrid
Print #fp, " hGrid = " hGrid
Print #fp, " pGridData = " pGridData
#EndIf
If @pGridData.hCtrlInCell Then
#If %Def(%DEBUG)
Print #fp, " Got In Where @pGridData.hCtrlInCell = %True!"
Print #fp, " @pGridData.hCtrlInCell = " @pGridData.hCtrlInCell
#EndIf
iLen=GetWindowTextLength(@pGridData.hCtrlInCell)
pZStr=GlobalAlloc(%GPTR,(iLen+1)*%SIZEOF_CHAR)
If pZStr Then
Call GetWindowText(@pGridData.hCtrlInCell,Byval pZStr,iLen+1)
strData=@pZStr
Call IGrid_SetData(this,@pGridData.iEditedRow,@pGridData.iEditedCol,strData)
#If %Def(%DEBUG)
Print #fp, " Got To Here!"
#EndIf
Call SetWindowLong(@pGridData.hCtrlInCell,%GWL_WNDPROC,fnEditWndProc)
Call SetParent(@pGridData.hCtrlInCell,hGrid)
Call SetWindowPos(@pGridData.hCtrlInCell,%HWND_BOTTOM,0,0,0,0,%SWP_HIDEWINDOW)
@pGridData.hCtrlInCell=0
Call IGrid_Refresh(this)
Else
#If %Def(%DEBUG)
Print #fp, " Function=%S_FALSE"
Print #fp, " Leaving IGrid_FlushData()"
Print #fp,
#EndIf
Function=%S_FALSE : Exit Function
End If
End If
#If %Def(%DEBUG)
Print #fp, " Function=%S_OK"
Print #fp, " Leaving IGrid_FlushData()"
Print #fp,
#EndIf
Function=%S_OK
End Function
continued ...
Function IGrid_Refresh(Byval this As IGrid Ptr) As Long
Local iRows,iCols,iCountCells,iIdx,iReturn As Long
Local pGridData As GridData Ptr
Local pGrid As CGrid Ptr
Local pText As ZStr Ptr
Local si As SCROLLINFO
Register i As Long
pGrid=this
#If %Def(%DEBUG)
Print #fp, " Entering IGrid_Refresh()"
#EndIf
pGridData=GetWindowLong(@pGrid.hWndCtrl,0)
iRows=@pGridData.iVisibleRows
iCols=@pGridData.iCols
iCountCells=iRows*iCols
si.cbSize = sizeof(SCROLLINFO)
si.fMask=%SIF_POS
iReturn=GetScrollInfo(@pGrid.hWndCtrl,%SB_VERT,si)
#If %Def(%DEBUG)
Print #fp, " iReturn = " iReturn
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 @pBackColor[iIdx] @pTextColor[iIdx]"
Print #fp, " =================================================================================="
#EndIf
If iReturn Then
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 SetWindowLong(@pGridData.@pCellHandles[i],8,@pGridData.@pTextColor[iIdx])
Call SetWindowLong(@pGridData.@pCellHandles[i],12,@pGridData.@pBackColor[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, Hex$(@pGridData.@pBackColor[iIdx]),Hex$(@pGridData.@pTextColor[iIdx])
#EndIf
Next i
Function=%S_OK
Else
Function=%E_FAIL
End If
#If %Def(%DEBUG)
Print #fp, " Leaving Refresh()"
Print #fp,
#EndIf
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 IGrid_GethComboBox(Byval this As IGrid Ptr, Byval iCol As Long, Byref hComboBox As Long) As Long
Local pGridData As GridData Ptr
Local pGrid As CGrid Ptr
pGrid=this
pGridData=GetWindowLong(@pGrid.hWndCtrl,0)
If @pGridData.@pCellCtrlTypes[iCol-1]=%GRID_CELL_CTRL_COMBO Then
hComboBox=@pGridData.@pCtrlHdls[iCol-1]
Function=%S_OK
Else
Function=%E_FAIL
End If
End Function
Function IGrid_SetCellAttributes(Byval this As IGrid Ptr, Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Local pGridData As GridData Ptr
Local iIdx,blnFound As Long
Local pGrid As CGrid Ptr
Register i As Long
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Entering IGrid_SetCellAttributes()"
Print #fp, " this = " this
Print #fp, " iRow = " iRow
Print #fp, " iCol = " iCol
Print #fp, " iBackColor = " Hex$(iBackColor)
Print #fp, " iTextColor = " Hex$(iTextColor)
#EndIf
pGrid=this
pGridData=GetWindowLong(@pGrid.hWndCtrl,0)
If iRow And iCol Then
iIdx=dwIdx(iRow,iCol)
@pGridData.@pTextColor[iIdx] = iTextColor
Else
iIdx=0
End If
#If %Def(%DEBUG)
Print #fp, " @pGridData.iCols = " @pGridData.iCols
Print #fp, " iIdx = " iIdx
Print #fp, " @pGridData.pTextColor = " @pGridData.pTextColor
Print #fp, " @pGridData.@pTextColor[iIdx] = " @pGridData.@pTextColor[iIdx]
Print #fp, " @pGridData.@pCellHandles[iIdx] = " @pGridData.@pCellHandles[iIdx]
Print #fp, " @pGridData.@pCreatedColors[0] = " @pGridData.@pCreatedColors[0]
Print #fp, " @pGridData.@pCreatedBrushes[0] = " @pGridData.@pCreatedBrushes[0]
Print #fp, " i @pGridData.@pCreatedColors[i] iBackColor"
Print #fp, " ============================================================="
#EndIf
'pGridMemory As Dword Ptr 'Will be storing ZStr Ptrs here
'pTextColor As Dword Ptr 'Will be storing RGB values here, i.e., %Red, %Blue, etc
'pBackColor As Dword Ptr 'Will be storing HBRUSHs here. May be zero for default brush.
'pCreatedColors As Dword Ptr 'Colors so far asked for by user per grid instance, e.g., %Red, %Yellow, %Blue, etc.
'pCreatedBrushes As Dword Ptr 'Will be storing created HBRUSHs here. Accumulate them. Numbers such as &HA0556789
For i=1 To @pGridData.@pCreatedColors[0]
#If %Def(%DEBUG)
Print #fp, " " i, Hex$(@pGridData.@pCreatedColors[i]),,,Hex$(iBackColor)
#EndIf
If @pGridData.@pCreatedColors[i]=iBackColor Then
blnFound=%True : Exit For
End If
Next i
If blnFound Then
If iRow And iCol Then
@pGridData.@pBackColor[iIdx] = @pGridData.@pCreatedBrushes[i]
End If
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Got In Where blnFound = %True!"
Print #fp, " @pGridData.@pCreatedBrushes[i] = " Hex$(@pGridData.@pCreatedBrushes[i])
#EndIf
Else
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Got In Where blnFound = %False!"
Print #fp, " @pGridData.@pCreatedBrushes[0] = " @pGridData.@pCreatedBrushes[0] " << Before"
#EndIf
If @pGridData.@pCreatedBrushes[0]<%MAX_COLORS Then ' Test to see if @pGridData.@pCreatedBrushes[0]
Incr @pGridData.@pCreatedBrushes[0] ' is less than 15, i.e., %MAX_COLORS
Incr @pGridData.@pCreatedColors[0]
#If %Def(%DEBUG)
Print #fp, " Will Be Able To Create Another Brush!"
#EndIf
Else
Function=%E_FAIL : Exit Function ' We've already created 15 brushes
#If %Def(%DEBUG)
Print #fp, " Can't Create Another Brush!"
Print #fp, " Leaving IGrid_SetCellAttributes()"
Print #fp,
#EndIf
End If
#If %Def(%DEBUG)
Print #fp, " @pGridData.@pCreatedBrushes[0] = " @pGridData.@pCreatedBrushes[0] " << After"
#EndIf
@pGridData.@pCreatedBrushes[@pGridData.@pCreatedBrushes[0]] = CreateSolidBrush(iBackColor)
@pGridData.@pCreatedColors[@pGridData.@pCreatedColors[0]] = iBackColor
#If %Def(%DEBUG)
Print #fp, " @pGridData.@pCreatedBrushes[@pGridData.@pCreatedBrushes[0]] = " @pGridData.@pCreatedBrushes[@pGridData.@pCreatedBrushes[0]]
#EndIf
If iRow And iCol Then
@pGridData.@pBackColor[iIdx] = @pGridData.@pCreatedBrushes[@pGridData.@pCreatedBrushes[0]]
#If %Def(%DEBUG)
Print #fp, " Have Just Assigned A Newly Created Brush To pBackColor[]"
Print #fp, " @pGridData.@pBackColor[iIdx] = " Hex$(@pGridData.@pBackColor[iIdx])
#EndIf
End If
End If
#If %Def(%DEBUG)
If iRow And iCol Then
Print #fp, " @pGridData.@pTextColor[iIdx] = " Hex$(@pGridData.@pTextColor[iIdx])
End If
Print #fp, " Leaving IGrid_SetCellAttributes()"
Print #fp,
#EndIf
Function=%S_Ok
End Function
Function IGrid_DeleteRow(ByVal this As IGrid Ptr, Byval iRow As Long) As Long
Local iStart,iSize,iCols As Long
Local pGridData As GridData Ptr
Local pGrid As CGrid Ptr
Local hGrid As Dword
Register i As Long
#If %Def(%DEBUG)
Prnt " Entering IGrid_DeleteRow()"
#EndIf
pGrid=this
hGrid=@pGrid.hWndCtrl
pGridData=GetWindowLong(hGrid,0)
#If %Def(%DEBUG)
Prnt " pGrid = " & Str$(pGrid)
Prnt " hGrid = " & Str$(hGrid)
Prnt " pGridData = " & Str$(pGridData)
Prnt " iRow = " & Str$(iRow)
#EndIf
iSize=(@pGridData.iRows-1)*@pGridData.iCols-1
iStart=dwIdx(iRow,1)
iCols=@pGridData.iCols
#If %Def(%DEBUG)
Prnt " iSize = " & Str$(iSize)
Prnt " iStart = " & Str$(iStart)
Prnt " iCols = " & Str$(iCols)
#EndIf
For i=iStart To iSize
@pGridData.@pGridMemory[i] = @pGridData.@pGridMemory[i+iCols]
@pGridData.@pTextColor[i] = @pGridData.@pTextColor[i+iCols]
@pGridData.@pBackColor[i] = @pGridData.@pBackColor[i+iCols]
Next i
iStart=dwIdx(@pGridData.iRows,1)
For i=iStart To iStart+iCols - 1
@pGridData.@pGridMemory[i] = 0
@pGridData.@pTextColor[i] = 0
@pGridData.@pBackColor[i] = 0
Next i
For i=1 To iCols
Call IGrid_SetCellAttributes(this,iRow,i,@pGridData.iSelectionBackColor,@pGridData.iSelectionTextColor)
Next i
#If %Def(%DEBUG)
Prnt " Leaving IGrid_DeleteRow()"
#EndIf
Function=%S_Ok
End Function
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 hr,blnCancel As Long
Local pGrid As CGrid Ptr
Register i As Long
hCell=GetParent(hEdit) : hPane=GetParent(hCell)
hBase=GetParent(hPane) : hGrid=GetParent(hBase)
pGridData=GetWindowLong(hPane,0)
pGrid=@pGridData.pComObj
Select Case As Long wMsg
Case %WM_CHAR
#If %Def(%DEBUG)
Print #fp, " Entering fnEditSubClass"
Print #fp, " Got WM_CHAR Message In fnEditSubClass!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[3] Using ptrKeyPress(dwPtr, wParam, lParam, @pGridData.iEditedRow, @pGridData.iEditedCol, blnCancel) To hr
If blnCancel Then
Exit Function
End If
End If
Next i
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Print #fp, " Call Dword @Vtbl[3] Using ptrKeyPress() Succeeded!"
End If
#EndIf
If wParam=%VK_RETURN Then
#If %Def(%DEBUG)
Print #fp, " Got WM_CHAR Message %VK_RETURN In fnEditSubClass!"
#EndIf
Call IGrid_FlushData(pGrid)
Call IGrid_Refresh(@pGridData.pComObj)
#If %Def(%DEBUG)
Print #fp, " Leaving fnEditSubClass"
Print #fp,
#EndIf
Exit Function
Else
@pGridData.hCtrlInCell=hEdit
End If
#If %Def(%DEBUG)
Print #fp, " Leaving fnEditSubClass"
Print #fp,
#EndIf
Case %WM_KEYDOWN
#If %Def(%DEBUG)
Print #fp, " Entering fnEditSubClass"
Print #fp, " Got WM_KEYDOWN Message In fnEditSubClass!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[4] Using ptrKeyDown(dwPtr, wParam, lParam, @pGridData.iEditedRow, @pGridData.iEditedCol, blnCancel) To hr
If blnCancel Then
Exit Function
End If
End If
Next i
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Print #fp, " Call Dword @Vtbl[4] Using ptrKeyDown() Succeeded!"
End If
Print #fp, " Leaving fnEditSubClass"
Print #fp,
#EndIf
Case %WM_PASTE
#If %Def(%DEBUG)
Print #fp, " Got WM_PASTE Message In fnEditSubClass!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[7] Using ptrPaste(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Print #fp, " Call Dword @Vtbl[7] Using ptrPaste() Succeeded!"
End If
#EndIf
Case %WM_LBUTTONDBLCLK
#If %Def(%DEBUG)
Print #fp, " Got %WM_LBUTTONDBLCLK Message In fnEditSubClass!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[6] Using ptrLButtonDblClk(dwPtr, @pGridData.iEditedCellRow, @pGridData.iEditedRow, @pGridData.iEditedCol) To hr
End If
Next i
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Print #fp, " Call Dword @Vtbl[6] Using ptrPaste() Succeeded!"
End If
#EndIf
End Select
Function=CallWindowProc(fnEditWndProc,hEdit,wMsg,wParam,lParam)
End Function
Function EnumGridProc(Byval hWnd As Long, Byval lParam As Dword) As Long
If GetClassLong(hWnd,%GCL_WNDPROC)=lParam Then
#If %Def(%DEBUG)
Print #fp, " Called EnumGridProc() - ", hWnd, lParam
#EndIf
Local pGridData As GridData Ptr
pGridData=GetWindowLong(hWnd,0)
Call IGrid_FlushData(@pGridData.pComObj)
End If
Function=%True
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 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
Local pGrid As CGrid 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 EnumChildWindows(@pGridData.hParent,CodePtr(EnumGridProc),Byval Codeptr(fnGridProc))
si.cbSize = sizeof(SCROLLINFO)
si.fMask=%SIF_POS
Call GetScrollInfo(hGrid,%SB_VERT,si)
For i=1 To @pGridData.iVisibleRows
For j=1 To @pGridData.iCols
iCellBufferPos = dwIdx(i,j)
If @pGridData.@pCellHandles[iCellBufferPos]=hCell Then
iGridMemOffset = @pGridData.iCols * (si.nPos -1) + iCellBufferPos
pZStr=@pGridData.@pGridMemory[iGridMemOffset]
iRow=i : iCol=j
@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
Exit, Exit
End If
Next j
Next i
#If %Def(%DEBUG)
Print #fp, " iRow = " iRow
Print #fp, " iCol = " iCol
Print #fp, " @pGridData.@pCellCtrlTypes[iCol-1] = " @pGridData.@pCellCtrlTypes[iCol-1]
#EndIf
@pGridData.hCtrlInCell=@pGridData.@pCtrlHdls[iCol-1]
Call SetParent(@pGridData.hCtrlInCell,hCell)
fnEditWndProc=SetWindowLong(@pGridData.hCtrlInCell,%GWL_WNDPROC,CodePtr(fnEditSubClass)) '<<added to fix bad bug
If @pGridData.hFont Then
Call SendMessage(@pGridData.hCtrlInCell,%WM_SETFONT,@pGridData.hFont,%TRUE)
End If
If @pGridData.@pCellCtrlTypes[iCol-1]=%GRID_CELL_CTRL_EDIT Then
Call SetWindowPos(@pGridData.hCtrlInCell,%HWND_TOP,1,0,@pGridData.@pColWidths[iCol-1]-2,@pGridData.iRowHeight,%SWP_SHOWWINDOW)
Call SetWindowText(@pGridData.hCtrlInCell,@pZStr)
Call SetFocus(@pGridData.hCtrlInCell)
End If
If @pGridData.@pCellCtrlTypes[iCol-1]=%GRID_CELL_CTRL_COMBO Then
Call SetWindowPos(@pGridData.hCtrlInCell,%HWND_TOP,1,0,@pGridData.@pColWidths[iCol-1]-2,180,%SWP_SHOWWINDOW)
Call SendMessage(@pGridData.hCtrlInCell,%CB_SETCURSEL,-1,0)
End If
pGrid=@pGridData.pComObj
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
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
#EndIf
End If
Next i
#If %Def(%DEBUG)
Print #fp, " Leaving fnCellProc - Case WM_LBUTTONDOWN" : Print #fp,
#EndIf
Function=0 : Exit Function
Case %WM_PAINT
Local hDC,hFont,hTmp,hBrush,hTmpBr,dwColor As Dword
Local pBuffer As ZStr Ptr
Local ps As PAINTSTRUCT
hDC=BeginPaint(hCell,ps)
pBuffer=GetWindowLong(hCell,0)
hFont=GetWindowLong(hCell,4)
dwColor=GetWindowLong(hCell,8)
hBrush=GetWindowLong(hCell,12)
If hFont Then
hTmp=SelectObject(hDC,hFont)
End If
If dwColor Then
Call SetTextColor(hDC,dwColor)
End If
If hBrush Then
Local rc As RECT
hTmpBr=SelectObject(hDC,hBrush)
Call GetClientRect(hCell,rc)
Call FillRect(hDC,rc,hBrush)
Call SelectObject(hDC,hTmpBr)
End If
Call SetBkMode(hDC,%TRANSPARENT)
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.hCtrlInCell Then
Call IGrid_FlushData(@pGridData.pComObj)
Call IGrid_Refresh(@pGridData.pComObj)
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 ' This is the procedure which actually creates the grid.
Local iFlds,iHdlCount,iCols,iCtr,iSize As Long ' When this Dll is loaded and DllGetClassObjectImpl() is
Local strParseData(),strFieldData() As BStr ' called, the Sub Initialize() is then called too. This
Local pGridData1,pGridData2 As GridData Ptr ' latter Sub registers (RegisterClassEx()) several Window
Local dwStyle,hButton,hCell,hDC As Dword ' Classes necessary to the grid's creation, such as the
Local pCreateStruct As CREATESTRUCT Ptr ' "Grid", Class, the "Pane" Class, and the "Cell" Class.
Local szText As ZStr*64 ' When a client app holding an IGrid Interface Pointer
Local hdrItem As HDITEM ' makes an IGrid::CreateGrid() member call, the function
Local strSetup As BStr ' IGrid_CreateGrid() is first called, and this latter
Local iPos() As Long ' function makes the CreateWindowEx(..., "Grid", ...)
Register i As Long ' call that triggers invocation of this fnGridProc_OnCreate()
Register j As Long ' WM_CREATE handler, which constructs the grid.
Local rc As RECT
#If %Def(%DEBUG)
Print #fp, " Entering fnGridProc_OnCreate()"
#EndIf
pCreateStruct=Wea.lParam ' A grid consists of many 'child' or subobjects. For example,
Wea.hInst=@pCreateStruct.hInstance ' there is the "Grid" itself, which is something of a "Container"
pGridData1=@pCreateStruct.lpCreateParams ' object. Within the "Grid", and as children of the grid, are
strSetup=@pCreateStruct.@lpszName ' the "Base" object, and the "Pane" object. Then the "Cell"
Call GetClientRect(Wea.hWnd,rc) ' objects become children of the "Pane" object. It is the "Pane"
#If %Def(%DEBUG)
Print #fp, " %WM_USER = " %WM_USER ' object which is involved in horizontal scrolling.
Print #fp, " %WM_APP = " %WM_APP ' It is the header control, i.e., WC_HEADER, which
Print #fp, " hGrid = " Wea.hWnd ' I've used to provide the functionality of resizable
Print #fp, " pGridData1 = " pGridData1 ' grid columns. That control sits atop and becomes a
Print #fp, " Wea.hInstance = " Wea.hInst ' child of the "Pane". Then the "Cell" objects, each
Print #fp, " @pCreateStruct.cx = " @pCreateStruct.cx ' of which are created through a CreateWindowEx() call,
Print #fp, " @pCreateStruct.cy = " @pCreateStruct.cy ' sit underneath the header control, and are also children
Print #fp, " rc.Right = " rc.Right ' of the "Pane". Of course, some of the first real work
Print #fp, " rc.Bottom = " rc.Bottom ' this procedure does is to determine the sizes of things
Print #fp, " @pGridData1.iFontSize = " @pGridData1.iFontSize ' and their locations, given the various parameters sent
Print #fp, " @pGridData1.iFontWeight = " @pGridData1.iFontWeight ' in through the parameter list from the client. After
Print #fp, " @pGridData1.szFontName = " @pGridData1.szFontName ' that is the necessity of dealing with the setup string
Print #fp, " strSetup = " strSetup ' sent in from the client, which contains all the column info.
#EndIf
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 ' In terms of the strSetup parameter, that is a BSTR passed in from the client
Function=-1 : Exit Function ' with a comma delimited format that contains the initial pixel width of the
End If ' column, the text to display in the header control, the type of control to
pGridData2=GlobalAlloc(%GPTR,sizeof(GridData)) ' be set in the cell when a user clicks on a cell (at this time only edit controls
If pGridData2=0 Then ' or combo boxes), and whether the text in the header control is left oriented,
Function=-1 : Exit Function ' right oriented, or centered (<:>:^). The ':' symbol further is used as the
End If ' delimiter of this information within each comma delimited substring. Note
Call SetWindowLong(Wea.hWnd,0,pGridData2) ' that PowerBASIC's ParseCount / Parse statement functionality is used to seperate
@pGridData2.iCtrlID=@pCreateStruct.hMenu ' the substrings and get at this data. The Parse Statement was broken in PBWin 10,
@pGridData2.cx=@pCreateStruct.cx ' then fixed in update release 10.01. In PBWin 10.02 it also worked, but was again
@pGridData2.cy=@pCreateStruct.cy ' broken in PBWin 10.03. This latter situation only applies to unicode builds
@pGridData2.iCols=iCols ' and on Win 2000/XP machines (for whatever reason). Therefore, I would not
@pGridData2.iRows=@pGridData1.iRows ' recommend using this grid if it is going to be built with PBWin 10.03.
@pGridData2.iRowHeight=@pGridData1.iRowHeight
@pGridData2.iVisibleRows=Fix((rc.Bottom-@pGridData1.iRowHeight)/@pGridData1.iRowHeight)
If @pGridData1.iRows>@pGridData2.iVisibleRows Then 'DANGER! ADDITION!!!
@pGridData2.iRows=@pGridData1.iRows
Else
@pGridData2.iRows=@pGridData2.iVisibleRows+1
@pGridData1.iRows=@pGridData2.iVisibleRows+1
End If 'END DANGER ADDITION
@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(),"," ' Here is the statement that seems to cause memory corruption on 2000/XP.
@pGridData2.pColWidths=GlobalAlloc(%GPTR,(iCols+1)*%SIZEOF_PTR) 'when 10.03 compiler is used.
If @pGridData2.pColWidths=0 Then
Goto CleanUp
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) 'Create Base
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)
@pGridData2.pCellCtrlTypes=GlobalAlloc(%GPTR,(iCols)*%SIZEOF_PTR) 'Set up ptr to buffer in GridData for holding control types for column, i.e.,
If @pGridData2.pCellCtrlTypes=0 Then 'edit controls, none, combo boxes, etc.
Goto CleanUp
End If
@pGridData2.pCtrlHdls=GlobalAlloc(%GPTR,(iCols)*%SIZEOF_PTR)
If @pGridData2.pCtrlHdls=0 Then
Goto CleanUp
End If
#If %Def(%DEBUG)
Print #fp, " @pGridData2.hBase = " @pGridData2.hBase
Print #fp, " @pGridData2.hPane = " @pGridData2.hPane
Print #fp, " @pGridData2.hHeader = " @pGridData2.hHeader
Print #fp, " @pGridData2.pCellCtrlTypes = " @pGridData2.pCellCtrlTypes
Print #fp,
Print #fp, " i @pColWidths[i] iPos(i) szText strFieldData(2), strFieldData(3) Cell Ctrl Type"
Print #fp, " ==========================================================================================================================="
#EndIf
hdrItem.mask=%HDI_FORMAT Or %HDI_WIDTH Or %HDI_TEXT
Redim iPos(iCols) As Long
For i=0 To iCols-1 ' This rather complex code sets up the header control using the data parsed
iFlds=ParseCount(strParseData(i),":") ' from the setup string, such as grid column text strings, initial widths,
Redim strFieldData(iFlds-1) ' justification of text in header control, etc. Note that each of the sub-
Parse strParseData(i), strFieldData(), ":" ' strings parsed from the comma delimited setup string need to be further parsed
@pGridData2.@pColWidths[i]=Val(strFieldData(0)) ' for the sub - sub-strings within them that use the ':' char as a delimiter.
@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)
If strFieldData(2)="<" Then
hdrItem.fmt= %HDF_LEFT
Else
If strFieldData(2)="^" Then
hdrItem.fmt=%HDF_CENTER
Else
hdrItem.fmt=%HDF_RIGHT
End If
End If
hdrItem.fmt=hdrItem.fmt Or %HDF_STRING
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
Select Case strFieldData(3)
Case "none"
@pGridData2.@pCellCtrlTypes[i]=0
Case "edit"
@pGridData2.@pCellCtrlTypes[i]=1
Case "combo"
@pGridData2.@pCellCtrlTypes[i]=2
Case "check"
@pGridData2.@pCellCtrlTypes[i]=3
End Select
#If %Def(%DEBUG)
Print #fp, " " i, @pGridData2.@pColWidths[i], iPos(i), szText, strFieldData(2), ,strFieldData(3), , @pGridData2.@pCellCtrlTypes[i]
#EndIf
Erase strFieldData()
Next i
#If %Def(%DEBUG)
Print #fp,
Print #fp, " i @pGridData2.@pCtrlHdls[i]"
Print #fp, " ==================================="
#EndIf
Local blnEditCreated,iCboCtr As Long '@pGridData2.hCtrlInCell is equal to the hWnd of the edit control
For i=0 To iCols-1 'created in fnGridProc_OnCreate(). Also, GridData::pCtrlHdls[i]
If @pGridData2.@pCellCtrlTypes[i]=%GRID_CELL_CTRL_EDIT Then 'hold the handles of the various edit or combo box controls.
If blnEditCreated=%False Then 'fnEditWndProc is the original edit control WndProc().
dwStyle=%WS_CHILD Or %ES_AUTOHSCROLL
@pGridData2.@pCtrlHdls[i]=CreateWindow("edit","",dwStyle,0,0,0,0,Wea.hWnd,%IDC_EDIT,Wea.hInst,ByVal 0)
@pGridData2.hCtrlInCell=@pGridData2.@pCtrlHdls[i]
blnEditCreated=%True
Else
@pGridData2.@pCtrlHdls[i]=@pGridData2.hCtrlInCell
End If
End If
If @pGridData2.@pCellCtrlTypes[i]=%GRID_CELL_CTRL_COMBO Then
dwStyle=%WS_CHILD Or %CBS_DROPDOWNLIST Or %WS_VSCROLL 'Or %CBS_NOINTEGRALHEIGHT
@pGridData2.@pCtrlHdls[i]=CreateWindow("combobox","",dwStyle,0,0,0,0,Wea.hWnd,%IDC_COMBO+iCboCtr,Wea.hInst,ByVal 0)
Incr iCboCtr
End If
#If %Def(%DEBUG)
Print #fp, " " i, @pGridData2.@pCtrlHdls[i]
#EndIf
Next i
@pGridData2.hCtrlInCell=0
#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 that go at far left in the grid, and which can be clicked to select a grid row
@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
Goto CleanUp
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 Grid Cells, i.e., "Cell" Class
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
@pGridData2.pTextColor=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
#If %Def(%DEBUG)
Print #fp, " @pGridData2.pTextColor = " @pGridData2.pTextColor
#EndIf
If @pGridData2.pTextColor=0 Then
Goto Cleanup
End If
@pGridData2.pBackColor=GlobalAlloc(%GPTR,iSize*%SIZEOF_PTR)
#If %Def(%DEBUG)
Print #fp, " @pGridData2.pBackColor = " @pGridData2.pBackColor
#EndIf
If @pGridData2.pBackColor=0 Then
Goto Cleanup
End If
@pGridData2.pCreatedColors=GlobalAlloc(%GPTR,(%MAX_COLORS+1)*%SIZEOF_PTR)
#If %Def(%DEBUG)
Print #fp, " @pGridData2.pCreatedColors = " @pGridData2.pCreatedColors
#EndIf
If @pGridData2.pCreatedColors=0 Then
Goto Cleanup
End If
@pGridData2.pCreatedBrushes=GlobalAlloc(%GPTR,(%MAX_COLORS+1)*%SIZEOF_PTR)
#If %Def(%DEBUG)
Print #fp, " @pGridData2.pCreatedBrushes = " @pGridData2.pCreatedBrushes
#EndIf
If @pGridData2.pCreatedBrushes=0 Then
Goto Cleanup
End If
Else
Goto CleanUp
End If
Erase strParseData()
Erase iPos()
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Leaving %WM_CREATE Case" : Print #fp,
#EndIf
Function=0 : Exit Function
CleanUp:
If @pGridData2.pColWidths Then
Call GlobalFree(@pGridData2.pColWidths)
End If
If @pGridData2.pCellCtrlTypes Then
Call GlobalFree(@pGridData2.pCellCtrlTypes)
End If
If @pGridData2.pCtrlHdls Then
Call GlobalFree(@pGridData2.pCtrlHdls)
End If
If @pGridData2.pVButtons Then
Call GlobalFree(@pGridData2.pVButtons)
End If
If @pGridData2.pCellHandles Then
Call GlobalFree(@pGridData2.pCellHandles)
End If
If @pGridData2.pGridMemory Then
Call GlobalFree(@pGridData2.pGridMemory)
End If
If @pGridData2.pTextColor Then
Call GlobalFree(@pGridData2.pTextColor)
End If
If @pGridData2.pBackColor Then
Call GlobalFree(@pGridData2.pBackColor)
End If
If @pGridData2.pCreatedColors Then
Call GlobalFree(@pGridData2.pCreatedColors)
End If
If @pGridData2.pCreatedBrushes Then
Call GlobalFree(@pGridData2.pCreatedBrushes)
End If
If pGridData2 Then
Call GlobalFree(pGridData2)
End If
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Leaving %WM_CREATE Case" : Print #fp,
#EndIf
Function=-1
End Function
continued ...
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
#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, " 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 IGrid_FlushData(@pGridData.pComObj)
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 As Long
iNum=@pGridData.iCols*(si.nPos-1)
iLast=(@pGridData.iCols * @pGridData.iVisibleRows) - 1
For i=0 To iLast
hCell=@pGridData.@pCellHandles[i]
Call SetWindowLong(hCell,0,@pGridData.@pGridMemory[iNum])
Call SetWindowLong(hCell,8,@pGridData.@pTextColor[iNum])
Call SetWindowLong(hCell,12,@pGridData.@pBackColor[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 pGrid As CGrid Ptr
Local si As SCROLLINFO
Register i As Long
#If %Def(%DEBUG)
Print #fp,
Print #fp, " Entering fnGridProc_OnCommand()"
Prnt ""
Prnt "Entering fnGridProc_OnCommand()"
Print #fp, " Lowrd(Wea.wParam) = " Lowrd(Wea.wParam)
#EndIf
If Lowrd(Wea.wParam)>20000 Then
pGridData=GetWindowLong(Wea.hWnd,0)
pGrid=@pGridData.pComObj
#If %Def(%DEBUG)
Prnt " pGridData = " & Str$(pGridData)
Prnt " @pGridData.pComObj = " & Str$(@pGridData.pComObj)
Prnt " pGrid = " & Str$(pGrid)
Prnt ""
Prnt " i pGrid.@pISink[i] @pGrid.@pISink[i]"
Prnt " ========================================="
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call IGrid_FlushData(@pGridData.pComObj)
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
#If %Def(%DEBUG)
Prnt " Lowrd(Wea.wParam) = " & Str$(Lowrd(Wea.wParam))
Prnt " iGridRow = " & Str$(iGridRow)
#endIf
If @pGridData.blnRowSelected Then
#If %Def(%DEBUG)
Print #fp, " We Got In Where @pGridData.blnSelected = %True!"
Prnt " We Got In Where @pGridData.blnSelected = %True!"
#EndIf
If iGridRow=@pGridData.iSelectedRow Then 'Same button clicked twice, i.e., toggled, or user wishes to unselect a row
#If %Def(%DEBUG)
Print #fp, " We Got In Where iGridRow = @pGridData.iSelectedRow!"
Prnt " We Got In Where iGridRow = @pGridData.iSelectedRow!"
#EndIf
For i=1 To @pGridData.iCols
Call IGrid_SetCellAttributes(@pGridData.pComObj,@pGridData.iSelectedRow,i,&H00FFFFFF,0) '''Here
Next i
@pGridData.iSelectedRow=0 : @pGridData.blnRowSelected=%False
Else
#If %Def(%DEBUG)
Print #fp, " We Got In Where iGridRow <> @pGridData.iSelectedRow!"
Prnt " We Got In Where iGridRow <> @pGridData.iSelectedRow!"
#EndIf
For i=1 To @pGridData.iCols
Call IGrid_SetCellAttributes(@pGridData.pComObj,@pGridData.iSelectedRow,i,&H00FFFFFF,0) '''Here
Next i
@pGridData.iSelectedRow=iGridRow
For i=1 To @pGridData.iCols
Call IGrid_SetCellAttributes(@pGridData.pComObj,iGridRow,i,@pGridData.iSelectionBackColor,@pGridData.iSelectionTextColor) '''Here
Next i
End If
Else
#If %Def(%DEBUG)
Prnt " We Got In Where @pGridData.blnSelected = %False!"
Print #fp, " We Got In Where @pGridData.blnSelected = %False!"
Print #fp, " @pGridData.iSelectionBackColor = " Hex$(@pGridData.iSelectionBackColor)
Print #fp, " @pGridData.iSelectionTextColor = " Hex$(@pGridData.iSelectionTextColor)
#EndIf
For i=1 To @pGridData.iCols
'Call IGrid_SetCellAttributes(@pGridData.pComObj,iGridRow,i,%Red,%White) '''Here
Call IGrid_SetCellAttributes(@pGridData.pComObj,iGridRow,i,@pGridData.iSelectionBackColor,@pGridData.iSelectionTextColor)
Next i
@pGridData.blnRowSelected=%True
@pGridData.iSelectedRow=iGridRow
#If %Def(%DEBUG)
Prnt " @pGridData.iSelectedRow = " & Str$(@pGridData.iSelectedRow)
Prnt " @pGridData.blnRowSelected = " & Str$(@pGridData.blnRowSelected)
#EndIf
End If
Call IGrid_Refresh(@pGridData.pComObj)
'Declare Function ptrRowSelection(Byval this As Dword Ptr, Byval iRow As Long, Byval iAction As Long) As Long
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[8] Using ptrRowSelection(dwPtr, iGridRow, @pGridData.blnRowSelected) To hr
#If %Def(%DEBUG)
If SUCCEEDED(hr) Then
Prnt " Call Dword @Vtbl[8] Using ptrRowSelection() Succeeded!"
Prnt " @pGridData.blnRowSelected = " & Str$(@pGridData.blnRowSelected)
End If
#EndIf
End If
Next i
Call SetFocus(Wea.hWnd)
End If
#If %Def(%DEBUG)
Print #fp, " Leaving fnGridProc_OnCommand()"
Prnt "Leaving fnGridProc_OnCommand()"
Prnt ""
Print #fp,
#EndIf
Function=0
End Function
Function fnGridProc_OnKeyDown(Wea As WndEventArgs) As Long
Local pGridData As GridData Ptr
Local dwPtr,VTbl As Dword Ptr
Local pGrid As CGrid Ptr
Register i As Long
Local hr As Long
If Wea.wParam=%VK_DELETE Then
pGridData=GetWindowLong(Wea.hWnd,0)
pGrid=@pGridData.pComObj
#If %Def(%DEBUG)
Prnt "Entering fnGridProc_OnKeyDown()"
#EndIf
If @pGridData.blnRowSelected=%True Then
#If %Def(%DEBUG)
Prnt " A Row Is Selected! The Selected Row Is " & Str$(@pGridData.iSelectedRow)
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i] Then
dwPtr=@pGrid.@pISink[i]
VTbl=@dwPtr
Call Dword @Vtbl[9] Using ptrDelete(dwPtr, @pGridData.iSelectedRow) To hr
End If
Next i
Call IGrid_Refresh(@pGridData.pComObj)
Else
#If %Def(%DEBUG)
Prnt " No Row Is Selected!"
#EndIf
End If
#If %Def(%DEBUG)
Prnt "Leaving fnGridProc_OnKeyDown()"
#EndIf
End If
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
Print #fp, " @pGridData.pCellCtrlTypes = " @pGridData.pCellCtrlTypes
'Grid Row Memory
Print #fp,
Print #fp, " i j iCtr strCoordinate pMem pBackColor[i] pTextColor[i]"
Print #fp, " ============================================================================================================"
iCtr=0
For i=1 To @pGridData.iRows
For j=1 To @pGridData.iCols
pMem=@pGridData.@pGridMemory[iCtr]
Print #fp, " " i,j,iCtr,@pMem Tab(72) pMem, Hex$(@pGridData.@pBackColor[iCtr]), Hex$(@pGridData.@pTextColor[iCtr])
Incr iCtr
Next j
Next i
#EndIf
blnFree=GlobalFree(@pGridData.pColWidths)
#If %Def(%DEBUG)
Print #fp,
Print #fp, " blnFree(pColWidths) = " blnFree
#EndIf
If @pGridData.pCellCtrlTypes Then
blnFree=GlobalFree(@pGridData.pCellCtrlTypes)
#If %Def(%DEBUG)
Print #fp, " blnFree(pCellCtrlTypes) = " blnFree
#EndIf
End If
If @pGridData.pCtrlHdls Then
blnFree=GlobalFree(@pGridData.pCtrlHdls)
#If %Def(%DEBUG)
Print #fp, " blnFree(pCtrlHdls) = " blnFree
#EndIf
End If
If @pGridData.hFont Then
blnFree=DeleteObject(@pGridData.hFont)
#If %Def(%DEBUG)
Print #fp, " blnFree(hFont) = " blnFree
#EndIf
End If
#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.pTextColor)
#If %Def(%DEBUG)
Print #fp,
Print #fp, " blnFree(@pGridData.pTextColor) = " blnFree
#EndIf
blnFree=GlobalFree(@pGridData.pBackColor)
#If %Def(%DEBUG)
Print #fp, " blnFree(@pGridData.pBackColor) = " blnFree
#EndIf
#If %Def(%DEBUG)
Print #fp,
Print #fp, " @pGridData.@pCreatedBrushes[0] = " @pGridData.@pCreatedBrushes[0]
Print #fp, " @pGridData.@pCreatedColors[0] = " @pGridData.@pCreatedColors[0]
Print #fp,
Print #fp, " i DeleteObject(i)"
Print #fp, " =========================="
#EndIf
For i=1 To @pGridData.@pCreatedBrushes[0]
If @pGridData.@pCreatedBrushes[i] Then
blnFree=DeleteObject(@pGridData.@pCreatedBrushes[i])
#If %Def(%DEBUG)
Print #fp, " " i, blnFree
#EndIf
End If
Next i
blnFree=GlobalFree(@pGridData.pCreatedColors)
#If %Def(%DEBUG)
Print #fp,
Print #fp, " blnFree(@pGridData.pCreatedColors) = " blnFree
#EndIf
blnFree=GlobalFree(@pGridData.pCreatedBrushes)
#If %Def(%DEBUG)
Print #fp,
Print #fp, " blnFree(@pGridData.pCreatedBrushes) = " blnFree
#EndIf
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 6
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(6) 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(6).wMessage=%WM_KEYDOWN : MsgHdlr(6).dwFnPtr=CodePtr(fnGridProc_OnKeyDown)
MsgHdlr(5).wMessage=%WM_COMMAND : MsgHdlr(5).dwFnPtr=CodePtr(fnGridProc_OnCommand)
MsgHdlr(4).wMessage=%WM_DESTROY : MsgHdlr(4).dwFnPtr=CodePtr(fnGridProc_OnDestroy)
End Sub
Sub Initialize()
Local uCC As INIT_COMMON_CONTROLSEX
Local szClassName As ZStr*16
Local wc As WNDCLASSEX
#If %Def(%DEBUG)
Prnt " Entering Initialize() -- Initialize()"
#EndIf
uCC.dwSize = SizeOf(uCC)
uCC.dwICC = %ICC_LISTVIEW_CLASSES
Call InitCommonControlsEx(uCC)
szClassName="Cell"
wc.lpszClassName=VarPtr(szClassName) : wc.lpfnWndProc=CodePtr(fnCellProc)
wc.cbSize=SizeOf(wc) : wc.style=0
wc.cbClsExtra=0 : wc.cbWndExtra=16
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
Call RegisterClassEx(wc)
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
Call RegisterClassEx(wc)
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
Call RegisterClassEx(wc)
szClassName="Grid"
wc.lpszClassName=VarPtr(szClassName) : wc.lpfnWndProc=CodePtr(fnGridProc)
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(%DKGRAY_BRUSH)
wc.lpszMenuName=%NULL
#If %Def(%DEBUG)
Prnt " GetModuleHandle() = " & Str$(wc.hInstance)
#EndIf
Call RegisterClassEx(wc)
Call AttachMessageHandlers()
#If %Def(%DEBUG)
Prnt " Leaving Initialize()"
#EndIf
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
Register i As Long
#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
#If %Def(%DEBUG)
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call DestroyWindow(@pGrid.hWndCtrl)
#If %Def(%DEBUG)
Prnt " @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
#EndIf
Call CoTaskMemFree(@pGrid.@pISink) ' Or, Less Insane ... Call CoTaskMemFree(Byval @pGrid.pISink)
Call CoTaskMemFree(@this) ' Or, Less Insane ... Call CoTaskMemFree(Byval 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
continued ...
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
#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
Function=IConnectionPointContainer_QueryInterface(this, $IID_IConnectionPoint, ppCP)
#If %Def(%DEBUG)
Prnt " @ppCP = " & Str$(@ppCP)
Prnt " Leaving IConnectionPointContainer_FindConnectionPoint()" : Prnt ""
#EndIf
Else
#If %Def(%DEBUG)
Prnt " Got Where I Shouldn't Have Gotten!!!"
Prnt " Leavinging IConnectionPointContainer_FindConnectionPoint()"
#EndIf
Function=%E_NOINTERFACE
End If
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)
#If %Def(%DEBUG)
Prnt " Looking For IID_IUnknown"
Prnt " Leaving IConnectionPoint_QueryInterface()"
#EndIf
Function=%S_OK : Exit Function
Case $IID_IFHGrid
Decr this : Decr this
@ppv=this
Call IGrid_AddRef(this)
#If %Def(%DEBUG)
Prnt " Looking For IID_IFHGrid"
Prnt " Leaving IConnectionPoint_QueryInterface()"
#EndIf
Function=%S_OK : Exit Function
Case $IID_IConnectionPointContainer
Decr this
@ppv=this
Call IConnectionPointContainer_AddRef(this)
#If %Def(%DEBUG)
Prnt " Looking For IID_IConnectionPointContainer"
Prnt " Leaving IConnectionPoint_QueryInterface()"
#EndIf
Function=%S_OK : Exit Function
Case $IID_IConnectionPoint
@ppv=this
Call IConnectionPoint_AddRef(this)
#If %Def(%DEBUG)
Prnt " Looking For IID_IConnectionPoint"
Prnt " Leaving IConnectionPoint_QueryInterface()"
#EndIf
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
Register i As Long
#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
#If %Def(%DEBUG)
For i=0 To %MAX_CONNECTIONS-1
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
Next i
#EndIf
Call DestroyWindow(@pGrid.hWndCtrl)
#If %Def(%DEBUG)
Prnt " @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
#EndIf
Call CoTaskMemFree(@pGrid.@pISink) ' Or, Less Insane ... Call CoTaskMemFree(Byval @pGrid.pISink)
Call CoTaskMemFree(@this) ' Or, Less Insane ... Call CoTaskMemFree(Byval 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 blnFoundOpenSlot As Long
Local Vtbl,dwPtr As Dword Ptr
Local pGrid As CGrid Ptr
Register i As Long
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)
#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
If SUCCEEDED(hr) Then
#If %Def(%DEBUG)
Prnt " Call Dword Succeeded!"
#EndIf
For i=0 To %MAX_CONNECTIONS-1
If @pGrid.@pISink[i]=0 Then
blnFoundOpenSlot=%True
#If %Def(%DEBUG)
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i]) & " Found Open Slot!"
#EndIf
Exit For
Else
#If %Def(%DEBUG)
Prnt " " & Str$(i) & " " & Str$(Varptr(@pGrid.@pISink[i])) & " " & Str$(@pGrid.@pISink[i])
#EndIf
End If
Next i
If blnFoundOpenSlot Then
#If %Def(%DEBUG)
Prnt " Will Be Able To Store Connection Point!"
#EndIf
@pGrid.@pISink[i]=dwPtr
@pdwCookie=i
hr=%S_Ok
Else
@pdwCookie=0
hr=%CONNECT_E_ADVISELIMIT
End If
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)
Prnt " dwCookie = " & Str$(dwCookie)
#EndIf
Decr this : Decr this
pGrid=this
#If %Def(%DEBUG)
Prnt " @pGrid.hWndCtrl = " & Str$(@pGrid.hWndCtrl)
#EndIf
dwPtr=@pGrid.@pISink[dwCookie]
Vtbl=@dwPtr
#If %Def(%DEBUG)
Prnt " dwPtr = " & Str$(dwPtr)
#EndIf
Call Dword @Vtbl[2] Using ptrRelease(dwPtr) To iReturn
If SUCCEEDED(iReturn) Then
@pGrid.@pISink[dwCookie]=0
#If %Def(%DEBUG)
Prnt " IGrid_Events::Release() Succeeded!"
#EndIf
End If
#If %Def(%DEBUG)
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
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.pISink=CoTaskMemAlloc(%MAX_CONNECTIONS * %SIZEOF_PTR)
If @pGrid.pISink Then
Poke Dword, @pGrid.pISink, 0, 0, 0, 0 'Call memset(Byval @pGrid.pISink,0,%MAX_CONNECTIONS*%SIZEOF_PTR)
@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))
Prnt " @pGrid.pISink = " & Str$(@pGrid.pISink)
#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(Byval pGrid)
End If
Else
Call CoTaskMemFree(Byval pGrid)
hr=%E_OutOfMemory
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
hr=IClassFactory_QueryInterface(VarPtr(CDClassFactory),iid,pClassFactory)
If FAILED(hr) Then
pClassFactory=0
hr=%CLASS_E_CLASSNOTAVAILABLE
Else
Call Initialize()
#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 'Original
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 'Original
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, Byval 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
#If %Def(%DEBUG)
Print #fp, " Entering UnRegisterServer()"
Print #fp, " szVerIndProgID = " szVerIndProgID
Print #fp, " szProgID = " szProgID
#EndIf
szClsid=GuidTxt$(ClassId)
If szClsid<>"" Then
szKey="CLSID\"+szClsid
lResult=RecursiveDeleteKey(%HKEY_CLASSES_ROOT,szKey)
If lResult<>%ERROR_SUCCESS Then
#If %Def(%DEBUG)
Print #fp, " Got In Where RecursiveDeleteKey() Failed!"
Print #fp, " Leaving UnregisterServer()"
#EndIf
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
#If %Def(%DEBUG)
Print #fp, " Leaving UnregisterServer()"
#EndIf
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 pTypeLib,Vtbl As Dword Ptr
Local hr,iBytesReturned As Long
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)
strWideCharPath=szPath
#Else
strAsciPath=szPath
strWideCharPath=UCode$(strAsciPath & $Nul)
#EndIf
hr=LoadTypeLibEx(Byval Strptr(strWideCharPath), %REGKIND_REGISTER, pTypeLib)
If SUCCEEDED(hr) Then
#If %Def(%DEBUG)
Print #fp, " LoadTypeLib() Succeeded!"
#EndIf
Vtbl=@pTypeLib
Call Dword @Vtbl[2] Using ptrRelease(pTypeLib)
szFriendlyName = "Fred Harris Grid Control v8"
szVerIndProgID = "FHGrid8.Grid"
szProgID = "FHGrid8.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
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
#If %Def(%DEBUG)
Print #fp, " Entering DllUnrrgisterServer()"
#EndIf
hr=UnRegisterTypeLib($IID_LIBID_FHGrid, 1, 0, %LANG_NEUTRAL, %SYS_WIN32)
If SUCCEEDED(hr) Then
szVerIndProgID = "FHGrid8.Grid"
szProgID = "FHGrid8.Grid.1"
hr=UnregisterServer($CLSID_FHGrid, szVerIndProgID, szProgID)
#If %Def(%DEBUG)
Print #fp, " Got In Where UnRegisterTypeLib() Succeeded!"
#EndIf
Else
#If %Def(%DEBUG)
Print #fp, " Got In Where UnRegisterTypeLib() Failed!"
#EndIf
End If
#If %Def(%DEBUG)
Print #fp, " Leaving DllUnrrgisterServer()"
#EndIf
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\v8\Output.txt" For Output As #fp
Print #fp, "Entering DllMain() -- %DLL_PROCESS_ATTACH"
#EndIf
Call DisableThreadLibraryCalls(hInstance)
g_hModule = hInstance
g_CtrlId = 1500
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.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)
IGrid_Vtbl.GethComboBox = CodePtr(IGrid_GethComboBox)
IGrid_Vtbl.SetCellAttributes = CodePtr(IGrid_SetCellAttributes)
IGrid_Vtbl.DeleteRow = Codeptr(IGrid_DeleteRow)
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)
Case %DLL_PROCESS_DETACH
#If %Def(%DEBUG)
Print #fp, "Leaving DllMain() -- %DLL_PROCESS_DETACH"
Close #fp
#EndIf
End Select
DllMain=%TRUE
End Function
Here is the FHGrid8.idl file which the midl compiler needs to create the type library file FHGrid8.tlb ...
// fhGrid8.idl
import "unknwn.idl";
[object, uuid(20000000-0000-0000-0000-000000000085), oleautomation] interface IGrid : IUnknown
{
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] int iSelectionBackColor,
[in] int iSelectionTextColor,
[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);
HRESULT GethComboBox([in] int iCol, [out, retval] int* hCombo);
HRESULT SetCellAttributes([in] int iRow, [in] int iCol, [in] int iBackColor, [in] int iTextColor);
HRESULT DeleteRow([in] int iRow);
};
[object, uuid(20000000-0000-0000-0000-000000000086), oleautomation] interface IGridEvents : IUnknown
{
HRESULT Grid_OnKeyPress([in] int iKeyCode, [in] int iKeyData, [in] int iRow, [in] int iCol, [out] int* blnCancel);
HRESULT Grid_OnKeyDown([in] int KeyCode, [in] int iKeyData, [in] int iRow, [in] int iCol, [out] int* blnCancel);
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_OnRowSelection([in] int iRow, [in] int iAction);
HRESULT Grid_OnDelete([in] int iRow);
};
[uuid(20000000-0000-0000-0000-000000000087), helpstring("FHGrid8 TypeLib"), version(1.0)] library FHGrid8Library
{
importlib("stdole32.tlb");
interface IGrid;
interface IGridEvents;
[uuid(20000000-0000-0000-0000-000000000084)] coclass FHGrid8
{
interface IGrid;
[source] interface IGridEvents;
}
};
I'll attach the FHGrid8.tlb file.
If you want to create the dll to follow along here you'll need the FHGrid8.tlb file, because the 16th line of the dll's code references it as follows ...
#Resource Typelib, 1, "FHGrid8.tlb"
That line causes the type library to be written into the dll itself. After compiling the dll you'll have to register it with RegSvr32.
' PBClient1.bas
'
' The program below creates an instance of the grid and uses PowerBASIC's WithEvents methodology
' to set up the event handling class and sink. There is a button on the form that retrieves
' whatever is in cell 3, 2. Another button colors several rows in the grid several different
' colors. You select a row by clicking one of the small vertical aligned buttons at far left
' in the grid adjacent to the row you want to select. Clicking the same button de-selects it.
' Clicking a different button changes the selection. When a row is selected you can delete
' the row by using the [Delete] key. In this example a combo box with several strings in it
' were added to the 5th row.
'
#Compile Exe "PBClient1.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Using PowerBASIC Includes.
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
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient1","PBClient1")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pVnt As Variant Ptr
Local pGrid As IGrid
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long ' Offset Item
Local pCreateStruct As CREATESTRUCT Ptr ' =======================================
Local strSetup,strCoordinate As BStr ' 0 - 3 IGrid Ptr - pGrid
Local pSink As IGridEvents ' 4 - 7 IGridEvents Ptr - pSink
Local pVnt As Variant Ptr ' 8 - 11 Store Current Selected Row
Local szName As ZStr*16
Local pGrid As IGrid ' In your typical Windows GUI program its certainly not necessary or desirable to
Local hCtl As Dword ' store the Window Handles of child window controls at global scope. Afterall,
Register i As Long ' one can always obtain the window handle ( HWND ) of a child window control through
Register j As Long ' its control id using the GetDlgItem() function, whose only parameters are the parent
' window handle and the control id of the desired child window control. What you don't
Call AllocConsole() ' need to worry about when you adorn your GUI programs with child window controls is
Prnt "Entering fnWndProc_OnCreate()" ' that Windows will prematurely and randomly destroy them for you after their creation.
pCreateStruct=wea.lParam ' If you decide to include ActiveX Controls in your program though, excrutiating
wea.hInst=@pCreateStruct.hInstance ' difficulties can arise if you attempt to deal with them in as caviliar a fashion as you
Let pGrid = NewCom "FHGrid8.Grid" ' might with a standard Windows control such a a text box or combo box - or even a
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid)) ' Common Control such as a Progress Bar or Calendar Control. The problem is that these
pVnt=GlobalAlloc(%GPTR, 16) ' things are 'reference counted' within your client program code, and if you don't
@pVnt=pGrid 'assign interface to variant ' declare their object variables at global scope, you risk having the compiler's garbage
Call SetWindowLong(Wea.hWnd,0,pVnt) ' collection code deallocate and destroy these things as local stack based objects. For
strSetup= _ ' example, just left PowerBASIC's NewCom statement is used in this WM_CREATE handler to
"120:Column 1:^:edit," & _ ' instantiate a my grid control. However, note that the pGrid variable of type IGrid
"130:Column 2:^:edit," & _ ' is declared as a local in this procedure. In fact this whole program has no global
"140:Column 3:^:edit," & _ ' variables, aside from possibly MsgHdlr(), which actually doesn't hold variables, but
"150:Column 4:^:edit," & _ ' rather constants, i.e., names of Windows Messages, and the addresses of the message
"160:Column 5:^:combo" ' handling function which handles each respective message. So, getting back to pGrid,
pGrid.CreateGrid _ ' which is actually a local interface pointer, if NewCom() succeeds in creating the
( _ ' grid control, QueryInterface() code within the grid dll will call AddRef() on the
Wea.hWnd, _ ' HWND of Parent ' pointer before it is returned to this code here, and that will set the reference count
strSetup, _ ' Setup String For Grid ' to one. However, being as pGrid is a local object variable, the PowerBASIC compiler
190, _ ' Top Left Corner x ' will call a Release() on the pointer at procedure termination in its effort to prevent
10, _ ' Top Left Corner y ' memory leaks. What it will do here with this object variable isn't conceptually any
570, _ ' Grid Width ' different than what it would do with a locally allocated String or WString object.
218, _ ' Grid Height ' Any memory it allocated to store a local string would be released after the procedure
12, _ ' # Rows Data In Grid ' exits. It really has to do this or your program would 'eat' memory until it crashed
5, _ ' # Columns In Grid ' the system. The problem with that behavior here is that a Release() call on the local
28, _ ' Row Ht In Pixels ' IGrid pointer pGrid will cause our reference count of one ( 1 ) to fall to zero ( 0 ),
0, _ ' Cell Back Color ' and when that happens COM objects automatically deallocate and destroy themselves! So
0, _ ' Cell Text Color ' what would happen here in that case is that the grid would be successfully created in
"Times New Roman", _ ' Font Name ' this WM_CREATE handler, but the user of this program would never see it, as nothing
18, _ ' Font Size ' that takes place during or immediately after a WM_CREATE call is visible to the user.
%FW_DONTCARE _ ' Font Weight ' Only after WM_PAINT does a window/app become visible to the user, and by that time, in
) ' relative computer time terms, the grid would have been long dead. The only answer
Let pSink = Class "CGridEvents" ' to this dilema, other than making the COM based control a global, is to store the valid
Events From pGrid Call pSink ' interface pointer somewhere, and 'artifically' increment its reference count so that
pVnt=GlobalAlloc(%GPTR, 16) ' PowerBASIC's garbage collection of local stack based objects won't allow the reference
@pVnt=pSink ' count to fall to zero, which condition causes the object to destroy itself. That is
Call SetWindowLong(Wea.hWnd,4,pVnt) ' exactly what you are seeing take place in this code upper left where a Variant Ptr object
For i=1 To 12 ' named pVnt is pointed at a dynamically allocated 16 byte chunk of memory where a Variant
For j=1 To 5 ' can be stored. Into that variant memory our pGrid interface pointer is stored with the
strCoordinate= _ ' statement @pVnt=pGrid. This line has a very interesting side effect. PowerBASIC
"(" & Trim$(Str$(i)) & _ ' interprets the equal operator ( = ) as a QueryInterface() call on the object for in this
"," & Trim$(Str$(j)) & ")" ' case the IUnknown of the object. This will cause a second AddRef() call on the object,
pGrid.SetData(i, j, strCoordinate) ' and that will bump the reference count to two ( 2 ). If you create the grid dll and
Next j ' compile and run this code, you'll easily see this in the voluminous console output
Next i ' produced by a run of the code. The net effect of this is that the compiler's clean up
pGrid.Refresh() ' of the local IGrid object pGrid at procedure termination will only cause the reference
hCtl=CreateWindow _ ' count on the object to fall to one ( 1 ) - not zero ( 0 ). The grid will keep itself
( _ ' in memory and you'll see and be able to use it. While its address held in pGrid will
"button", _ ' go out of scope, you'll note above that it was saved in the WNDCLASSEX::cbWndExtra bytes
"Retrieve Cell (3,2)", _ ' by a call to SetWindowLong() right after the variant assignment.
%WS_CHILD Or %WS_VISIBLE, _
10, _ ' The remainder of this procedure attaches the event sink to the grid, and creates some
20, _ ' buttons which exercise the grid in various self-explanatory ways. Also, the combo box
150, _ ' established in the fifth column of the grid is loaded with a few strings. One of the
30, _ ' grid methods returns a handle to the combo box the grid created within itself if you
Wea.hWnd, _ ' pass into the call the column ( 5 ) of the grid where the handle is you want.
%IDC_RETRIEVE, _
Wea.hInst, _
ByVal 0 _
)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5)
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs) ' Entering fnWndProc_OnDestroy() ' DestroyGrid() is called by either clicking the 'Unload Grid'
Local pSink As IGridEvents ' Entering DestroyGrid() ' button on the main form, or by 'x' ing out from the Title Bar.
Local pVnt As Variant Ptr ' pSink = 2896540 ' The output just left is from a program run where I just
Local pGrid As IGrid ' ' started the program, then immediately x'ed out to get the
Local iCnt As Long ' Entering IGrid_QueryInterface() ' debug console output. At this point I don't have too much to
' Trying To Get IFHGrid ' say about Release() 'ing the sink. Let's move down to the
Prnt " Entering DestroyGrid()" ' Entering IGrid_AddRef() ' Release() of the grid pointer stored at offset zero ( 0 ) in
' First, Release Sink ... ' @pGrid.m_cRef = 1 << Before ' the WNDCLASSEX::cbWndExtra bytes.
pVnt=GetWindowLong(Wea.hWnd,4) ' @pGrid.m_cRef = 2 << After
If pVnt Then ' Leaving IGrid_AddRef() ' First, a GetWindowLong() call retrieves the pointer to the
pSink=@pVnt ' this = 6815312 ' varient stored at offset zero in the .cbWndExtra bytes. Then
Prnt " pSink = " & Str$(ObjPtr(pSink)) ' Leaving IGrid_QueryInterface() ' the object stored in the Variant is copied to an IGrid pointer
If IsObject(pSink) Then ' ' pGrid. That's what caused the 'Entering IGrid_QueryInterface()'
Events End pSink ' pGrid = 6815312 ' call just a few lines up from here just left. Notice that from
Set pSink=Nothing ' ' within the dll we are being told that an IGrid pointer is being
End If ' Entering IGrid_Release() ' requested. The grid's QueryInterface() can satisfy that request,
Call SetWindowLong(Wea.hWnd,4,0) ' @pGrid.m_cRef = 2 << Before ' and so the pointer is returned, and an AddRef() is called on the
Call GlobalFree(pVnt) ' @pGrid.m_cRef = 1 << After ' pointer, which now brings up the reference count on the object
Else ' Leaving IGrid_Release() ' up to two ( 2 ). The first would be the pointer stored in the
Prnt " pSink Was Already Released!" ' ' .cbWndExtra bytes up in WM_CREATE, and the second would be the
End If ' iCnt = 1 ' local reference just stored in the local pGrid pointer here in
' Leaving DestroyGrid() ' DestroyGrid(). Then, right after the IsObject(pGrid) test on
' Then, Release Grid ... ' ' pGrid we see a Release() call - Call pGrid.Release(). Let's
pVnt=GetWindowLong(Wea.hWnd,0) ' Entering IGrid_Release() ' consider that call to be a release or undoing of the storage of
If pVnt Then ' @pGrid.m_cRef = 1 << Before ' the IGrid pointer up in the WM_CREATE handler where we put it in
pGrid=@pVnt ' 0 6810520 2896540 ' the WNDCLASSEX::cbWndExtra bytes. That call brings our reference
Prnt " pGrid = " & Str$(ObjPtr(pGrid)) ' 1 6810524 0 ' count on the grid down to one ( 1 ). Notice that in the remainder
If IsObject(pGrid) Then ' 2 6810528 0 ' of the DestroyGrid() procedure there are no more calls from the
Call pGrid.Release() To iCnt ' 3 6810532 0 ' pGrid pointer. Its still valid and the object is still alive;
Prnt " iCnt = " & Str$(iCnt) ' @pGrid.m_cRef = 0 << After ' but we're just taking care of other housekeeping chores. The
Call SetWindowLong(Wea.hWnd,0,0) ' Grid Was Deleted! ' procedure then exits and we get a message to that effect. But
End If ' Leaving IGrid_Release() ' then look what happens immediately! There is a call from within
Call GlobalFree(pVnt) ' ' the grid of 'IGrid_Release(). Now what caused that call? What
Else ' Entering DllCanUnloadNow() ' caused it is the PowerBASIC compiler generated clean up code
Prnt " pGrid Was Already Released!" ' I'm Outta Here! (dll is unloaded) ' cleaning up the local stack variables of the DestroyGrid()
End If ' Leaving DllCanUnloadNow() ' function. One of those locals was an IGrid pointer holding a
Prnt " Leaving DestroyGrid()" ' Leaving fnWndProc_OnDestroy() ' valid address. The compiler calls the Release(), knocking back
End Sub ' the reference count to zero, and the grid destroys itself....
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long ' ... What is about as interesting if you look down in
Local pVnt As Variant Ptr ' fnWndProc_OnDestroy() is a call to CoFreeUnusedLibraries() right
Local strData As BStr ' after the call to DestroyGrid() which we just exited. Note that
Local pGrid As IGrid ' we're still in the fnWndProc_OnDestroy() handler tripped by the
Local dwPtr As Dword ' click of the 'x' button the close the window. Anyway, the
Local iCnt As Long ' CoFreeUnusedLibraries() Api call queries the system for any dlls
Register i As Long ' laying around taking up memory that aren't being used by any
' program, i.e., they don't have any active clients. COM Dlls
Select Case As Long Lowrd(Wea.wParam) ' maintain a couple internal counters to track this. There is a
Case %IDC_RETRIEVE ' counter for locks and a counter for live objects. At this point
Prnt "Entering fnWndProc_OnCommand()" ' in the program both are at zero so DllCanUnloadNow() (an exported
Prnt " Case %IDC_RETRIEVE" ' Dll function) returns %S_OK and the system goes ahead and releases
pVnt=GetWindowLong(Wea.hWnd,0) ' the COM Dll itself. If you look inside that function in FHGrid8.bas
pGrid=@pVnt ' you'll see the 'I'm Outta Here!' phrase.
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient1"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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
' PBClient2.bas
'
' This version uses the built in IConnectionPointContainer and IConnectionPoint interfaces directly
' to set up the event sink. This actually seems to simplify the DestroyGrid() code. Here is the
' DestroyGrid() procedure ...
'
' Sub DestroyGrid(Wea As WndEventArgs)
' Local pConnectionPoint As IConnectionPoint
' Local pVnt As Variant Ptr
' Local dwCookie As Dword
' Local pGrid As IGrid
'
' Prnt " Entering DestroyGrid()"
' pVnt=GetWindowLong(Wea.hWnd,0) ' Coming Into This Procedure, The Reference Count Will Be Sitting At
' If pVnt Then ' One, Due To An IGrid Ptr Being Assigned To A Variant Up in WM_CREATE.
' pGrid=@pVnt ' Reference Count Increments To Two
' pConnectionPoint=pGrid ' Reference Count Increments To Three
' pGrid.Release() ' Reference Count Will Decrement To Two At This Point
' dwCookie=GetWindowLong(Wea.hWnd,4)
' Call pConnectionPoint.Unadvise(dwCookie) ' The Reference Count Of Two Will Be Decremented To Zero After This
' Call SetWindowLong(Wea.hWnd,0,0) ' Procedure Exits, because Both pGrid And pConnectionPoint Are Holding
' Call SetWindowLong(Wea.hWnd,4,0) ' Valid Local Pointers Yet; PowerBASIC Is Tracking This, And Will Call
' Call GlobalFree(pVnt) ' Releases() On Both Of Them When The Stack For DestroyGrid() Is
' Else ' Cleaned Up.
' Prnt " pGrid Was Already Released!"
' End If
' Prnt " Leaving DestroyGrid()"
' End Sub
'
' What this procedure does is retrieve the stored IGrid inteface pointer from the WNDCLASSEX::cbWndExtra bytes, and uses
' that pointer to query for an IConnectionPoint interface pointer. These two operations cause the reference count on
' the grid to increase to three. The first count derives from the initial storage of the IGrid pointer up in
' fnWndProc_OnCreate. The second derives from the assignment of that pointer to the local pGrid pointer in DestroyGrid().
' The third increment derives from the dynamic cast of the local IGrid pointer to the local IConnectionPoint pointer
' pConnectionPoint. This is accomplished internally through yet another QueryInterface() call on the grid. To see how
' this is happening, here is the console output from a run of the program where it was simply started and x'ed out of.
' I'll just show the close out code ...
' Entering fnWndProc_OnDestroy()
' Entering DestroyGrid()
' Entering IGrid_QueryInterface() ' <<< This line caused by this statement ... pGrid=@pVnt
' Trying To Get IFHGrid ' Since the grid can return an IFHGrid interface, AddRef()
' Entering IGrid_AddRef() ' will be called within the grid. That brings the reference
' @pGrid.m_cRef = 1 << Before ' count up to 2.
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_AddRef()
' this = 4849232
' Leaving IGrid_QueryInterface()
' Entering IGrid_QueryInterface() ' <<< This line caused by this statement ... pConnectionPoint=pGrid
' Trying To Get IConnectionPoint ' Since the grid can return an IConnectionPoint interface pointer,
' this = 4849232 ' AddRef() will be called yet again within the grid, and our reference
' Entering IConnectionPoint_AddRef() ' count now goes up to 3.
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 3 << After
' Leaving IConnectionPoint_AddRef()
' this = 4849240
' Leaving IGrid_QueryInterface()
' Entering IGrid_Release() ' <<< This line is caused by this statement ... pGrid.Release()
' @pGrid.m_cRef = 3 << Before ' Let us assume we're releasing the the IGrid interface pointer
' @pGrid.m_cRef = 2 << After ' we just copied/retrieved from the .cbWndExtra bytes. That will
' Leaving IGrid_Release() ' of course drop our reference count back to 2, and those 2 are
' Entering IConnectionPoint_Unadvise() ' the two local ones we just acquired in this procedure. We're not
' this = 4849240 ' going to anything with those two interface pointers in this version
' dwCookie = 0 ' of DestroyGrid() other than to use the IConnectionPoint pointer to
' @pGrid.hWndCtrl = 2753048 ' call the Unadvise() method of IConnectionPoint, which releases or
' dwPtr = 4010652 ' terminates the advisory relationship between the grid and the sink
' IGrid_Events::Release() Succeeded! ' object contained here in the client. Note we don't make anymore
' Release() Returned 0 ' Release() calls on the IGrid pointer pGrid or the IConnectionPoint
' Leaving IConnectionPoint_Unadvise() ' pointer pConnectionPoint, even though we still have two outstanding
' Leaving DestroyGrid() ' reference counts on the grid for those two objects. It almost looks
' Entering IGrid_Release() ' like we're just leaving them hanging, and finally we see a Leaving
' @pGrid.m_cRef = 2 << Before ' DestroyGrid() message. But then we immediately see two Release()
' @pGrid.m_cRef = 1 << After ' calls; the first for the IGrid interface and the second for the
' Leaving IGrid_Release() ' IConnectionPoint interface. Try to find in the code where those
' Entering IConnectionPoint_Release() ' calls came from. You won't. They didn't come from any code in
' @pGrid.m_cRef = 1 << Before ' this client. They were generated by code the PowerBASIC compiler
' 0 4844440 0 ' generated to clean up the local stack based interface pointers. Of
' 1 4844444 0 ' course, after the Release() on pConnectionPoint is called the
' 2 4844448 0 ' reference count on the grid falls to 0 and the object deletes
' 3 4844452 0 ' itself (see just left).
' @pGrid.m_cRef = 0 And Will Now Delete pGrid!
' Leaving IConnectionPoint_Release()
' Entering DllCanUnloadNow()
' I'm Outta Here! (dll is unloaded)
' Leaving DllCanUnloadNow()
' Leaving fnWndProc_OnDestroy()
' The next line you see in the console output above is 'Entering DllCanUnloadNow()'. That is a COM Dll export and you'll
' find that procedure in the FHGrid8.bas code. What triggered it was a call to CoFreeUnusedLibraries() I made down in
' fnWndProc_OnDestroy(). So you won't get too confused here is that procedure from the client app below ...
' Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
' Prnt "Entering fnWndProc_OnDestroy()"
' Call DestroyGrid(Wea)
' Call CoFreeUnusedLibraries()
' Call PostQuitMessage(0)
' Prnt "Leaving fnWndProc_OnDestroy()"
' Function=0
' End Function
'
' Don't lose sight of the fact that the reason we were in the DestroyGrid() procedure above is that somebody clicked the
' little "x" button to close out the app, and that triggered a WM_DESTROY message, and fnWndProc_OnDestroy() above is the
' handler for that message. That's where DestroyGrid() got called, and its also where CoFreeUnusedLibraries() is located.
' CoFreeUnusedLibraries() calls all the Dlls in memory and asks them if they can be unloaded. It does this by calling
' each Dll's DllCanUnloadNow() exported function. If that function returns %S_OK, Windows unloads the Dll. That's what
' happened above. Here's the whole program listing...
#Compile Exe "PBClient2.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Uses PowerBASIC Includes
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
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient2","PBClient2")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pVnt As Variant Ptr
Local pGrid As IGrid
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long ' Offset Item
Local pConnectionPointContainer As IConnectionPointContainer ' =============================
Local pConnectionPoint As IConnectionPoint ' 0 - 3 IGrid Ptr - pGrid
Local pCreateStruct As CREATESTRUCT Ptr ' 4 - 7 dwCookie
Local strSetup,strCoordinate As BStr ' 8 - 11 iSelectedRow
Local pSink As IGridEvents
Local pVnt As Variant Ptr
Local EventGuid As Guid
Local dwCookie As Dword
Local szName As ZStr*16
Local pGrid As IGrid
Local hCtl As Dword
Register i As Long
Register j As Long
Call AllocConsole()
Prnt "Entering fnWndProc_OnCreate()"
pCreateStruct=wea.lParam
wea.hInst=@pCreateStruct.hInstance
Let pGrid = NewCom "FHGrid8.Grid"
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid))
pVnt=GlobalAlloc(%GPTR, 16)
@pVnt=pGrid 'assign interface to variant
Call SetWindowLong(Wea.hWnd,0,pVnt)
strSetup="120:Column 1:^:edit,130:Column 2:^:edit,140:Column 3:^:edit,150:Column 4:^:edit,160:Column 5:^:combo"
pGrid.CreateGrid(Wea.hWnd,strSetup,190,10,570,218,12,5,28,0,0,"Times New Roman",18,%FW_DONTCARE)
pConnectionPointContainer = pGrid
EventGuid=$IID_IGridEvents
Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid),Byval Varptr(pConnectionPoint))
Let pSink = Class "CGridEvents"
Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
Call SetWindowLong(Wea.hWnd,4,dwCookie)
Prnt " dwCookie = " & Str$(dwCookie)
For i=1 To 12
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
pGrid.Refresh()
hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,10,20,150,30,Wea.hWnd,%IDC_RETRIEVE,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5)
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs)
Local pConnectionPoint As IConnectionPoint
Local pVnt As Variant Ptr
Local dwCookie As Dword
Local pGrid As IGrid
Prnt " Entering DestroyGrid()"
pVnt=GetWindowLong(Wea.hWnd,0) ' Coming Into This Procedure, The Reference Count Will Be Sitting At
If pVnt Then ' One, Due To An IGrid Ptr Being Assigned To A Variant Up in WM_CREATE.
pGrid=@pVnt ' Reference Count Increments To Two
pConnectionPoint=pGrid ' Reference Count Increments To Three
pGrid.Release() ' Reference Count Will Decrement To Two At This Point
dwCookie=GetWindowLong(Wea.hWnd,4)
Call pConnectionPoint.Unadvise(dwCookie) ' The Reference Count Of Two Will Be Decremented To Zero After This
Call SetWindowLong(Wea.hWnd,0,0) ' Procedure Exits, because Both pGrid And pConnectionPoint Are Holding
Call SetWindowLong(Wea.hWnd,4,0) ' Valid Local Pointers Yet; PowerBASIC Is Tracking This, And Will Call
Call GlobalFree(pVnt) ' Releases() On Both Of Them When The Stack For DestroyGrid() Is
Else ' Cleaned Up.
Prnt " pGrid Was Already Released!"
End If
Prnt " Leaving DestroyGrid()"
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local pVnt As Variant Ptr
Local strData As BStr
Local pGrid As IGrid
Local iCnt As Long
Register i As Long
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_RETRIEVE"
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient2"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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
' PBClient3
'
' In this version of our client program we'll explore PowerBASIC's 'Nothing' keyword and see what
' effects use of this keyword have on the logistics of releasing local references. If you look
' down in DestroyGrid() in this version of the program (reproduced here) ...
' Sub DestroyGrid(Wea As WndEventArgs)
' Local pConnectionPoint As IConnectionPoint
' Local pVnt As Variant Ptr
' Local dwCookie As Dword
' Local pGrid As IGrid
'
' Prnt " Entering DestroyGrid()"
' pVnt=GetWindowLong(Wea.hWnd,0)
' If pVnt Then
' pGrid=@pVnt
' pConnectionPoint=pGrid
' pGrid.Release()
' dwCookie=GetWindowLong(Wea.hWnd,4)
' Call pConnectionPoint.Unadvise(dwCookie)
' pGrid = Nothing ' <<<< here &
' pConnectionPoint = Nothing ' <<<< here
' Call SetWindowLong(Wea.hWnd,0,0)
' Call SetWindowLong(Wea.hWnd,4,0)
' Call GlobalFree(pVnt)
' Else
' Prnt " pGrid Was Already Released!"
' End If
' Prnt " Leaving DestroyGrid()"
' End Sub
'
' ...you'll see that instead of leaving those two reference counts on the grid hang open like we did
' in version 2 of the program, we used the 'Nothing' keyword in assignment statements to set the
' reference to 'Nothing'. And what effect does that have, in comparison to letting the compiler
' auto-generated garbage collection code release the object in the process of deallocating the
' the DestroyGrid()'s stack? Here is the console output ...
'
' Entering fnWndProc_OnDestroy()
' Entering DestroyGrid()
' Entering IGrid_QueryInterface()
' Trying To Get IFHGrid
' Entering IGrid_AddRef()
' @pGrid.m_cRef = 1 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_AddRef()
' this = 6028880
' Leaving IGrid_QueryInterface()
' Entering IGrid_QueryInterface()
' Trying To Get IConnectionPoint
' this = 6028880
' Entering IConnectionPoint_AddRef()
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 3 << After
' Leaving IConnectionPoint_AddRef()
' this = 6028888
' Leaving IGrid_QueryInterface()
' Entering IGrid_Release()
' @pGrid.m_cRef = 3 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_Release()
' Entering IConnectionPoint_Unadvise()
' this = 6028888
' dwCookie = 0
' @pGrid.hWndCtrl = 3473864
' dwPtr = 2896540
' IGrid_Events::Release() Succeeded!
' Release() Returned 0
' Leaving IConnectionPoint_Unadvise()
' Entering IGrid_Release() ' <<< Here is what setting pGrid = Nothing caused ...
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 1 << After
' Leaving IGrid_Release()
' Entering IConnectionPoint_Release() ' <<< ... and here is what setting pConnectionPoint = Nothing caused.
' @pGrid.m_cRef = 1 << Before ' The important point to note in comparison to what we did in PBClient2
' 0 6024088 0 ' is that we are still in the DestroyGrid() function. The release of
' 1 6024092 0 ' the grid achieved by its reference count hitting zero occurred within
' 2 6024096 0 ' DestroyGrid() - not afterwards by auto garbage collection code.
' 3 6024100 0
' @pGrid.m_cRef = 0 And Will Now Delete pGrid!
' Leaving IConnectionPoint_Release()
' Leaving DestroyGrid()
' Entering DllCanUnloadNow()
' I'm Outta Here! (dll is unloaded)
' Leaving DllCanUnloadNow()
' Leaving fnWndProc_OnDestroy()
'
' What might be particularly instructive at this point might be to ask oneself what would happen or be the
' difference between using the Nothing keyword to diminish the reference count, i.e., it causes a call to
' Release() on the object, or simply calling Release() directly? Think a moment about that one. We'll try
' that in the next example, and see what happens!
#Compile Exe "PBClient3.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Uses PowerBASIC Includes
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
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient3","PBClient3")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pVnt As Variant Ptr
Local pGrid As IGrid
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long ' Offset Item
Local pConnectionPointContainer As IConnectionPointContainer ' =============================
Local pConnectionPoint As IConnectionPoint ' 0 - 3 IGrid Ptr - pGrid
Local pCreateStruct As CREATESTRUCT Ptr ' 4 - 7 dwCookie
Local strSetup,strCoordinate As BStr ' 8 - 11 iSelectedRow
Local pSink As IGridEvents
Local pVnt As Variant Ptr
Local EventGuid As Guid
Local dwCookie As Dword
Local szName As ZStr*16
Local pGrid As IGrid
Local hCtl As Dword
Register i As Long
Register j As Long
Call AllocConsole()
Prnt "Entering fnWndProc_OnCreate()"
pCreateStruct=wea.lParam
wea.hInst=@pCreateStruct.hInstance
Let pGrid = NewCom "FHGrid8.Grid"
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid))
pVnt=GlobalAlloc(%GPTR, 16)
@pVnt=pGrid 'assign interface to variant
Call SetWindowLong(Wea.hWnd,0,pVnt)
strSetup="120:Column 1:^:edit,130:Column 2:^:edit,140:Column 3:^:edit,150:Column 4:^:edit,160:Column 5:^:combo"
pGrid.CreateGrid(Wea.hWnd,strSetup,190,10,570,218,12,5,28,0,0,"Times New Roman",18,%FW_DONTCARE)
pConnectionPointContainer = pGrid
EventGuid=$IID_IGridEvents
Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid),Byval Varptr(pConnectionPoint))
Let pSink = Class "CGridEvents"
Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
Call SetWindowLong(Wea.hWnd,4,dwCookie)
Prnt " dwCookie = " & Str$(dwCookie)
For i=1 To 12
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
pGrid.Refresh()
hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,10,20,150,30,Wea.hWnd,%IDC_RETRIEVE,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5)
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs)
Local pConnectionPoint As IConnectionPoint
Local pVnt As Variant Ptr
Local dwCookie As Dword
Local pGrid As IGrid
Prnt " Entering DestroyGrid()"
pVnt=GetWindowLong(Wea.hWnd,0)
If pVnt Then
pGrid=@pVnt
pConnectionPoint=pGrid
pGrid.Release()
dwCookie=GetWindowLong(Wea.hWnd,4)
Call pConnectionPoint.Unadvise(dwCookie)
pGrid = Nothing
pConnectionPoint = Nothing
Call SetWindowLong(Wea.hWnd,0,0)
Call SetWindowLong(Wea.hWnd,4,0)
Call GlobalFree(pVnt)
Else
Prnt " pGrid Was Already Released!"
End If
Prnt " Leaving DestroyGrid()"
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local pVnt As Variant Ptr
Local strData As BStr
Local pGrid As IGrid
Local iCnt As Long
Register i As Long
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_RETRIEVE"
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient3"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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
' PBClient4
'
' Below is our simple alteration of DestroyGrid() where we've now replaced the two Nothing calls on pGrid
' and pConnectionPoint with Release() calls to see what happens ....
'
' Sub DestroyGrid(Wea As WndEventArgs)
' Local pConnectionPoint As IConnectionPoint
' Local pVnt As Variant Ptr
' Local dwCookie As Dword
' Local pGrid As IGrid
'
' Prnt " Entering DestroyGrid()"
' pVnt=GetWindowLong(Wea.hWnd,0)
' If pVnt Then
' pGrid=@pVnt
' pConnectionPoint=pGrid
' pGrid.Release()
' dwCookie=GetWindowLong(Wea.hWnd,4)
' Call pConnectionPoint.Unadvise(dwCookie)
' pGrid.Release() ' <<< Now calling Release() on pGrid instead of setting to Nothing
' pConnectionPoint.Release() ' <<< Now calling Release() on pConnectionPoint rather than setting to Nothing
' Call SetWindowLong(Wea.hWnd,0,0)
' Call SetWindowLong(Wea.hWnd,4,0)
' Call GlobalFree(pVnt)
' Else
' Prnt " pGrid Was Already Released!"
' End If
' Prnt " Leaving DestroyGrid()"
' End Sub
'
' And below is the console output from starting the program and simply x'ing out, as I've been doing all along here to
' study and elucidate object release and destruction issues ....
' Entering fnWndProc_OnDestroy()
' Entering DestroyGrid()
' Entering IGrid_QueryInterface()
' Trying To Get IFHGrid
' Entering IGrid_AddRef()
' @pGrid.m_cRef = 1 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_AddRef()
' this = 5111376
' Leaving IGrid_QueryInterface()
'
' Entering IGrid_QueryInterface()
' Trying To Get IConnectionPoint
' this = 5111376
' Entering IConnectionPoint_AddRef()
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 3 << After
' Leaving IConnectionPoint_AddRef()
' this = 5111384
' Leaving IGrid_QueryInterface()
'
' Entering IGrid_Release()
' @pGrid.m_cRef = 3 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_Release()
'
' Entering IConnectionPoint_Unadvise()
' this = 5111384
' dwCookie = 0
' @pGrid.hWndCtrl = 3343016
' dwPtr = 4141724
' IGrid_Events::Release() Succeeded!
' Release() Returned 0
' Leaving IConnectionPoint_Unadvise()
'
' Entering IGrid_Release() ' Here is the Release() call on pGrid ...
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 1 << After
' Leaving IGrid_Release()
'
' Entering IConnectionPoint_Release() ' ... and here the one on pConnectionPoint, which finally
' @pGrid.m_cRef = 1 << Before ' drops our reference count to zero, and triggers object
' 0 5106584 0 ' destruction code.
' 1 5106588 0
' 2 5106592 0
' 3 5106596 0
' @pGrid.m_cRef = 0 And Will Now Delete pGrid!
' Leaving IConnectionPoint_Release()
' Leaving DestroyGrid() ' So, just like in the last example ( PBClient3 ), the
' ' grid is destroyed within the execution of the DestroyGrid()
' Entering IGrid_Release() ' function. However, take careful note of what happens next ...
' @pGrid.m_cRef = 0 << Before
' @pGrid.m_cRef = -1 << After ' WOW!!!!
' Leaving IGrid_Release()
'
' Entering IConnectionPoint_Release() ' WOW!!!
' @pGrid.m_cRef = -1 << Before
' @pGrid.m_cRef = -2 << After
' Leaving IConnectionPoint_Release()
'
' Entering DllCanUnloadNow()
' I'm Outta Here! (dll is unloaded)
' Leaving DllCanUnloadNow()
' Leaving fnWndProc_OnDestroy()
'
' Now I think that's interesting! Even though the grid's reference count was driven down to zero by the Release() calls,
' and its automatic deallocation and destruction code was correctly executed, the PowerBASIC compiler still made its
' Release() calls on the local IGrid and IConnectionPoint interface pointers. Since the actual reference counting member
' variable in the grid object was declared as a signed entity, that drove the reference count down to a minus two (-2).
' This didn't cause any problems, but nonetheless, I don't believe its a real good thing to let happen. The reason it
' didn't cause any problems is because of the way I have my Release() methods coded in my grid. Other objects could
' possible react to this in a less satisfactory way, and for that reason I'd suggest that care should be taken to see
' that Release() calls are not made on an object after it has already been released. Here for example, is my
' IConnectionPoint::Release code ...
' Function IConnectionPoint_Release(ByVal this As IConnectionPoint1 Ptr) As Long
' Local pGrid As CGrid Ptr
' Register i As Long
'
' #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 ' <<<< Destruction code only executed when @pGrid.m_cRef
' #If %Def(%DEBUG) ' hit exactly zero.
' For i=0 To %MAX_CONNECTIONS-1
' Prnt " " & Str$(i) & " " & _
' Str$(Varptr(@pGrid.@pISink[i])) & _
' " " & Str$(@pGrid.@pISink[i])
' Next i
' #EndIf
' Call DestroyWindow(@pGrid.hWndCtrl)
' #If %Def(%DEBUG)
' Prnt " @pGrid.m_cRef = 0 And Will Now Delete pGrid!"
' #EndIf
' Call CoTaskMemFree(Byval @pGrid.pISink)
' 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
'
' So you can see above that the extra Release() calls simply kept decrementing the reference counting member m_cRef
' rather than getting inside the If which would have surely have caused problems if already released memory was
' deallocated more than once.
'
' If you reflect on this I believe it makes it fairly clear what the difference is between Release() calls on an
' object and setting it to Nothing. They both cause a Release() call on the object, but the Nothing keyword seems
' to tell the compiler not to garbage collect on the object when it goes out of scope. There really aren't too
' many references to this in the PowerBASIC Help, but I did find this ...
' The final issue in this topic is how to destroy an object variable. Generally speaking,
' you do nothing at all. When an object variable goes out of scope, PowerBASIC will handle
' all the messy details for you. For the most part, just forget about it. However, in the
' rare case that you need to destroy an object variable at a specific time and place, you
' can do so with the following statement:
'
' object1 = NOTHING
'
' Setting an object variable to NOTHING handles it all for you.
'
' And this ...
'
' LET objvar = NOTHING
'
' This destroys an object variable, discontinuing its association with a specific object.
' This in turn releases all system and memory resources associated with the object when no
' more object variables refer to it.
'
' For me, that makes sense after I've experimented with this code as I have, but before that it was unclear
' in my mind the difference between Release() calls and setting the object variable to Nothing.
'
' In all these examples so far we've used variants which were dynamically allocated in which we stored
' our interface pointers. To some, this might have raised the question as to whether it might be possible
' to just store the Objptr of the interface pointer directly in the WNDCLASSEX::cbWndExtra bytes. As I
' believe I've previously stated (many times), this presents difficulties because PowerBASIC makes it
' difficult to reinstate an object pointer back into an interface variable. This whole issue is a
' matter of variable 'casting'.
'
' Each programming language it seems has its own technique for converting a variable of one type into
' a variable of another type. For example, in C or C++ if one had a variable typed as an IGrid pointer, i.e.,
' IGrid* pGrid, one could store that value in the WNDCLASSEX object with a call to SetWindowLong() as
' follows...
'
' SetWindowLong(hWnd, 0, (long)pGrid);
'
' To retrieve the IGrid interface pointer from the Window Class structure one would use this ...
'
' pGrid=(IGrid*)GetWindowLong(hWnd, 0);
'
' In the 1st case above with SetWindowLong(), the entity '(long)' in front of pGrid is known as a 'cast'.
' Its a message to the compiler to tell it that the number held in pGrid, which is an integral address,
' should be considered as a long, which is how the 3rd parameter of SetWindowLong() is typed. In that case
' the compiler will allow the compilation it otherwise wouldn't. In the same way with GetWindowLong() the
' entity '(IGrid*)' is prefaced to GetWindowLong(), and that tells the compiler that it should interpret
' the return value from GetWindowLong(), which is a long, as instead a pointer to an IGrid interface. So
' that's the logic of casting when looking at the world through the eyes of C.
'
' The PowerBASIC compiler looks at the world through different colored glasses. Instead of casts, which
' are hints to the compiler to treat a quantity in a different way, PowerBASIC uses conversion routines
' such as CInt, CDbl, etc. There are a lot of them as you would see if you checked the manual. But there
' isn't any CObj(), which would be a conversion routine to do the opposite of what ObjPtr does, that is, a
' routine which reinstates an integral address back into an object variable. In the next example we'll
' look at creating our own so we don't have to resort to the awkwardness of using variants to store
' interface pointers.
#Compile Exe "PBClient4.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Uses PowerBASIC Includes
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
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient4","PBClient4")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pVnt As Variant Ptr
Local pGrid As IGrid
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long ' Offset Item
Local pConnectionPointContainer As IConnectionPointContainer ' =============================
Local pConnectionPoint As IConnectionPoint ' 0 - 3 IGrid Ptr - pGrid
Local pCreateStruct As CREATESTRUCT Ptr ' 4 - 7 dwCookie
Local strSetup,strCoordinate As BStr ' 8 - 11 iSelectedRow
Local pSink As IGridEvents
Local pVnt As Variant Ptr
Local EventGuid As Guid
Local dwCookie As Dword
Local szName As ZStr*16
Local pGrid As IGrid
Local hCtl As Dword
Register i As Long
Register j As Long
Call AllocConsole()
Prnt "Entering fnWndProc_OnCreate()"
pCreateStruct=wea.lParam
wea.hInst=@pCreateStruct.hInstance
Let pGrid = NewCom "FHGrid8.Grid"
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid))
pVnt=GlobalAlloc(%GPTR, 16)
@pVnt=pGrid 'assign interface to variant
Call SetWindowLong(Wea.hWnd,0,pVnt)
strSetup="120:Column 1:^:edit,130:Column 2:^:edit,140:Column 3:^:edit,150:Column 4:^:edit,160:Column 5:^:combo"
pGrid.CreateGrid(Wea.hWnd,strSetup,190,10,570,218,12,5,28,0,0,"Times New Roman",18,%FW_DONTCARE)
pConnectionPointContainer = pGrid
EventGuid=$IID_IGridEvents
Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid),Byval Varptr(pConnectionPoint))
Let pSink = Class "CGridEvents"
Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
Call SetWindowLong(Wea.hWnd,4,dwCookie)
Prnt " dwCookie = " & Str$(dwCookie)
For i=1 To 12
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
pGrid.Refresh()
hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,10,20,150,30,Wea.hWnd,%IDC_RETRIEVE,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5)
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs)
Local pConnectionPoint As IConnectionPoint
Local pVnt As Variant Ptr
Local dwCookie As Dword
Local pGrid As IGrid
Prnt " Entering DestroyGrid()"
pVnt=GetWindowLong(Wea.hWnd,0)
If pVnt Then
pGrid=@pVnt
pConnectionPoint=pGrid
pGrid.Release()
dwCookie=GetWindowLong(Wea.hWnd,4)
Call pConnectionPoint.Unadvise(dwCookie)
pGrid.Release()
pConnectionPoint.Release()
Call SetWindowLong(Wea.hWnd,0,0)
Call SetWindowLong(Wea.hWnd,4,0)
Call GlobalFree(pVnt)
Else
Prnt " pGrid Was Already Released!"
End If
Prnt " Leaving DestroyGrid()"
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local pVnt As Variant Ptr
Local strData As BStr
Local pGrid As IGrid
Local iCnt As Long
Register i As Long
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_RETRIEVE"
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient4"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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
I had posted a bad version and had to re-post the above.
What happens is that your code is flawed.
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
It should be:
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
pGrid.AddRef
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
You're bypassing PB's automatic reference counting with pGrid=@pVnt, so it needs to be followed by pGrid.AddRef.
Not sure what you are talking about Jose. I've looked at the PBClient1 and PBClient4 code I posted, and I see no problems with what I've done, other than the fact that I presented PBClient4 as an example of failed code, where reference counting was indeed screwed up. I have several more clients to post with full discussions written up, but just haven't gotten around to posting them yet. However, I did take the time to code and test a variant where I added the .AddRef() call you mentioned, and I can say for certain that that is the wrong thing to do. Here is the out of sequence example (PBClient7) using exactly what you just recommended, and afterwards is the console output which clearly shows the reference counting mischief it caused...
' PBClient7.bas ' !!! Code Fails To Unload Grid!!!
'
#Compile Exe "PBClient7.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Using PowerBASIC Includes.
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
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient7","PBClient7")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pVnt As Variant Ptr
Local pGrid As IGrid
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
pVnt=GetWindowLong(hMain,0)
pGrid=@pVnt
pGrid.AddRef() ' <<< Here is the line Jose wants to see
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Set pGrid=Nothing
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long ' Offset Item
Local pCreateStruct As CREATESTRUCT Ptr ' =======================================
Local strSetup,strCoordinate As BStr ' 0 - 3 IGrid Ptr - pGrid
Local pSink As IGridEvents ' 4 - 7 IGridEvents Ptr - pSink
Local pVnt As Variant Ptr ' 8 - 11 Store Current Selected Row
Local szName As ZStr*16
Local pGrid As IGrid ' In your typical Windows GUI program its certainly not necessary or desirable to
Local hCtl As Dword ' store the Window Handles of child window controls at global scope. Afterall,
Register i As Long ' one can always obtain the window handle ( HWND ) of a child window control through
Register j As Long ' its control id using the GetDlgItem() function, whose only parameters are the parent
' window handle and the control id of the desired child window control. What you don't
Call AllocConsole() ' need to worry about when you adorn your GUI programs with child window controls is
Prnt "Entering fnWndProc_OnCreate()" ' that Windows will prematurely and randomly destroy them for you after their creation.
pCreateStruct=wea.lParam ' If you decide to include ActiveX Controls in your program though, excrutiating
wea.hInst=@pCreateStruct.hInstance ' difficulties can arise if you attempt to deal with them in as caviliar a fashion as you
Let pGrid = NewCom "FHGrid8.Grid" ' might with a standard Windows control such a a text box or combo box - or even a
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid)) ' Common Control such as a Progress Bar or Calendar Control. The problem is that these
pVnt=GlobalAlloc(%GPTR, 16) ' things are 'reference counted' within your client program code, and if you don't
@pVnt=pGrid 'assign interface to variant ' declare their object variables at global scope, you risk having the compiler's garbage
Call SetWindowLong(Wea.hWnd,0,pVnt) ' collection code deallocate and destroy these things as local stack based objects. For
strSetup= _ ' example, just left PowerBASIC's NewCom statement is used in this WM_CREATE handler to
"120:Column 1:^:edit," & _ ' instantiate a my grid control. However, note that the pGrid variable of type IGrid
"130:Column 2:^:edit," & _ ' is declared as a local in this procedure. In fact this whole program has no global
"140:Column 3:^:edit," & _ ' variables, aside from possibly MsgHdlr(), which actually doesn't hold variables, but
"150:Column 4:^:edit," & _ ' rather constants, i.e., names of Windows Messages, and the addresses of the message
"160:Column 5:^:combo" ' handling function which handles each respective message. So, getting back to pGrid,
pGrid.CreateGrid _ ' which is actually a local interface pointer, if NewCom() succeeds in creating the
( _ ' grid control, QueryInterface() code within the grid dll will call AddRef() on the
Wea.hWnd, _ ' HWND of Parent ' pointer before it is returned to this code here, and that will set the reference count
strSetup, _ ' Setup String For Grid ' to one. However, being as pGrid is a local object variable, the PowerBASIC compiler
190, _ ' Top Left Corner x ' will call a Release() on the pointer at procedure termination in its effort to prevent
10, _ ' Top Left Corner y ' memory leaks. What it will do here with this object variable isn't conceptually any
570, _ ' Grid Width ' different than what it would do with a locally allocated String or WString object.
218, _ ' Grid Height ' Any memory it allocated to store a local string would be released after the procedure
12, _ ' # Rows Data In Grid ' exits. It really has to do this or your program would 'eat' memory until it crashed
5, _ ' # Columns In Grid ' the system. The problem with that behavior here is that a Release() call on the local
28, _ ' Row Ht In Pixels ' IGrid pointer pGrid will cause our reference count of one ( 1 ) to fall to zero ( 0 ),
0, _ ' Cell Back Color ' and when that happens COM objects automatically deallocate and destroy themselves! So
0, _ ' Cell Text Color ' what would happen here in that case is that the grid would be successfully created in
"Times New Roman", _ ' Font Name ' this WM_CREATE handler, but the user of this program would never see it, as nothing
18, _ ' Font Size ' that takes place during or immediately after a WM_CREATE call is visible to the user.
%FW_DONTCARE _ ' Font Weight ' Only after WM_PAINT does a window/app become visible to the user, and by that time, in
) ' relative computer time terms, the grid would have been long dead. The only answer
Let pSink = Class "CGridEvents" ' to this dilema, other than making the COM based control a global, is to store the valid
Events From pGrid Call pSink ' interface pointer somewhere, and 'artifically' increment its reference count so that
pVnt=GlobalAlloc(%GPTR, 16) ' PowerBASIC's garbage collection of local stack based objects won't allow the reference
@pVnt=pSink ' count to fall to zero, which condition causes the object to destroy itself. That is
Call SetWindowLong(Wea.hWnd,4,pVnt) ' exactly what you are seeing take place in this code upper left where a Variant Ptr object
For i=1 To 12 ' named pVnt is pointed at a dynamically allocated 16 byte chunk of memory where a Variant
For j=1 To 5 ' can be stored. Into that variant memory our pGrid interface pointer is stored with the
strCoordinate= _ ' statement @pVnt=pGrid. This line has a very interesting side effect. PowerBASIC
"(" & Trim$(Str$(i)) & _ ' interprets the equal operator ( = ) as a QueryInterface() call on the object for in this
"," & Trim$(Str$(j)) & ")" ' case the IUnknown of the object. This will cause a second AddRef() call on the object,
pGrid.SetData(i, j, strCoordinate) ' and that will bump the reference count to two ( 2 ). If you create the grid dll and
Next j ' compile and run this code, you'll easily see this in the voluminous console output
Next i ' produced by a run of the code. The net effect of this is that the compiler's clean up
pGrid.Refresh() ' of the local IGrid object pGrid at procedure termination will only cause the reference
hCtl=CreateWindow _ ' count on the object to fall to one ( 1 ) - not zero ( 0 ). The grid will keep itself
( _ ' in memory and you'll see and be able to use it. While its address held in pGrid will
"button", _ ' go out of scope, you'll note above that it was saved in the WNDCLASSEX::cbWndExtra bytes
"Retrieve Cell (3,2)", _ ' by a call to SetWindowLong() right after the variant assignment.
%WS_CHILD Or %WS_VISIBLE, _
10, _ ' The remainder of this procedure attaches the event sink to the grid, and creates some
20, _ ' buttons which exercise the grid in various self-explanatory ways. Also, the combo box
150, _ ' established in the fifth column of the grid is loaded with a few strings. One of the
30, _ ' grid methods returns a handle to the combo box the grid created within itself if you
Wea.hWnd, _ ' pass into the call the column ( 5 ) of the grid where the handle is you want.
%IDC_RETRIEVE, _
Wea.hInst, _
ByVal 0 _
)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5)
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs) ' Entering fnWndProc_OnDestroy() ' DestroyGrid() is called by either clicking the 'Unload Grid'
Local pSink As IGridEvents ' Entering DestroyGrid() ' button on the main form, or by 'x' ing out from the Title Bar.
Local pVnt As Variant Ptr ' pSink = 2896540 ' The output just left is from a program run where I just
Local pGrid As IGrid ' ' started the program, then immediately x'ed out to get the
Local iCnt As Long ' Entering IGrid_QueryInterface() ' debug console output. At this point I don't have too much to
' Trying To Get IFHGrid ' say about Release() 'ing the sink. Let's move down to the
Prnt " Entering DestroyGrid()" ' Entering IGrid_AddRef() ' Release() of the grid pointer stored at offset zero ( 0 ) in
' First, Release Sink ... ' @pGrid.m_cRef = 1 << Before ' the WNDCLASSEX::cbWndExtra bytes.
pVnt=GetWindowLong(Wea.hWnd,4) ' @pGrid.m_cRef = 2 << After
If pVnt Then ' Leaving IGrid_AddRef() ' First, a GetWindowLong() call retrieves the pointer to the
pSink=@pVnt ' this = 6815312 ' varient stored at offset zero in the .cbWndExtra bytes. Then
Prnt " pSink = " & Str$(ObjPtr(pSink)) ' Leaving IGrid_QueryInterface() ' the object stored in the Variant is copied to an IGrid pointer
If IsObject(pSink) Then ' ' pGrid. That's what caused the 'Entering IGrid_QueryInterface()'
Events End pSink ' pGrid = 6815312 ' call just a few lines up from here just left. Notice that from
Set pSink=Nothing ' ' within the dll we are being told that an IGrid pointer is being
End If ' Entering IGrid_Release() ' requested. The grid's QueryInterface() can satisfy that request,
Call SetWindowLong(Wea.hWnd,4,0) ' @pGrid.m_cRef = 2 << Before ' and so the pointer is returned, and an AddRef() is called on the
Call GlobalFree(pVnt) ' @pGrid.m_cRef = 1 << After ' pointer, which now brings up the reference count on the object
Else ' Leaving IGrid_Release() ' up to two ( 2 ). The first would be the pointer stored in the
Prnt " pSink Was Already Released!" ' ' .cbWndExtra bytes up in WM_CREATE, and the second would be the
End If ' iCnt = 1 ' local reference just stored in the local pGrid pointer here in
' Leaving DestroyGrid() ' DestroyGrid(). Then, right after the IsObject(pGrid) test on
' Then, Release Grid ... ' ' pGrid we see a Release() call - Call pGrid.Release(). Let's
pVnt=GetWindowLong(Wea.hWnd,0) ' Entering IGrid_Release() ' consider that call to be a release or undoing of the storage of
If pVnt Then ' @pGrid.m_cRef = 1 << Before ' the IGrid pointer up in the WM_CREATE handler where we put it in
pGrid=@pVnt ' 0 6810520 2896540 ' the WNDCLASSEX::cbWndExtra bytes. That call brings our reference
Prnt " pGrid = " & Str$(ObjPtr(pGrid)) ' 1 6810524 0 ' count on the grid down to one ( 1 ). Notice that in the remainder
If IsObject(pGrid) Then ' 2 6810528 0 ' of the DestroyGrid() procedure there are no more calls from the
Call pGrid.Release() To iCnt ' 3 6810532 0 ' pGrid pointer. Its still valid and the object is still alive;
Prnt " iCnt = " & Str$(iCnt) ' @pGrid.m_cRef = 0 << After ' but we're just taking care of other housekeeping chores. The
Call SetWindowLong(Wea.hWnd,0,0) ' Grid Was Deleted! ' procedure then exits and we get a message to that effect. But
End If ' Leaving IGrid_Release() ' then look what happens immediately! There is a call from within
Call GlobalFree(pVnt) ' ' the grid of 'IGrid_Release(). Now what caused that call? What
Else ' Entering DllCanUnloadNow() ' caused it is the PowerBASIC compiler generated clean up code
Prnt " pGrid Was Already Released!" ' I'm Outta Here! (dll is unloaded) ' cleaning up the local stack variables of the DestroyGrid()
End If ' Leaving DllCanUnloadNow() ' function. One of those locals was an IGrid pointer holding a
Prnt " Leaving DestroyGrid()" ' Leaving fnWndProc_OnDestroy() ' valid address. The compiler calls the Release(), knocking back
End Sub ' the reference count to zero, and the grid destroys itself....
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long ' ... What is about as interesting if you look down in
Local pVnt As Variant Ptr ' fnWndProc_OnDestroy() is a call to CoFreeUnusedLibraries() right
Local strData As BStr ' after the call to DestroyGrid() which we just exited. Note that
Local pGrid As IGrid ' we're still in the fnWndProc_OnDestroy() handler tripped by the
Local dwPtr As Dword ' click of the 'x' button the close the window. Anyway, the
Local iCnt As Long ' CoFreeUnusedLibraries() Api call queries the system for any dlls
Register i As Long ' laying around taking up memory that aren't being used by any
' program, i.e., they don't have any active clients. COM Dlls
Select Case As Long Lowrd(Wea.wParam) ' maintain a couple internal counters to track this. There is a
Case %IDC_RETRIEVE ' counter for locks and a counter for live objects. At this point
Prnt "Entering fnWndProc_OnCommand()" ' in the program both are at zero so DllCanUnloadNow() (an exported
Prnt " Case %IDC_RETRIEVE" ' Dll function) returns %S_OK and the system goes ahead and releases
pVnt=GetWindowLong(Wea.hWnd,0) ' the COM Dll itself. If you look inside that function in FHGrid8.bas
pGrid=@pVnt ' you'll see the 'I'm Outta Here!' phrase.
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
pVnt=GetWindowLong(Wea.hWnd,0)
pGrid=@pVnt
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient7"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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
Here is the console output with comments. The gist of it is that two AddRefs occur instead of only the one needed, and the object fails to release. The output below is obtainable by starting PBClient7.bas, highlighting a row and hitting the [DELETE] keyboard button to delete the row, then x'ing out of the app...
next post ...
Output from PBClient7 showing failure to release grid due to extra unneeded AddRef() in delete routine. Its not needed because QueryInterface automatically AddRefs the returned pointer ...
Entering fnWndProc_OnCreate()
Entering DllGetClassObjectImpl()
Entering IClassFactory_QueryInterface()
Entering IClassFactory_AddRef()
g_lObjs = 1
Leaving IClassFactory_AddRef()
this = 9968324
Leaving IClassFactory_QueryInterface()
IClassFactory_QueryInterface() For iid Succeeded!
Leaving DllGetClassObjectImpl()
Entering IClassFactory_CreateInstance()
pGrid = 1366584
Varptr(@pGrid.lpIGridVtbl) = 1366584
Varptr(@pGrid.lpICPCVtbl) = 1366588
Varptr(@pGrid.lpICPVtbl) = 1366592
@pGrid.pISink = 1359536
@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 = 1366584
Leaving IGrid_QueryInterface()
@ppv = 1366584 << After QueryInterface() Call
Entering Initialize() -- Initialize()
GetModuleHandle() = 9895936
Leaving Initialize()
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 = 1366584
Leaving IGrid_QueryInterface()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Objptr(pGrid) = 1366584
Entering IGrid_QueryInterface()
Looking For Something I Ain't Got!
Leaving IGrid_QueryInterface()
Entering IGrid_QueryInterface()
Trying To Get IUnknown
Entering IGrid_AddRef()
@pGrid.m_cRef = 1 << Before
@pGrid.m_cRef = 2 << After
Leaving IGrid_AddRef()
this = 1366584
Leaving IGrid_QueryInterface()
Entering IGrid_CreateGrid()
this = 1366584
hContainer = 3146208
strSetup = 120:Column 1:^:edit,130:Column 2:^:edit,140:Column 3:^:edit,150:Column 4:^:edit,160:Column 5:^:combo
x = 190
y = 10
cx = 570
cy = 218
iRows = 12
iCols = 5
iRowHt = 28
iSelectionBackColor = 0
iSelectionTextColor = 0
strFontName = Times New Roman
iFontSize = 18
iFontWeight = 0
GetLastError() = 0
hGrid = 1311260
pGridData = 1368120
Leaving IGrid_CreateGrid()
Called Class Method Create()!
hMain = 3146208
Leaving Class Method Create()
Entering IGrid_QueryInterface()
Trying To Get IConnectionPointContainer
this = 1366584
Entering IConnectionPointContainer_AddRef()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 3 << After
Leaving IConnectionPointContainer_AddRef()
this = 1366588
Leaving IGrid_QueryInterface()
Entering IConnectionPointContainer_FindConnectionPoint()
this = 1366588
@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 = 1366592
Leaving IConnectionPointContainer_FindConnectionPoint()
Entering IConnectionPoint_Advise()! Grab Your Hardhat And Hang On Tight!
this = 1366592
pGrid = 1366584
@pGrid.hControl = 1311260
pUnkSink = 1366620
Vtbl = 2108757
@Vtbl[0] = 2116396
dwPtr = 1366620
Call Dword Succeeded!
0 1359536 0 Found Open Slot!
Will Be Able To Store Connection Point!
Leaving IConnectionPoint_Advise() And Still In One Piece!
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()
hCtl = 590452
Leaving fnWndProc_OnCreate()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Entering fnGridProc_OnCommand() ' Most of this code here is from inside the COM grid dll,
pGridData = 1368120 ' and involves all the nastiness involved in clicking one
@pGridData.pComObj = 1366584 ' of the verticle aligned button controls just to the left
pGrid = 1366584 ' of each row of cells in the grid.
i pGrid.@pISink[i] @pGrid.@pISink[i]
=========================================
0 1359536 1366620
1 1359540 0
2 1359544 0
3 1359548 0
Lowrd(Wea.wParam) = 20004
iGridRow = 4
We Got In Where @pGridData.blnSelected = %False!
@pGridData.iSelectedRow = 4
@pGridData.blnRowSelected = 1
Entering Grid_OnRowSelection(GridEvents)
iRow = 4
iAction = 1
Leaving Grid_OnRowSelection(GridEvents)
Call Dword @Vtbl[8] Using ptrRowSelection() Succeeded!
@pGridData.blnRowSelected = 1
Leaving fnGridProc_OnCommand()
Entering fnGridProc_OnKeyDown() ' Most of this code here is likewise from within the grid's WM_KEYDOWN
A Row Is Selected! The Selected Row Is 4 ' handler, and runs when a row is 'Selected', and one presses the [DELETE]
Entering Grid_OnDelete() ' key.
iRow = 4
Entering IGrid_QueryInterface() ' <<< There is the code that executes when this line is encountered in
Trying To Get IFHGrid ' the client ...
Entering IGrid_AddRef()
@pGrid.m_cRef = 1 << Before ' pGrid=@pVnt
@pGrid.m_cRef = 2 << After '
Leaving IGrid_AddRef() ' The PowerBASIC compiler fully recognizes that as the assignment of an
this = 1366584 ' IUnknown generic object pointer to an IGrid interface pointer, and does
Leaving IGrid_QueryInterface() ' an automatic QueryInterface() on it. Within the Dll QueryInterface()
' automatically AddRef()'s all pointers returned. So that line drive the
Entering IGrid_AddRef() ' reference count to 2.
@pGrid.m_cRef = 2 << Before ' <<< Here <<< the extra AddRef() Jose wants to make is unnecessary and
@pGrid.m_cRef = 3 << After ' drives the reference count up to 3, which is unnecessary, as two (2) is
Leaving IGrid_AddRef() ' all that is needed - one for the saved interface pointer in the .cbWndExtra
' bytes, and one for the IGrid pointer being used in .Grid_OnDelete(). The
Entering IGrid_DeleteRow() ' problem comes in when this procedure exits and pGrid is set to Nothing.
pGrid = 1366584 ' What happens there is that only one Release() will occur, which drops the
hGrid = 1311260 ' reference count from 3 to 2. When you click the x to close the program it
pGridData = 1368120 ' now has an extra reference count it doesn't release, and the grid won't
iRow = 4 ' unload satisfactorily.
iSize = 54
iStart = 15
iCols = 5
Leaving IGrid_DeleteRow()
Entering IGrid_Release()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 2 << After
Leaving IGrid_Release()
Leaving Grid_OnDelete()
Leaving fnGridProc_OnKeyDown()
Entering fnWndProc_OnDestroy()
Entering DestroyGrid()
pSink = 1366620
Entering IGrid_QueryInterface()
Trying To Get IFHGrid
Entering IGrid_AddRef()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 3 << After
Leaving IGrid_AddRef()
this = 1366584
Leaving IGrid_QueryInterface()
pGrid = 1366584
Entering IGrid_Release()
@pGrid.m_cRef = 3 << Before
@pGrid.m_cRef = 2 << After
Leaving IGrid_Release()
iCnt = 2
Leaving DestroyGrid()
Entering IGrid_Release()
@pGrid.m_cRef = 2 << Before
@pGrid.m_cRef = 1 << After
Leaving IGrid_Release()
Entering DllCanUnloadNow()
The System Wants Rid Of Me But I Won't Go! ' <<<<< Its still got that extra AddRef() it can't deal with!!!!!!
Leaving DllCanUnloadNow()
Leaving fnWndProc_OnDestroy()
' PBClient5.bas
'
' So what we'll do here is simply use Objptr(pGrid) to store the address of our IGrid interface pointer
' returned by NewCom to the WNDCLASSEX::cbWndExtra bytes. If you are still not understanding what the
' commotion is all about, try this little nonsense console program...
'
' #Compile Exe
' #Dim All
'
' Interface IGrid : Inherit IUnknown ' just make a dummy interface with a couple methods
' Method CreateGrid() As Long
' Method DestroyGrid() As Long
' End Interface
'
' Function PBMain() As Long
' Local pGrid As IGrid ' declare an IGrid interface variable, which, as with
' ' all newly declared variables, PowerBASIC sets to null.
' 'Con.Print "pGrid = " pGrid ' then just try to print it out. you can't. It won't compile.
' Con.Print "Objptr(pGrid) = " Objptr(pGrid) ' to get this to compile and output a zero you need to
' Con.Waitkey$ ' comment out the Print pGrid statement. Note that
' ' there is no problem outputting the Objptr(pGrid), which
' PBMain=0 ' just gives a zero.
' End Function
'
'
' 'Objptr(pGrid) = 0
'
' As you should be beginning to see, the extent of freedom you have with PowerBASIC object variables is
' carefully constrained by the language. Of course, having to use Objptr(pGrid) to store an interface pointer
' in the .cbWndExtra bytes isn't terribly onerous. However, things get considerably trickier when one attempts
' to reuse an interface pointer so stored, as, for example, we must do in our DestroyGrid() routine to
' disconnect the connection point and release the grid. As you recall, the GetWindowLong() function can be
' used to retrieve our IGrid interface pointer stored using Objptr up in fnWndProc_OnCreate(), but that function
' returns a long, and PowerBASIC won't allow you to take that long and reassign it to a local IGrid interface
' pointer such as pGrid. If you try, you'll get this compilation error ...
'
' Error 482 in C:\Code\PwrBasic\PBWin10\COM\Grids\v8\Series\PBClient5.bas(240:009): Data type mismatch
' Line 240: pGrid=GetWindowLong(Wea.hWnd,0)
'
' As I've mentioned before, when PowerBASIC sees an uninitialized object/interface variable, it wants to see
' it initialized either through a NewCom, GetCom, or AnyCom call, or through its retrieval from a variant, which
' has an IUnknown object type as one of its many possible union members. It manifestly doesn't want to see an
' object variable initialized from a long, dword, integer, pointer variants of the aforementioned, or anything
' like that. It simply won't allow it. However, one can go behind PowerBASIC's back, so to speak, and Poke the
' integral address into the quantity referenced by the declared object variable. I learned this from Steven
' Pringels, who said he may have got it from Jose Roca, but he wasn't completely certain about that. So what it
' could look like then, that is, our 'hack' to get our IGrid interface pointer stored in the .cbWndExtra bytes
' into a locally declared interface variable, is something like this ...
'
' Macro CObj(pUnk, dwAddr) ' Used to convert an address to an object. This could
' Poke Dword, Varptr(pUnk), dwAddr ' be a new feature suggestion!
' pUnk.AddRef()
' End Macro
'
' That dasdardly abomination does the job! Here is the output from starting this program, then immediately
' x'ing out ...
'
' Entering fnWndProc_OnDestroy()
'
' Entering DestroyGrid()
' Entering IGrid_AddRef()
' @pGrid.m_cRef = 1 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_AddRef()
' Entering IGrid_QueryInterface()
' Trying To Get IConnectionPoint
' this = 2096720
' Entering IConnectionPoint_AddRef()
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 3 << After
' Leaving IConnectionPoint_AddRef()
' this = 2096728
' Leaving IGrid_QueryInterface()
' Entering IGrid_Release()
' @pGrid.m_cRef = 3 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IGrid_Release()
' Entering IConnectionPoint_Unadvise()
' this = 2096728
' dwCookie = 0
' @pGrid.hWndCtrl = 1442320
' dwPtr = 3678668
' IGrid_Events::Release() Succeeded!
' Release() Returned 0
' Leaving IConnectionPoint_Unadvise()
' Leaving DestroyGrid()
'
' Entering IGrid_Release()
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 1 << After
' Leaving IGrid_Release()
'
' Entering IConnectionPoint_Release()
' @pGrid.m_cRef = 1 << Before
' 0 2091928 0
' 1 2091932 0
' 2 2091936 0
' 3 2091940 0
' @pGrid.m_cRef = 0 And Will Now Delete pGrid!
' Leaving IConnectionPoint_Release()
'
' Entering DllCanUnloadNow()
' I'm Outta Here! (dll is unloaded)
' Leaving DllCanUnloadNow()
' Leaving fnWndProc_OnDestroy()
'
' As you can see, as soon as we enter DestroyGrid() we pick up an AddRef() from within our CObj Macro. Then
' we get another when set pConnectionPoint = pGrid, which causes a QueryInterface in the grid, and another
' AddRef() is called from there, which brings us up to three. Then we Release() the one we came into the
' procedure with from up in fnWndProc_OnCreate(), and that just leaves us with the two locals in DestroyGrid().
' And PowerBASIC calls auto releases on both of those when DestroyGrid() exits, and the grid unloads itself.
'
' Given what we've learned so far, could't we substitute Nothing calls on those local interface pointes?
' Lets try that in PBClient6. For now, here is PBClient5 ...
#Compile Exe "PBClient5.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Uses PowerBASIC Includes
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 CObj(pUnk, dwAddr) ' Used to convert an address to an object. This could
Poke Dword, Varptr(pUnk), dwAddr ' be a new feature suggestion!
pUnk.AddRef()
End Macro
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient5","PBClient5")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pGrid As IGrid
Local dwPtr As Dword
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
dwPtr=GetWindowLong(hMain,0)
CObj(pGrid,dwPtr)
Call pGrid.AddRef()
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long 'Offset Item
Local pConnectionPointContainer As IConnectionPointContainer '=====================================================================
Local pConnectionPoint As IConnectionPoint '0 - 3 IGrid Ptr - pGrid
Local pCreateStruct As CREATESTRUCT Ptr '4 - 7 dwCookie
Local strSetup,strCoordinate As BStr '8 - 11 iSelectedRow
Local pSink As IGridEvents
Local EventGuid As Guid
Local dwCookie As Dword
Local szName As ZStr*16
Local pGrid As IGrid
Local hCtl As Dword
Register i As Long
Register j As Long
Call AllocConsole()
Prnt "Entering fnWndProc_OnCreate()"
pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance
Let pGrid = NewCom "FHGrid8.Grid"
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid))
Call SetWindowLong(Wea.hWnd,0,Objptr(pGrid))
pGrid.AddRef()
strSetup="120:Column 1:^:edit,130:Column 2:^:edit,140:Column 3:^:edit,150:Column 4:^:edit,160:Column 5:^:combo"
pGrid.CreateGrid(Wea.hWnd,strSetup,190,10,570,218,12,5,28,0,0,"Times New Roman",18,%FW_DONTCARE)
pConnectionPointContainer = pGrid
EventGuid=$IID_IGridEvents
Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid),Byval Varptr(pConnectionPoint))
Let pSink = Class "CGridEvents"
Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
Prnt " dwCookie = " & Str$(dwCookie)
Call SetWindowLong(Wea.hWnd,4,dwCookie)
For i=1 To 12
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
pGrid.Refresh()
hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,10,20,150,30,Wea.hWnd,%IDC_RETRIEVE,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5) ' this line and method gets the handle to the combo box put in the 5th column of the grid
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName)) ' put some strings in the combo box
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs) ' Instead of using a variant to transfer and/or store the IGrid
Local pConnectionPoint As IConnectionPoint ' interface pointer, which is rather roundabout, here we're
Local dwCookie,dwPtr As Dword ' just storing and retrieving the address directly. However,
Local pGrid As IGrid ' due to PowerBASIC's somewhat protective instinct of trying
' to protect us from ourselves, so that we don't shoot ourselves
Prnt " Entering DestroyGrid()" ' in the foot so to speak, it won't let us easily reinstate the
dwPtr=GetWindowLong(Wea.hWnd,0) ' address from the GetWindowLong() memory into our object variable
If dwPtr Then ' pGrid. So we created our macro CObj() to do that. That Macro
CObj(pGrid,dwPtr) ' automatically AddRef's the pointer, so all we do here is Release()
pConnectionPoint=pGrid ' the AddRef() we did up in fnWndProc_OnCreate(). When DestroyGrid()
pGrid.Release() ' terminates PowerBASIC's clean up code calls Release() on the two
dwCookie=GetWindowLong(Wea.hWnd,4) ' local interface pointers allocated in this procedure. Apparently,
Call pConnectionPoint.Unadvise(dwCookie) ' at that point, its not asking any questions, or casting any
Call SetWindowLong(Wea.hWnd,0,0) ' judgement, upon the ledgitimacy of how the interface pointers came
Call SetWindowLong(Wea.hWnd,4,0) ' to be initialized with non zero values. All it apparently sees
Else ' is that the two pointers are referencing non null memory, and it
Prnt " pGrid Was Already Released!" ' dutuifully calls releases on them and all's well that ends well!
End If
Prnt " Leaving DestroyGrid()"
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local strData As BStr
Local pGrid As IGrid
Local dwPtr As Dword
Local iCnt As Long
Register i As Long
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_RETRIEVE"
dwPtr=GetWindowLong(Wea.hWnd,0)
Prnt " dwPtr = " & Str$(dwPtr)
CObj(pGrid,dwPtr)
Call pGrid.AddRef() To iCnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
dwPtr=GetWindowLong(Wea.hWnd,0)
Prnt " dwPtr = " & Str$(dwPtr)
CObj(pGrid,dwPtr)
Call pGrid.AddRef() To iCnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient5"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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
' PBClient6.bas
'
' Here we'll try setting pGrid and pConnectionPoint to Nothing within DestroyGrid(), to
' reinforce our knowledge of the effects of Release() calls verses the Nothing keyword
' in terms of object destruction. Here is the console output from making those changes
' in DestroyGrid() ...
'
' Entering fnWndProc_OnDestroy()
' Entering DestroyGrid()
' Entering IGrid_QueryInterface()
' Trying To Get IConnectionPoint
' this = 4457760
' Entering IConnectionPoint_AddRef()
' @pGrid.m_cRef = 1 << Before
' @pGrid.m_cRef = 2 << After
' Leaving IConnectionPoint_AddRef()
' this = 4457768
' Leaving IGrid_QueryInterface()
'
' Entering IConnectionPoint_Unadvise()
' this = 4457768
' dwCookie = 0
' @pGrid.hWndCtrl = 9961994
' dwPtr = 4465020
' IGrid_Events::Release() Succeeded!
' Release() Returned 0
' Leaving IConnectionPoint_Unadvise()
'
' Entering IGrid_Release()
' @pGrid.m_cRef = 2 << Before
' @pGrid.m_cRef = 1 << After
' Leaving IGrid_Release()
'
' Entering IConnectionPoint_Release()
' @pGrid.m_cRef = 1 << Before
' 0 4189112 0
' 1 4189116 0
' 2 4189120 0
' 3 4189124 0
' @pGrid.m_cRef = 0 And Will Now Delete pGrid!
' Leaving IConnectionPoint_Release()
' Leaving DestroyGrid()
'
' Entering DllCanUnloadNow()
' I'm Outta Here! (dll is unloaded)
' Leaving DllCanUnloadNow()
' Leaving fnWndProc_OnDestroy()
'
' If you compare with PBClient5, you'll see the only difference is that Release() calls
' were triggered by setting pGrid and pConnectionPoint to Nothing, and of course these
' Release() calls occurred within the execution of the DestroyGrid() procedure, as
' opposed to their occurrence afterwards through PowerBASIC's stack clean up code.
'
#Compile Exe "PBClient6.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-000000000084}")
$IID_IFHGrid = GUID$("{20000000-0000-0000-0000-000000000085}")
$IID_IGridEvents = GUID$("{20000000-0000-0000-0000-000000000086}")
%IDC_RETRIEVE = 1500
%IDC_COLOR = 1505
%IDC_UNLOAD_GRID = 1510
%IDC_GET_SELECTED_ROW = 1515
#Include "Win32Api.inc" ' Uses PowerBASIC Includes
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 CObj(pUnk, dwAddr) = Poke Dword, Varptr(pUnk), dwAddr ' used to convert an address to an object. this could
' be a new feature suggestion!
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
Interface IGrid $IID_IFHGrid : Inherit IAutomation ' This is the Grid's Interface (a standard incoming Interface, i.e.,
Method CreateGrid _ ' method calls are coming into the grid from the client).
( _
Byval hParent 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 iSelectionBackColor As Long, _
Byval iSelectionTextColor As Long, _
Byval strFontName As BStr, _
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
Method GethComboBox(Byval iCol As Long) As Long
Method SetCellAttributes(Byval iRow As Long, Byval iCol As Long, Byval iBackColor As Long, Byval iTextColor As Long) As Long
Method DeleteRow(Byval iRow As Long)
End Interface
Class CGridEvents As Event
Instance hMain As Dword
Class Method Create()
Prnt " Called Class Method Create()!"
hMain=FindWindow("PBClient6","PBClient6")
Prnt " hMain = " & Str$(hMain)
Prnt " Leaving Class Method Create()
End Method
Interface IGridEvents $IID_IGridEvents : Inherit IAutomation
Method Grid_OnKeyPress(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyPress From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnKeyDown(Byval iKeyCode As Long, Byval iKeyData As Long, Byval iRow As Long, Byval iCol As Long, Byref blnCancel As Long)
Prnt "Got KeyDown From CGridEvents1!" & Str$(iKeyCode) & "=" & Chr$(iKeyCode)
End Method
Method Grid_OnLButtonDown(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
Prnt "Got WM_LBUTTONDOWN In Grid Cell From CGridEvents1" & "(" & Trim$(Str$(iGridRow)) & "," & Trim$(Str$(iCol)) & ")"
End Method
Method Grid_OnLButtonDblClk(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnPaste(Byval iCellRow As Long, Byval iGridRow As Long, Byval iCol As Long)
' Insert your code here
End Method
Method Grid_OnRowSelection(Byval iRow As Long, Byval iAction As Long)
Prnt " Entering Grid_OnRowSelection(GridEvents)"
Prnt " iRow = " & Str$(iRow)
Prnt " iAction = " & Str$(iAction)
If iAction Then
Call SetWindowLong(hMain,8,iRow)
Else
Call SetWindowLong(hMain,8,0)
End If
Prnt " Leaving Grid_OnRowSelection(GridEvents)"
End Method
Method Grid_OnDelete(Byval iRow As Long)
Local pGrid As IGrid
Local dwPtr As Dword
Prnt " Entering Grid_OnDelete()"
Prnt " iRow = " & Str$(iRow)
dwPtr=GetWindowLong(hMain,0)
CObj(pGrid,dwPtr)
Call pGrid.AddRef()
Call pGrid.DeleteRow(iRow)
Call pGrid.Refresh()
Prnt " Leaving Grid_OnDelete()"
End Method
End Interface
End Class
Function fnWndProc_OnCreate(Wea As WndEventArgs) As Long 'Offset Item
Local pConnectionPointContainer As IConnectionPointContainer '=====================================================================
Local pConnectionPoint As IConnectionPoint '0 - 3 IGrid Ptr - pGrid
Local pCreateStruct As CREATESTRUCT Ptr '4 - 7 dwCookie
Local strSetup,strCoordinate As BStr '8 - 11 iSelectedRow
Local pSink As IGridEvents
Local EventGuid As Guid
Local dwCookie As Dword
Local szName As ZStr*16
Local pGrid As IGrid
Local hCtl As Dword
Register i As Long
Register j As Long
Call AllocConsole()
Prnt "Entering fnWndProc_OnCreate()"
pCreateStruct=wea.lParam : wea.hInst=@pCreateStruct.hInstance
Let pGrid = NewCom "FHGrid8.Grid"
Prnt " Objptr(pGrid) = " & Str$(Objptr(pGrid))
Call SetWindowLong(Wea.hWnd,0,Objptr(pGrid))
pGrid.AddRef()
strSetup="120:Column 1:^:edit,130:Column 2:^:edit,140:Column 3:^:edit,150:Column 4:^:edit,160:Column 5:^:combo"
pGrid.CreateGrid(Wea.hWnd,strSetup,190,10,570,218,12,5,28,0,0,"Times New Roman",18,%FW_DONTCARE)
pConnectionPointContainer = pGrid
EventGuid=$IID_IGridEvents
Call pConnectionPointContainer.FindConnectionPoint(Byval Varptr(EventGuid),Byval Varptr(pConnectionPoint))
Let pSink = Class "CGridEvents"
Prnt " Objptr(pSink) = " & Str$(Objptr(pSink))
Call pConnectionPoint.Advise(Byval Objptr(pSink), dwCookie)
Prnt " dwCookie = " & Str$(dwCookie)
Call SetWindowLong(Wea.hWnd,4,dwCookie)
For i=1 To 12
For j=1 To 5
strCoordinate="(" & Trim$(Str$(i)) & "," & Trim$(Str$(j)) & ")"
pGrid.SetData(i, j, strCoordinate)
Next j
Next i
pGrid.Refresh()
hCtl=CreateWindow("button","Retrieve Cell (3,2)",%WS_CHILD Or %WS_VISIBLE,10,20,150,30,Wea.hWnd,%IDC_RETRIEVE,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Color Some Rows",%WS_CHILD Or %WS_VISIBLE,10,70,150,30,Wea.hWnd,%IDC_COLOR,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Get Selected Row",%WS_CHILD Or %WS_VISIBLE,10,120,150,30,Wea.hWnd,%IDC_GET_SELECTED_ROW,Wea.hInst,ByVal 0)
hCtl=CreateWindow("button","Unload Grid",%WS_CHILD Or %WS_VISIBLE,10,170,150,30,Wea.hWnd,%IDC_UNLOAD_GRID,Wea.hInst,ByVal 0)
hCtl=pGrid.GethComboBox(5) ' this line and method gets the handle to the combo box put in the 5th column of the grid
Prnt " hCtl = " & Str$(hCtl)
szName="Frederick" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName)) ' put some strings in the combo box
szName="Elsie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Scott" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Lorrie" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Joseph" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
szName="Frank" : Call SendMessage(hCtl,%CB_INSERTSTRING,-1,Varptr(szName))
Prnt "Leaving fnWndProc_OnCreate()"
fnWndProc_OnCreate=0
End Function
Sub DestroyGrid(Wea As WndEventArgs)
Local pConnectionPoint As IConnectionPoint
Local dwCookie,dwPtr As Dword
Local pGrid As IGrid
Prnt " Entering DestroyGrid()"
dwPtr=GetWindowLong(Wea.hWnd,0)
If dwPtr Then
CObj(pGrid,dwPtr)
pConnectionPoint=pGrid
dwCookie=GetWindowLong(Wea.hWnd,4)
Call pConnectionPoint.Unadvise(dwCookie)
Call SetWindowLong(Wea.hWnd,0,0)
Call SetWindowLong(Wea.hWnd,4,0)
Let pGrid = Nothing
Let pConnectionPoint = Nothing
Else
Prnt " pGrid Was Already Released!"
End If
Prnt " Leaving DestroyGrid()"
End Sub
Function fnWndProc_OnCommand(Wea As WndEventArgs) As Long
Local strData As BStr
Local pGrid As IGrid
Local dwPtr As Dword
Local iCnt As Long
Register i As Long
Select Case As Long Lowrd(Wea.wParam)
Case %IDC_RETRIEVE
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_RETRIEVE"
dwPtr=GetWindowLong(Wea.hWnd,0)
Prnt " dwPtr = " & Str$(dwPtr)
CObj(pGrid,dwPtr)
Call pGrid.AddRef() To iCnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
strData=pGrid.GetData(3,2)
Prnt " Cell 3,2 Contains " & strData
Prnt "Leaving fnWndProc_OnCommand()"
Case %IDC_COLOR
If Hiwrd(Wea.wParam)=%BN_CLICKED Then
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_COLOR
dwPtr=GetWindowLong(Wea.hWnd,0)
Prnt " dwPtr = " & Str$(dwPtr)
CObj(pGrid,dwPtr)
Call pGrid.AddRef() To iCnt
Prnt " iCnt = " & Str$(iCnt)
pGrid.FlushData()
For i=1 To 5
pGrid.SetCellAttributes(3,i,&H000000FF,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(4,i,&H0000FF00,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(5,i,&H00FF0000,&H00FFFFFF)
Next i
For i=1 To 5
pGrid.SetCellAttributes(6,i,RGB(255,255,0),&H00000001)
Next i
pGrid.Refresh()
Prnt "Leaving fnWndProc_OnCommand()"
End If
Case %IDC_GET_SELECTED_ROW
If GetWindowLong(Wea.hWnd,8) Then
MsgBox("Selected Row = " & Str$(GetWindowLong(Wea.hWnd,8)))
Else
MsgBox("No Row Selected!")
End If
Case %IDC_UNLOAD_GRID
Prnt "Entering fnWndProc_OnCommand()"
Prnt " Case %IDC_UNLOAD_GRID"
Call DestroyGrid(Wea)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_RETRIEVE),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_UNLOAD_GRID),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_COLOR),%False)
Call EnableWindow(GetDlgItem(Wea.hWnd,%IDC_GET_SELECTED_ROW),%False)
Call InvalidateRect(Wea.hWnd,Byval %Null, %True)
Prnt "Leaving fnWndProc_OnCommand()"
End Select
fnWndProc_OnCommand=0
End Function
Function fnWndProc_OnDestroy(Wea As WndEventArgs) As Long
Prnt "Entering fnWndProc_OnDestroy()"
Call DestroyGrid(Wea)
Call CoFreeUnusedLibraries()
Call PostQuitMessage(0)
Prnt "Leaving fnWndProc_OnDestroy()"
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
Call AttachMessageHandlers() : szAppName="PBClient6"
wc.lpszClassName=VarPtr(szAppName) : wc.lpfnWndProc=CodePtr(fnWndProc)
wc.cbClsExtra=0 : wc.cbWndExtra=12
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,790,280,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