VB5 SGrid 2 Demonstration (144K)
VB5 SGrid 2 Full Source (446K)
VB5 SGrid 2.0 Binary (194K)
VB6 SGrid 2 Binary (173K)
VB6 SGrid 2 Demonstration (138K)
VB6 SGrid 2 Full Source (419K)
Bugs: 4 / 5
Issues: 8 / 8
Questions: 0 / 0
10 Feb 2004
The VB6 Downloads for the Grid contained incorrect files. The versions posted now have the correct files. Please ensure your version of vbalSGrid6.OCX has the file version 2.0.0.40 and accept my apologies for this stupid error.
TaskList demo had a missing line in the mnuColumns event handler which caused a 'Subscript out of Range' error when showing or hiding columns (it was trying to hide/show column 0). Fixed.
Subclassing Without The Crashes
vbAccelerator ImageList Control and Class v2.0
vbAccelerator - Contents of code file: vbalGrid.ctl
VERSION 5.00
Begin VB.UserControl vbalGrid
ClientHeight = 3600
ClientLeft = 0
ClientTop = 0
ClientWidth = 4800
OLEDropMode = 1 'Manual
ScaleHeight = 3600
ScaleWidth = 4800
ToolboxBitmap = "vbalGrid.ctx":0000
Begin VB.PictureBox picImage
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 1920
Left = 1980
ScaleHeight = 1920
ScaleWidth = 1920
TabIndex = 0
TabStop = 0 'False
Top = 900
Visible = 0 'False
Width = 1920
End
End
Attribute VB_Name = "vbalGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "vbAccelerator Grid Control"
Option Explicit
'
===============================================================================
=======
' Name: vbAccelerator S-Grid Control
' Author: Steve McMahon (steve@vbaccelerator.com)
' Date: 22 December 1998
'
' Requires: SSUBTMR.DLL
' cScrollBars.cls
' cShellSort.cls
' mGDI.bas
' HeaderControl.ctl
'
' Copyright 1998-2003 Steve McMahon for vbAccelerator
'
-------------------------------------------------------------------------------
-------
' Visit vbAccelerator - advanced free source code for VB programmers
' http://vbaccelerator.com
'
-------------------------------------------------------------7-----------------
-------
'
' A serious VB grid control. Can be used to replace the ListView and
MSFlexGrid, and
' can emulate the Outlook message list view.
'
' Features:
'
' * Drag-drop columns
' * Visible or invisible columns
' * Row height can be set independently for each row
' * MS Common Controls or vbAccelerator ImageList support
' * Up to two icons per cell (e.g. a check box and a standard icon)
' * Indent text within any cell
' * Many cell text formatting options including multi-line text
' * Independently set BackColor,ForeColor and Font for each cell
' * Show/Hide rows to allow filtering options
' * Show/Hide columns
' * Scroll bars implemented using true API scroll bars, and support
flat/encarta style
' * Up to 2 billion rows and columns (although practically about 20,000 is the
limit)
' * Full row sorting by up to three columns at once, allows sorting by icon,
text,
' date/time or number.
' * Tile bitmaps into the grid's background
' * Autosize columns
'
' Updated 19/10/99
' * 1) Added hWnd() property (Igor Tur)
' * 2) Flat Headers (SPM)
' * 3) Header icons now works when no text set (Igor Tur)
' * 4) ClearSelection method
' * 5) EnsureVisible method
' * 6) Prevented scroll bar edges from being visible in a new grid (see
UserControl_Show)
' * 7) Clear RowTextColumn when columns are removed (Rhys Nicholls)
' * 8) HighlightForeColor and HighlightBackColor Properties (Michael
Karathanasis, Igor Tur)
' * 9) Make sure all header items are persisted (Ricardo Taborda dos Reis)
' * 10) Allow setting of HeaderHeight (Andreas Claesson)
' * 11) First column didn't resize correctly when dbl click header (Cuong
Nguyen)
' * 12) GPF when add column with rows present in grid (Marc Scherwinski)
' * 13) ColumnWidthChanged event (Brian Beatty)
' * 14) Ensure cells ungray themselves when enable is set back to true, don't
draw
' focus rect when disabled (Ricardo Taborda dos Reis)
'
' Updated 2003-12-08
' * 1) Added MouseWheel support
' * 2) CancelEdit now done using a WH_MOUSEHOOK - much more reliable
' * 3) PreCancelEdit event now offered.
' * 4) VB6 ImageList support (although not for the header)
' * 5) Option of separate ImageList for headers
' * 6) No Horizontal or No Vertical Grid line options
' * 7) Out of focus highlight colour can be set
' * 8) Control now draws correctly when it is wider than a single screen
' * 9) When using left and right keys in row mode, control no longer tries
' to scroll when the scroll bars are hidden.
' * 10) Corrected the gap between the borders and selection box, and also
' the positioning of the focus rectangle. Borders are more accurately
' positioned.
' * 11) Grid fits exactly into the space, rather than having a border
' * 12) Auto-fill grid lines option
' * 13) Alternate row back colour option
' * 14) Outlook-style grouping option with drag-drop grouping of cells
' * 15) Sorting is now 2 - 10x faster
' * 16) Inserting and removing rows is 10x faster.
' * 17) Responds to system colour or display change events
' * 18) SplitRow property allows a set of rows to be fixed
' within the grid so they always display
'
'
' Ongoing work:
'
' * *) Assign auto-edit controls to columns in the grid. Any control that
' supports the "Text" property can be used.
' * *) New virtual mode which works
' * *) Image processing of background bitmap for selections and highlighting
' * *) Owner-draw cells
' * *) Marquee multi-select when not in row-mode
' * *) Show a checkbox in a cell
'
' FREE SOURCE CODE - ENJOY!
'
===============================================================================
=======
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" ( _
ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" ( _
ByVal hLibModule As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
Integer
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long,
lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
lpPoint As POINTAPI) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As
Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long,
ByVal yPoint As Long) As Long
Private Declare Function ChildWindowFromPoint Lib "user32" (ByVal hWndParent As
Long, ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
Long, ByVal lpString As String) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal
fEnable As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long)
As Long
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const WM_ACTIVATEAPP = &H1C
Private Const WM_SETTINGCHANGE = &H1A&
Private Const WM_DISPLAYCHANGE = &H7E&
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCMBUTTONDOWN = &HA7
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_LBUTTONUP = &H202
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const WS_EX_WINDOWEDGE = &H100
Private Const WS_EX_CLIENTEDGE = &H200
Private Const WS_EX_STATICEDGE = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_VSCROLL = &H200000
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal
nIndex As Long) As Long
Private Const BITSPIXEL = 12 ' Number of bits per pixel
Private Declare Function ScrollDC Lib "user32" (ByVal hdc As Long, ByVal dx As
Long, ByVal dy As Long, lprcScroll As RECT, lprcClip As RECT, ByVal hrgnUpdate
As Long, lprcUpdate As RECT) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect
As RECT) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawTextA Lib "user32" (ByVal hdc As Long, ByVal lpStr
As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr
As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_NOFULLWIDTHCHARBREAK = &H80000
Private Const DT_HIDEPREFIX = &H100000
Private Const DT_PREFIXONLY = &H200000
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
As Long
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
nBkMode As Long) As Long
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As
Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
Long, ByVal y As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As
Long, ByVal ptY As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As
Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long,
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function ImageList_GetIconSize Lib "COMCTL32" (ByVal hImagelist
As Long, cx As Long, cy As Long) As Long
Private Declare Function ImageList_GetImageCount Lib "COMCTL32" (ByVal
hImagelist As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Sub mouse_event Lib "user32" ( _
ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, _
ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down
Private Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up
Public Enum ECGScrollBarStyles
ecgSbrRegular = EFSStyleConstants.efsRegular
ecgSbrEncarta = EFSStyleConstants.efsEncarta
ecgSbrFlat = EFSStyleConstants.efsFlat
End Enum
Public Enum ECGHdrTextAlignFlags
ecgHdrTextALignLeft = EHdrTextAlign.HdrTextALignLeft
ecgHdrTextALignCentre = EHdrTextAlign.HdrTextALignCentre
ecgHdrTextALignRight = EHdrTextAlign.HdrTextALignRight
End Enum
Public Enum ECGTextAlignFlags
DT_TOP = &H0&
DT_LEFT = &H0&
DT_CENTER = &H1&
DT_RIGHT = &H2&
DT_VCENTER = &H4&
DT_BOTTOM = &H8&
DT_WORDBREAK = &H10&
DT_SINGLELINE = &H20&
DT_EXPANDTABS = &H40&
DT_TABSTOP = &H80&
DT_NOCLIP = &H100&
DT_EXTERNALLEADING = &H200&
DT_CALCRECT = &H400&
DT_NOPREFIX = &H800&
DT_INTERNAL = &H1000&
'#if(WINVER >= =&H0400)
DT_EDITCONTROL = &H2000&
DT_PATH_ELLIPSIS = &H4000&
DT_END_ELLIPSIS = &H8000&
DT_MODIFYSTRING = &H10000
DT_RTLREADING = &H20000
DT_WORD_ELLIPSIS = &H40000
End Enum
Public Enum ECGGridLineMode
ecgGridStandard = 0
ecgGridFillControl = 1
End Enum
Public Enum ECGGroupRowState
ecgCollapsed = 0
ecgExpanded = 1
End Enum
Public Enum ECGDrawStage
ecgBeforeAll = 0
ecgBeforeIconAndText = 10
ecgAfter = 20
End Enum
' The grid:
Private m_tCells() As tGridCell
Private m_iTotalCellRows As Long
Private m_colGarbageRows As New Collection
Private m_tDefaultCell As tGridCell
' Row and columns and associated info:
Private m_iCols As Long
Private m_iRows As Long
Private m_tRows() As tRowPosition
Private Type tColPosition
lWidth As Long
lCorrectWidth As Long
bFixedWidth As Long
lStartX As Long
lCellColIndex As Long
bVisible As Boolean
bRowTextCol As Boolean
sKey As String
sTag As String
bIncludeInSelect As Boolean
lHeaderColIndex As Long
sHeader As String
iIconIndex As Long
eTextAlign As ECGHdrTextAlignFlags
sFmtString As String
bImageOnRight As Boolean
eSortType As ECGSortTypeConstants
eSortOrder As ECGSortOrderConstants
' 2003-11-26 additions
bIsGrouped As Boolean
iGroupOrder As Long
' 2004-01-10 for future expansion
bOwnerDraw As Boolean
End Type
Private m_tCols() As tColPosition
' Grouping of cells:
Private Type tGroupCells
iGroupNum As Long
iRow As Long
iCol As Long
End Type
Private m_tGroupCells() As tGroupCells
' Sorting:
Private m_cSort As New cGridSortObject
' Selection optimisations for not multi-select:
Private m_iSelRow As Long
Private m_iSelCol As Long
Private m_iLastSelRow As Long
Private m_iLastSelCol As Long
' Defaults:
Private m_lDefaultRowHeight As Long
Private m_lDefaultColumnWidth As Long
' Display fonts:
Private m_Fnt() As StdFont
Private m_hFnt() As Long
Private m_iFontCount As Long
' Drawing area:
Private m_lAvailWidth As Long
Private m_lAvailheight As Long
Private m_lGridWidth As Long
Private m_lGridHeight As Long
Private m_lStartX As Long
Private m_lStartY As Long
' Memory DC for flicker-free (1 row only) - also implements clipping
Private m_hDC As Long
Private m_hBmp As Long
Private m_hBmpOld As Long
Private m_lHeight As Long
Private m_lMaxRowHeight As Long
Private m_lMaxMemDCWidth As Long
Private m_hFntDC As Long
Private m_hFntOldDC As Long
' Background:
Private m_bBitmap As Boolean
Private m_hDCSrc As Long
Private m_lBitmapW As Long
Private m_lBitmapH As Long
Private m_bTrueColor As Boolean
' Icons:
Private m_hIml As Long
' VB6 ImageList support 2003-11-10 (5)
Private m_ptrVb6ImageList As Long
Private m_lIconSizeX As Long
Private m_lIconSizeY As Long
' Separate Header ImageList 2003-11-24
Private m_bHeaderImageListSet As Boolean
' Gridlines:
Private m_bGridLines As Boolean
' 2003-11-26: Switch off horizontal or vertical grid lines
Private m_bNoHorizontalGridLines As Boolean
Private m_bNoVerticalGridLines As Boolean
' 2003-11-26: Grid lines extend to fill control
Private m_eGridLineMode As ECGGridLineMode
Private m_oGridLineColor As OLE_COLOR
Private m_oGridFillLineColor As OLE_COLOR
' Active Colour 19/10/1999 (8)
Private m_oHighlightForeColor As OLE_COLOR
Private m_oHighlightBackColor As OLE_COLOR
' 2003-11-24: NoFocus Colours
Private m_oNoFocusHighlightForeColor As OLE_COLOR
Private m_oNoFocusHighlightBackColor As OLE_COLOR
' 2003-11-27: GroupRow Colours
Private m_oGroupRowBackColor As OLE_COLOR
Private m_oGroupRowForeColor As OLE_COLOR
Private m_oGroupAreaBackColor As OLE_COLOR
' 2003-12-07: Alternate Row BackColor
Private m_oAlternateRowBackColor As OLE_COLOR
' 2003-12-13: Gutter Colour for grouped rows
Private m_oGutterBackColor As OLE_COLOR
Private m_bAlphaBlendSelection As Boolean
Private m_bOutlineSelection As Boolean
' Behaviour:
Private m_bMultiSelect As Boolean
Private m_bMarquee As Boolean
Private WithEvents m_tmrMarquee As CTimer
Attribute m_tmrMarquee.VB_VarHelpID = -1
Private m_lMarqueeStartRow As Long
Private m_lMarqueeStartCol As Long
Private m_lMarqueeEndRow As Long
Private m_lMarqueeEndCol As Long
Private m_bRowMode As Boolean
Private m_bRedraw As Boolean
Private m_bHeader As Boolean
Private m_lSplitRow As Long
Private m_lSplitSeparatorSize As Long
Private m_bStretchLastColumnToFit As Boolean
Private m_lStretchedColumn As Long
Private m_lPtrOwnerDraw As Long
Private WithEvents m_tmrHotTrack As CTimer
Attribute m_tmrHotTrack.VB_VarHelpID = -1
Private m_bHotTrack As Boolean
Private m_lHotTrackRow As Long
Private m_lHotTrackCol As Long
' Control flags
Private m_bInFocus As Boolean
Private m_bDirty As Boolean
Private m_bUserMode As Boolean
Private m_bMouseDown As Boolean
' Edit flags
Private m_bInEdit As Boolean
Private m_bInEndEditInterlock As Boolean
' Store edit row and column 2003-11-10
Private m_iEditRow As Long
Private m_iEditCol As Long
' When window is disabled and control is used as an EXE
' we need to repost the cancel edit event
Private m_bRunningInVBIDE As Boolean
Private m_iRepostMsg As Long
Private m_tRepostPos As POINTAPI
Private m_lRepostShiftState As Long
' Check for WM_SETTINGSCHANGE 2003-12-10
Private m_hWnd As Long
' Check for WM_ACTIVATEAPP 2003-11-10
Private m_hWndParentForm As Long
Private m_bEditable As Boolean
Private m_bSingleClickEdit As Boolean
Private m_bSelChange As Boolean
Private m_bEnabled As Boolean
Private m_bDisableIcons As Boolean
Private m_bHighlightSelectedIcons As Boolean
Private m_bDrawFocusRectangle As Boolean
Private m_bNoOptimiseScroll As Boolean
Private m_bTryToFitGroupRows As Boolean
' "Row Text" Column:
Private m_iRowTextCol As Long
Private m_lRowTextStartCol As Long
Private m_bHasRowText As Boolean
' Search Column:
Private m_iSearchCol As Long
Private m_sSearchString As String
' Scroll bars:
Private WithEvents m_cScroll As cScrollBars
Attribute m_cScroll.VB_VarHelpID = -1
Private m_eScrollStyle As EFSStyleConstants
Private m_bAllowVert As Boolean
Private m_bAllowHorz As Boolean
' Header:
Private WithEvents m_cHeader As cHeaderControl
Attribute m_cHeader.VB_VarHelpID = -1
Private m_cFlatHeader As cFlatHeader
Private m_bHeaderFlat As Boolean
' Add rows on demand
Private m_bAddRowsOnDemand As Boolean
Private m_bInAddRowRequest As Boolean
' Hack for XP Crash with VB6 controls:
Private m_hMod As Long
Public Enum ECGBorderStyle
ecgBorderStyleNone = 0
ecgBorderStyle3d = 1
ecgBorderStyle3dThin = 2
End Enum
Private m_eBorderStyle As ECGBorderStyle
Public Enum ECGSerialiseTypes
ecgSerialiseSGRID = 0
ecgSerialiseSGRIDLayout = 1
ecgSerialiseTextTabNewLine = 2
ecgSerialiseCSV = 3
End Enum
Public Enum ECGScrollBarTypes
ecgScrollBarHorizontal
ecgScrollBarVertical
End Enum
' Events
''' <summary>
''' Raised when a column header is clicked
''' </summary>
''' <param name="lCol">Column index</param>
Public Event ColumnClick(ByVal lCol As Long)
Attribute ColumnClick.VB_Description = "Raised when the user clicks a column."
''' <summary>
''' Raised when a column header's width is about to be changed
''' </summary>
''' <param name="lCol">Column index</param>
''' <param name="lWidth">New width (can be modified)</param>
''' <param name="bCancel">Set to <c>true</c> to cancel the size change.</param>
Public Event ColumnWidthStartChange(ByVal lCol As Long, ByRef lWidth As Long,
ByRef bCancel As Boolean)
Attribute ColumnWidthStartChange.VB_Description = "Raised before a column's
width is about to be changed."
''' <summary>
''' Raised whilst a column header's width is changing
''' </summary>
''' <param name="lCol">Column index</param>
''' <param name="lWidth">New width (can be modified)</param>
''' <param name="bCancel">Set to <c>true</c> to cancel the size change.</param>
Public Event ColumnWidthChanging(ByVal lCol As Long, ByRef lWidth As Long,
ByRef bCancel As Boolean)
Attribute ColumnWidthChanging.VB_Description = "Raised as a column's width is
being changed."
''' <summary>
''' Raised when a column header's width has been changed
''' </summary>
''' <param name="lCol">Column index</param>
''' <param name="lWidth">New width (can be modified)</param>
''' <param name="bCancel">Set to <c>true</c> to cancel the size change.</param>
Public Event ColumnWidthChanged(ByVal lCol As Long, ByRef lWidth As Long, ByRef
bCancel As Boolean)
Attribute ColumnWidthChanged.VB_Description = "Raised when a column's width has
been changed."
''' <summary>
''' Raised when a column header's divider is double clicked
''' </summary>
''' <param name="lCol">Column index</param>
''' <param name="bCancel">Set to <c>true</c> to cancel the size change.</param>
Public Event ColumnDividerDblClick(ByVal lCol As Long, ByRef bCancel As Boolean)
Attribute ColumnDividerDblClick.VB_Description = "Raised when the divider
between two columns is double clicked."
''' <summary>
''' Raised when the order of columns has been changed in the control.
''' </summary>
Public Event ColumnOrderChanged()
Attribute ColumnOrderChanged.VB_Description = "Raised when the order of the
columns is changed following a drag-drop operation."
''' <summary>
''' Raised when the user right clicks in the header.
''' </summary>
''' <param name="x">x Position of right click</param>
''' <param name="y">y Position of right click</param>
Public Event HeaderRightClick(ByVal x As Single, ByVal y As Single)
Attribute HeaderRightClick.VB_Description = "Raised when the user right clicks
on the grid's header."
''' <summary>
''' Raised when the selected cell(s) in the grid change.
''' </summary>
''' <param name="lRow">Most recently selected row</param>
''' <param name="lCol">Most recently selected column</param>
Public Event SelectionChange(ByVal lRow As Long, ByVal lCol As Long)
Attribute SelectionChange.VB_Description = "Raised when the user changes the
selected cell."
''' <summary>
''' Raised when the hot item in the grid changes.
''' </summary>
''' <param name="lRow">Most recently hot row, may be zero</param>
''' <param name="lCol">Most recently hot column, may be zero</param>
Public Event HotItemChange(ByVal lRow As Long, ByVal lCol As Long)
Attribute HotItemChange.VB_Description = "Raised when the hot cell or row
changes. Only raised when HotTrack is True."
''' <summary>
''' Raised when the grid identifies that edit mode should
''' be started. The application should show the edit control
''' over the specified cell if <c>bCancel</c> is not set to
''' <c>true</c>.
''' </summary>
''' <param name="lRow">Row to edit</param>
''' <param name="lCol">Column to edit</param>
''' <param name="iKeyAscii">ASCII code of key that was pressed, or 0 if
''' edit mode was started using the mouse.</param>
''' <param name="bCancel">Set to <c>true</c> to not enter edit mode.</param>
Public Event RequestEdit(ByVal lRow As Long, ByVal lCol As Long, ByVal
iKeyAscii As Integer, ByRef bCancel As Boolean)
Attribute RequestEdit.VB_Description = "Raised when the grid has the Editable
property set to True and the user's actions request editing of the current
cell."
''' <summary>
''' Raised when the grid identifies that edit should be ended. Provides
opportunity
''' to validate the data in the cell prior to ending edit mode.
''' </summary>
''' <param name="lRow">Row to edit</param>
''' <param name="lCol">Column to edit</param>
''' <param name="newValue">For future expansion.</param>
''' <param name="bStayInEditMode">Set to <c>true</c> to not stay in edit
mode.</param>
Public Event PreCancelEdit(ByVal lRow As Long, ByVal lCol As Long, ByRef
newValue As Variant, ByRef bStayInEditMode As Boolean)
Attribute PreCancelEdit.VB_Description = "Raised when the user has taken an
action that will cancel an edit operation. Allows the edit contents to be
validated prior to exiting edit mode."
''' <summary>
''' Raised when the edit mode is exited. The application should hide any edit
''' control in response to this event. Note: do not attempt to perform
validation
''' in response to this event, use <c>PreCancelEdit</c> instead.
''' </summary>
Public Event CancelEdit()
''' <summary>
''' Raised when the user depresses a key in the control.
''' </summary>
''' <param name="KeyCode">Key code that was depressed</param>
''' <param name="Shift">Current shift mask state</param>
''' <param name="bDoDefault">Set to <c>false</c> to prevent the control
performing
''' default processing on the key</span>
Public Event KeyDown(KeyCode As Integer, Shift As Integer, bDoDefault As
Boolean)
Attribute KeyDown.VB_Description = "Raised when a key is pressed in the
control."
''' <summary>
''' Raised when the control converts a KeyDown in the control
''' into a character.
''' </summary>
''' <param name="KeyAscii">Ascii code of the key that was depressed</param>
Public Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "Raised after the KeyDown event when the
key press has been converted to an ASCII code."
''' <summary>
''' Raised when the user releases a key in the control.
''' </summary>
''' <param name="KeyCode">Key code that was released</param>
''' <param name="Shift">Current shift mask state</param>
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "Raised when a key is released on the grid."
''' <summary>
''' Raised when the user depresses a mouse button in the control.
''' </summary>
''' <param name="Button">Mouse button that was depressed</param>
''' <param name="Shift">Current shift mask state</param>
''' <param name="X">X position of mouse</param>
''' <param name="Y">Y position of mouse</param>
''' <param name="bDoDefault">Set to <c>false</c> to prevent the control
performing
''' default processing on the key</span>
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As
Single, bDoDefault As Boolean)
Attribute MouseDown.VB_Description = "Raised when the a mouse button is pressed
over the control."
''' <summary>
''' Raised when the user moves the mouse button in the control.
''' </summary>
''' <param name="Button">Mouse button that was depressed</param>
''' <param name="Shift">Current shift mask state</param>
''' <param name="X">X position of mouse</param>
''' <param name="Y">Y position of mouse</param>
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As
Single)
Attribute MouseMove.VB_Description = "Raised when the mouse moves over the
control, or when the mouse moves anywhere and a mouse button has been pressed
over the control."
''' <summary>
''' Raised when the user releases a mouse button in the control.
''' </summary>
''' <param name="Button">Mouse button that was released</param>
''' <param name="Shift">Current shift mask state</param>
''' <param name="X">X position of mouse</param>
''' <param name="Y">Y position of mouse</param>
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As
Single)
Attribute MouseUp.VB_Description = "Raised when a mouse button is released
after having been pressed over the control."
''' <summary>
''' Raised when the user double clicks in the control.
''' </summary>
''' <param name="lRow">Row user double clicked in, or 0 if no row.</param>
''' <param name="lCol">Column user double clicked in, or 0 if no row.</param>
Public Event DblClick(ByVal lRow As Long, ByVal lCol As Long)
Attribute DblClick.VB_Description = "Raised when the user double clicks on the
grid."
''' <summary>
''' Raised when one of the scroll bars is changed
''' </summary>
''' <param name="eBar">The scroll bar that has been changed</param>
Public Event ScrollChange(ByVal eBar As ECGScrollBarTypes)
Attribute ScrollChange.VB_Description = "Raised when the grid is scrolled."
''' <summary>
''' Raised when a row's grouping state is about to be changed.
''' </summary>
''' <param name="lRow">The group row who's state will be changed.</param>
''' <param name="eNewState">The new state for the row.</param>
''' <param name="bCancel">Set to <c>true</c> to cancel the event.</param>
Public Event RowGroupingStateChange(ByVal lRow As Long, ByVal eNewState As
ECGGroupRowState, ByRef bCancel As Boolean)
Attribute RowGroupingStateChange.VB_Description = "Raised when the state of a
grouping row changes (between collapsed and expanded)."
Public Event RequestRow(ByVal lRow As Long, ByRef lItemData As Long, ByRef
bVisible As Boolean, ByRef lHeight As Long, ByRef bNoMoreRows As Boolean)
Attribute RequestRow.VB_Description = "Raised when a new row is needed and the
AddRowsOnDemand property is set to True."
Public Event RequestRowData(ByVal lRow As Long)
Attribute RequestRowData.VB_Description = "Raised after a new row has been
added in response to RequestRow when AddRowsOnDemand is set True. Respond by
filling in the cells for that row."
Implements ISubclass
Public Sub SaveGridData(ByVal sFile As String)
Attribute SaveGridData.VB_Description = "Saves the grid's data using an
internal format. The data can be reloaded into a grid with the same columns
using LoadGridData."
Dim lLenPos As Long
Dim lNowPos As Long
Dim lLen As Long
Dim iFile As Integer
On Error GoTo ErrorHandler
iFile = FreeFile
Open sFile For Binary Access Write Lock Read As #iFile
' Remove any group rows
AllowGrouping = False
' Write out info that allows us to detect the data
' version for future updates
Put #iFile, , "SGrid002.000.000" ' 16 chars
' Space for the length of the data
lLenPos = Seek(iFile)
Put #iFile, , lLen
' Write the number of rows
Put #iFile, , m_iRows
' And the internal number of allocated cells
Put #iFile, , m_iTotalCellRows
' Garbage row count
Put #iFile, , m_colGarbageRows.Count
' Write the data
Put #iFile, , m_tRows
Put #iFile, , m_tCells
' Write out the garbage row list
If (m_colGarbageRows.Count > 0) Then
Dim v As Variant
Dim i As Long
Dim lGarbage() As Long
ReDim lGarbage(1 To m_colGarbageRows.Count) As Long
For Each v In m_colGarbageRows
i = i + 1
lGarbage(i) = v
Next
Put #iFile, , lGarbage
End If
' Write the length
lNowPos = Seek(iFile)
lLen = lNowPos - lLenPos - 4
Seek #iFile, lLenPos
Put #iFile, , lLen
Seek #iFile, lNowPos
Close #iFile
Exit Sub
ErrorHandler:
Dim sErr As String
Dim lErr As Long
sErr = Err.Description
lErr = Err.Number
On Error Resume Next
Close #iFile
Kill sFile
On Error GoTo 0
gErr lErr, sErr
Exit Sub
End Sub
Public Sub LoadGridData(ByVal sFile As String)
Attribute LoadGridData.VB_Description = "Loads data from a grid that was
previously saved using SaveGridData."
Dim sSaveVer As String
Dim iFile As Integer
On Error GoTo ErrorHandler
iFile = FreeFile
Open sFile For Binary Access Read Lock Write As #iFile
sSaveVer = Space(16)
Get #iFile, , sSaveVer
Clear
Select Case sSaveVer
Case "SGrid002.000.000"
loadGridData_2_0_0 iFile
Case Else
Close #iFile
On Error GoTo 0
gErr 502, "Unsupported data version"
End Select
Close #iFile
UserControl_Resize
Exit Sub
ErrorHandler:
Dim sErr As String
Dim lErr As Long
sErr = Err.Description
lErr = Err.Number
On Error Resume Next
Close #iFile
On Error GoTo 0
gErr lErr, sErr
Exit Sub
End Sub
Private Sub loadGridData_2_0_0(ByVal iFile As Integer)
Dim lLen As Long
Dim iGarbageRows As Long
Dim i As Long
Get #iFile, , lLen ' Not used by this routine, but could be used for a
sanity check
Get #iFile, , m_iRows ' Number of rows
If (m_iRows > 0) Then
Get #iFile, , m_iTotalCellRows ' Number of cells allocated
Get #iFile, , iGarbageRows ' Number of garbage rows
' Prepare the arrays
ReDim m_tRows(0 To m_iRows) As tRowPosition
ReDim m_tCells(1 To m_iCols, 1 To m_iTotalCellRows) As tGridCell
If (iGarbageRows > 0) Then
ReDim lGarbage(1 To iGarbageRows) As Long
End If
' Read the data
Get #iFile, , m_tRows
Get #iFile, , m_tCells
' Read the garbage rows
If (iGarbageRows > 0) Then
Get #iFile, , lGarbage
For i = 1 To iGarbageRows
m_colGarbageRows.Add lGarbage(i)
Next i
End If
' Set max row height:
m_lMaxRowHeight = m_lDefaultRowHeight
For i = 1 To m_iRows
If (m_tRows(i).lHeight > m_lMaxRowHeight) Then
m_lMaxRowHeight = m_tRows(i).lHeight
End If
Next i
BuildMemDC m_lMaxRowHeight
End If
End Sub
Public Property Get OwnerDrawImpl() As IGridCellOwnerDraw
Attribute OwnerDrawImpl.VB_Description = "Gets/sets the object which implements
the IGridCellOwnerDraw interface for this grid, or Nothing if there is no
owner draw implementation."
If Not (m_lPtrOwnerDraw = 0) Then
Set OwnerDrawImpl = ObjectFromPtr(m_lPtrOwnerDraw)
End If
End Property
Public Property Let OwnerDrawImpl(impl As IGridCellOwnerDraw)
pSetOwnerDrawImpl impl
End Property
Public Property Set OwnerDrawImpl(impl As IGridCellOwnerDraw)
pSetOwnerDrawImpl impl
End Property
Private Sub pSetOwnerDrawImpl(impl As IGridCellOwnerDraw)
If (impl Is Nothing) Then
m_lPtrOwnerDraw = 0
Else
m_lPtrOwnerDraw = ObjPtr(impl)
End If
End Sub
' SPM 2003-11-10: use Mouse Hook to identify edit cancellation
Friend Function MouseEvent( _
ByVal iMsg As Long, _
ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal hitTest As Long _
) As Boolean
If (iMsg = WM_NCLBUTTONDOWN Or iMsg = WM_NCRBUTTONDOWN Or iMsg =
WM_NCMBUTTONDOWN) Then
EndEdit
If (m_bInEdit) Then
' We have requested to cancel the edit.
MouseEvent = True
End If
ElseIf (iMsg = WM_RBUTTONDOWN Or iMsg = WM_LBUTTONDOWN Or iMsg =
WM_MBUTTONDOWN) Then
' Check which type of class we are over:
Dim className As String
Dim hWndOver As Long
Dim hWndParent As Long
Dim hWndDesktop As Long
Dim hWndChild As Long
hWndDesktop = GetDesktopWindow()
hWndOver = WindowFromPoint(x, y)
hWndParent = GetParent(hWndOver)
' The owner of a combo is the desktop
If Not (hWndOver = hWndDesktop) Then
If (GetProp(hWndOver, MAGIC_END_EDIT_IGNORE_WINDOW_PROP) = 0) Then
className = WindowClassName(hWndOver)
' Extra check for ComboLBox probably isn't needed, but menus have a
parent 0
If (InStr(className, "ComboLBox") = 0) And (InStr(className,
"#32768") = 0) Then ' second check!
' Check if the mouse event is within the boundaries of
' the cell that is being edited:
Dim pt As POINTAPI
Dim cursorPos As POINTAPI
GetCursorPos cursorPos
LSet pt = cursorPos
ScreenToClient UserControl.hwnd, pt
Dim tR As RECT
Dim lWidth As Long
Dim lHeight As Long
Dim clickedInCell As Boolean
Dim lOffsetX As Long
CellBoundary m_iEditRow, m_iEditCol, tR.left, tR.top, lWidth,
lHeight
lOffsetX = m_tCells(m_iEditCol,
m_tRows(m_iEditRow).lGridCellArrayRow).lIndent + _
(Abs(m_tCells(m_iEditCol,
m_tRows(m_iEditRow).lGridCellArrayRow).iIconIndex <> -1) *
m_lIconSizeX) + _
(Abs(m_tCells(m_iEditCol,
m_tRows(m_iEditRow).lGridCellArrayRow).lExtraIconIndex <>
-1) * m_lIconSizeX)
tR.left = tR.left \ Screen.TwipsPerPixelX - lOffsetX
tR.top = tR.top \ Screen.TwipsPerPixelY
tR.right = tR.left + lWidth \ Screen.TwipsPerPixelX + lOffsetX
tR.bottom = tR.top + lHeight \ Screen.TwipsPerPixelY
If (pt.x >= tR.left And pt.x <= tR.right) Then
If (pt.y >= tR.top And pt.y <= tR.bottom) Then
clickedInCell = True
End If
End If
If Not (clickedInCell) Then
EndEdit
If (m_bInEdit) Then
' We have requested to cancel cancelling the edit.
MouseEvent = True
Else
GetWindowRect m_hWnd, tR
If Not (PtInRect(tR, cursorPos.x, cursorPos.y) = 0) Then
m_iRepostMsg = iMsg
LSet m_tRepostPos = cursorPos
Dim bShift As Boolean
Dim bAlt As Boolean
Dim bCtrl As Boolean
bShift = (GetAsyncKeyState(vbKeyShift) <> 0)
bAlt = (GetAsyncKeyState(vbKeyMenu) <> 0)
bCtrl = (GetAsyncKeyState(vbKeyControl) <> 0)
m_lRepostShiftState = Abs(bShift * vbShiftMask) Or
Abs(bCtrl * vbCtrlMask) Or Abs(bAlt * vbAltMask)
End If
End If
End If
End If
End If
End If
End If
End Function
Public Property Get HideGroupingBox() As Boolean
Attribute HideGroupingBox.VB_Description = "When AllowGrouping is True,
Gets/sets whether the drag-drop area for grouping rows is hidden."
HideGroupingBox = m_cHeader.HideGroupingBox
End Property
Public Property Let HideGroupingBox(ByVal Value As Boolean)
If Not (m_cHeader.HideGroupingBox = Value) Then
m_cHeader.HideGroupingBox = Value
UserControl_Resize
PropertyChanged "HideGroupingBox"
End If
End Property
Public Property Get AllowGrouping() As Boolean
Attribute AllowGrouping.VB_Description = "Gets/sets whether the header shows a
grouping box to drag header items into."
AllowGrouping = m_cHeader.AllowGrouping
End Property
Public Property Let AllowGrouping(ByVal Value As Boolean)
Dim bRedraw As Boolean
If Not (m_cHeader.AllowGrouping = Value) Then
m_cHeader.AllowGrouping = Value
If Not (Value) Then
If (m_bRedraw) Then
bRedraw = True
Redraw = False
End If
pRemoveGroupingRows
pSyncHeaderOrder
pRowVisibility m_lSplitRow + 1
If (bRedraw) Then
Redraw = True
End If
End If
UserControl_Resize
PropertyChanged "AllowGrouping"
End If
End Property
Public Property Get GroupBoxHintText() As String
Attribute GroupBoxHintText.VB_Description = "Gets/sets the text shown in the
column header grouping box when no column headers are grouped."
GroupBoxHintText = m_cHeader.GroupBoxHintText
End Property
Public Property Let GroupBoxHintText(ByVal sText As String)
m_cHeader.GroupBoxHintText = sText
If (m_cHeader.AllowGrouping) Then
UserControl.Refresh
End If
PropertyChanged "GroupBoxHintText"
End Property
Private Function GetParentFormhWNd() As Long
Dim lHWnd As Long
Dim lhWndParent As Long
lHWnd = UserControl.hwnd
lhWndParent = GetParent(lHWnd)
Do While Not (lhWndParent = 0) And Not (IsWindowVisible(lhWndParent) = 0)
lHWnd = lhWndParent
lhWndParent = GetParent(lHWnd)
Loop
GetParentFormhWNd = lHWnd
' Detect if we're running in the VB IDE - the Message Loop
' works in a different way in the IDE compared to as an EXE.
' In an EXE, we need to repost end edit mouse events over the
' control once it is re-enabled. In the EXE, we don't.
' Bitch!
Dim sClass As String
sClass = WindowClassName(lHWnd)
' In the IDE, the form's name starts with 'ThunderForm' or 'ThunderMDIForm'.
' In EXE, it starts with 'ThunderRT'. We assume that this message loop
' hacking does not occur in other apps, but it may be that it also occurs
' in MS Office...
If InStr(sClass, "ThunderForm") = 1 Or InStr(sClass, "ThunderMDIForm") = 1
Then
m_bRunningInVBIDE = True
End If
End Function
Public Property Get HighlightSelectedIcons() As Boolean
Attribute HighlightSelectedIcons.VB_Description = "Gets/sets whether icons in
selected cells will be highlighted using the selection colour."
HighlightSelectedIcons = m_bHighlightSelectedIcons
End Property
Public Property Let HighlightSelectedIcons(ByVal bHighlight As Boolean)
m_bHighlightSelectedIcons = bHighlight
PropertyChanged "HighlightSelectedIcons"
End Property
Public Property Get DrawFocusRectangle() As Boolean
Attribute DrawFocusRectangle.VB_Description = "Gets/sets whether a focus
rectangle (dotted line around the selection) will be shown."
DrawFocusRectangle = m_bDrawFocusRectangle
End Property
Public Property Let DrawFocusRectangle(ByVal bDraw As Boolean)
m_bDrawFocusRectangle = bDraw
PropertyChanged "DrawFocusRectangle"
End Property
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Gets/sets whether the grid is enabled or
not. Note the grid can still be read when it is disabled, but cannot be
selected or edited."
Enabled = m_bEnabled
End Property
Public Property Let Enabled(ByVal bState As Boolean)
Dim iRow As Long, iCol As Long
m_bEnabled = bState
m_cHeader.Enabled = bState
If UserControl.Ambient.UserMode Then
m_bDirty = True
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag = True
Next iCol
Next iRow
' 19/10/1999 (14):
Draw
UserControl_Paint
End If
PropertyChanged "Enabled"
End Property
Public Property Get DisableIcons() As Boolean
Attribute DisableIcons.VB_Description = "Gets/sets whether icons are drawn
disabled when the control is disabled."
DisableIcons = m_bDisableIcons
End Property
Public Property Let DisableIcons(ByVal bState As Boolean)
m_bDisableIcons = bState
If Not (m_bEnabled) Then
m_bDirty = True
Draw
End If
PropertyChanged "DisableIcons"
End Property
Public Property Get Editable() As Boolean
Attribute Editable.VB_Description = "Gets/sets whether the grid will be
editable (i.e. raise RequestEdit events)."
Editable = m_bEditable
End Property
Public Property Let Editable(ByVal bState As Boolean)
If Not (m_bEditable = bState) Then
m_bEditable = bState
PropertyChanged "Editable"
End If
End Property
Public Property Get SingleClickEdit() As Boolean
Attribute SingleClickEdit.VB_Description = "Gets/sets whether the control
immediately goes into edit mode on selection of a cell when in EditMode. The
default is two-click edit."
SingleClickEdit = m_bSingleClickEdit
End Property
Public Property Let SingleClickEdit(ByVal bState As Boolean)
If Not (m_bSingleClickEdit = bState) Then
m_bSingleClickEdit = bState
PropertyChanged "SingleClickEdit"
End If
End Property
Public Property Get SortObject() As cGridSortObject
Attribute SortObject.VB_Description = "Returns a reference to the sort object
where grid sorting options can be specified."
Set SortObject = m_cSort
End Property
Public Sub Sort()
Attribute Sort.VB_Description = "Sorts the grid data according to the options
set up in the SortObject."
Dim sKey As String
Dim i As Long
Dim j As Long
Dim bS As Boolean
Dim bResetRedraw As Boolean
Dim iSortRowBefore As Long
If m_iRows > 0 And m_iCols > 0 Then
bResetRedraw = m_bRedraw
If (bResetRedraw) Then
m_bRedraw = False
End If
If (m_iSelRow > 0) And (m_iSelRow <= m_iRows) Then
If (m_iSelCol > 0) And (m_iSelCol <= m_iCols) Then
iSortRowBefore = m_tRows(m_iSelRow).lGridCellArrayRow
End If
End If
If Not (m_cSort.GridMatch) Then
'
pSyncHeaderWithSort
If (m_cHeader.ColumnGroupCount > 0) Then
pRemoveGroupingRows
End If
'
End If
m_cSort.SortItems m_tCells(), m_tRows(), m_lSplitRow + 1, m_iRows
m_tRows(m_lSplitRow + 1).lStartY = 0
If Not (m_cSort.GridMatch) Then
If (m_cHeader.ColumnGroupCount > 0) Then
' put the grouping rows back in
pAddGroupingRows
End If
m_cSort.SetGridMatch
End If
pRowVisibility m_lSplitRow + 1
bS = m_bNoOptimiseScroll
m_bNoOptimiseScroll = True
m_bDirty = True
If (iSortRowBefore > 0) Then
m_iSelRow = 0
For i = 1 To m_iRows
If (m_tRows(i).lGridCellArrayRow = iSortRowBefore) Then
m_iSelRow = i
Exit For
End If
Next i
If (m_iSelRow > 0) Then
If Not (pbEnsureVisible(m_iSelRow, m_iSelCol)) Then
End If
End If
End If
If (bResetRedraw) Then
m_bRedraw = True
Draw
End If
m_bNoOptimiseScroll = bS
Else
' That makes the sort somewhat quicker :)
End If
End Sub
Private Sub pSyncHeaderWithSort()
Dim iCol As Long
Dim lHeaderCol As Long
Dim iSortCol As Long
Dim iSortOrder As Long
' First make sure that there are no orphan group
' items, if there are then shuffle
m_cSort.RemoveGroupBubbles
' Now check if the header's grouped items match
' up with what's in the sort:
For iCol = 1 To m_iCols
If (m_tCols(iCol).lHeaderColIndex > 0) Then
iSortOrder = -1
lHeaderCol = m_tCols(iCol).lHeaderColIndex - 1
For iSortCol = 1 To m_cSort.Count
If (m_cSort.GridColumnArrayIndex(iSortCol) = iCol) Then
If (m_cSort.GroupBy(iSortCol)) Then
iSortOrder = iSortCol - 1
Exit For
End If
End If
Next iSortCol
If (m_cHeader.ColumnIsGrouped(lHeaderCol)) Then
If (m_cHeader.ColumnGroupOrder(lHeaderCol) = iSortOrder) Then
' No change for this column
Else
If (iSortOrder = -1) Then
' has been removed
m_cHeader.ColumnIsGrouped(lHeaderCol) = False
Else
' has had its order changed
m_cHeader.ColumnGroupOrder(lHeaderCol) = iSortOrder
End If
End If
Else
If (iSortOrder = -1) Then
' No change for this column
Else
' has been added as a new group at this order:
m_cHeader.ColumnIsGrouped(lHeaderCol) = True
m_cHeader.ColumnGroupOrder(lHeaderCol) = iSortOrder
End If
End If
End If
Next iCol
End Sub
Public Property Get EvaluateTextHeight( _
ByVal lRow As Long, _
ByVal lCol As Long _
) As Long
Attribute EvaluateTextHeight.VB_Description = "Determines the ideal height
required to display all the cell's text in a cell. This property is only of
any use if the Cell's CellTextAlign property allows multiple lines."
Dim hFntOld As Long
Dim tR As RECT
Dim sCopy As String
Dim iCol As Long, lCCol As Long
' Ensure correct font:
If (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iFntIndex <> 0) Then
hFntOld = SelectObject(m_hDC, m_hFnt(m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).iFntIndex))
End If
' Draw the text, calculating rect:
If Not IsMissing(m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText) Then
sCopy = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText
For iCol = 1 To m_iCols
If (m_tCols(iCol).lCellColIndex = lCol) Then
lCCol = iCol
Exit For
End If
Next iCol
If Len(m_tCols(lCCol).sFmtString) > 0 Then
sCopy = Format$(sCopy, m_tCols(lCCol).sFmtString)
End If
tR.right = m_tCols(lCCol).lWidth - 4 - 2 * Abs(m_bGridLines And Not
(m_bNoVerticalGridLines))
tR.right = tR.right - m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).lIndent
If (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iIconIndex >= 0) Then
tR.right = tR.right - m_lIconSizeX - 2
End If
If (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).lExtraIconIndex >= 0)
Then
tR.right = tR.right - m_lIconSizeX - 2
End If
DrawText m_hDC, sCopy & vbNullChar, -1, tR, m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).eTextFlags Or DT_CALCRECT
EvaluateTextHeight = tR.bottom - tR.top
Else
' don't need to do anything:
End If
If (hFntOld <> 0) Then
SelectObject m_hDC, hFntOld
hFntOld = 0
End If
End Property
Public Property Get EvaluateTextWidth( _
ByVal lRow As Long, _
ByVal lCol As Long, _
Optional ByVal bForceNoModify As Boolean = True _
) As Long
Attribute EvaluateTextWidth.VB_Description = "Determines the ideal width
required to fully display text in a cell."
EvaluateTextWidth = plEvaluateTextWidth(lRow, lCol, bForceNoModify, 0)
End Property
Private Property Get plEvaluateTextWidth( _
ByVal lRow As Long, _
ByVal lCol As Long, _
ByVal bForceNoModify As Boolean, _
ByVal lMaxWidth As Long _
) As Long
Dim hFntOld As Long
Dim tR As RECT
Dim sCopy As String
Dim sOrig As String
Dim iCol As Long
Dim lCCol As Long
Dim eFlags As ECGTextAlignFlags
Dim lLastRight As Long
' Ensure correct font:
If (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iFntIndex <> 0) Then
hFntOld = SelectObject(m_hDC, m_hFnt(m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).iFntIndex))
End If
' Find the index of lCol in the columns array:
For iCol = 1 To m_iCols
If (m_tCols(iCol).lCellColIndex = lCol) Then
lCCol = iCol
Exit For
End If
Next iCol
' Evaluate the text in the cell:
If Not (IsMissing(m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText))
Then
sCopy = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText
End If
If Len(m_tCols(lCCol).sFmtString) > 0 Then
sCopy = Format$(sCopy, m_tCols(lCCol).sFmtString)
End If
eFlags = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).eTextFlags Or
DT_CALCRECT
' For multi line we specify the right so we get a height:
If (eFlags And DT_WORDBREAK) = DT_WORDBREAK Then
tR.right = m_tCols(lCCol).lWidth
If (lMaxWidth > tR.right) Then
tR.right = lMaxWidth
End If
End If
If (bForceNoModify) Then
eFlags = eFlags And Not (DT_WORD_ELLIPSIS Or DT_PATH_ELLIPSIS Or
DT_MODIFYSTRING Or DT_END_ELLIPSIS)
End If
sOrig = sCopy
DrawText m_hDC, sCopy & vbNullChar, -1, tR, eFlags
If (eFlags And DT_WORDBREAK) = DT_WORDBREAK Then
Do While (tR.bottom > m_tRows(lRow).lHeight)
sCopy = sOrig
' Extend in blocks of 16 until we fit...
tR.right = tR.right + 16
lLastRight = tR.right
DrawText m_hDC, sCopy & vbNullChar, -1, tR, eFlags
tR.right = lLastRight
Loop
End If
plEvaluateTextWidth = tR.right - tR.left
If (hFntOld <> 0) Then
SelectObject m_hDC, hFntOld
hFntOld = 0
End If
End Property
Public Property Get RowTextStartColumn() As Long
Attribute RowTextStartColumn.VB_Description = "Gets/sets the column that text
in the RowText column will start drawing at."
Attribute RowTextStartColumn.VB_MemberFlags = "400"
RowTextStartColumn = m_lRowTextStartCol
End Property
Public Property Let RowTextStartColumn(ByVal lColumn As Long)
m_lRowTextStartCol = lColumn
End Property
Public Property Let DefaultRowHeight(ByVal lHeight As Long)
Attribute DefaultRowHeight.VB_Description = "Gets/sets the height which will be
used as a default for rows in the grid."
m_lDefaultRowHeight = lHeight
PropertyChanged "DefaultRowHeight"
End Property
Public Property Get DefaultRowHeight() As Long
DefaultRowHeight = m_lDefaultRowHeight
End Property
Public Property Get Redraw() As Boolean
Attribute Redraw.VB_Description = "Gets/sets whether the grid is redrawn in
response to changes. Set to False whilst setting many properties to increase
speed. Setting to True after it has been False forces a re-draw of the
control."
Attribute Redraw.VB_ProcData.VB_Invoke_Property = ";Behavior"
Redraw = m_bRedraw
End Property
Public Property Let Redraw(ByVal bState As Boolean)
m_bRedraw = bState
If (UserControl.Ambient.UserMode) And (bState) Then
m_bDirty = True
If (m_cHeader.AllowGrouping And Not (m_cHeader.HideGroupingBox)) Then
UserControl_Paint
Else
Draw
pResizeHeader
End If
End If
PropertyChanged "Redraw"
End Property
Public Property Get EditRow() As Long
Attribute EditRow.VB_Description = "Returns the index of the row currently
being edited, if any."
EditRow = m_iEditRow
End Property
Public Property Get EditCol() As Long
Attribute EditCol.VB_Description = "Returns the index of the column currently
being edited, if any."
EditCol = m_iEditCol
End Property
Public Property Get SelectionCount() As Long
Attribute SelectionCount.VB_Description = "In row mode; gets the number of
selected rows in the grid, otherwise gets the number of selected cells in the
grid."
Dim iRow As Long
Dim iCol As Long
Dim iSelCount As Long
If (m_bMultiSelect) Then
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected) Then
iSelCount = iSelCount + 1
If (m_bRowMode) Then
Exit For
End If
End If
Next iCol
Next iRow
SelectionCount = iSelCount
Else
SelectionCount = Abs(m_iSelRow > 0 And m_iSelCol > 0)
End If
End Property
Public Property Get SelectedRowByIndex(ByVal lIndex As Long) As Long
Attribute SelectedRowByIndex.VB_Description = "Gets the row of the selected
cell or row with the specified 1-based index. See also SelectionCount."
Dim iRow As Long
Dim iCol As Long
Dim lSelIndex As Long
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected) Then
lSelIndex = lSelIndex + 1
If (lIndex = lSelIndex) Then
SelectedRowByIndex = iRow
Exit Property
End If
If (m_bRowMode) Then
Exit For
End If
End If
Next iCol
Next iRow
End Property
Public Property Get SelectedColByIndex(ByVal lIndex As Long)
Attribute SelectedColByIndex.VB_Description = "Gets the column of the selected
cell with the specified 1-based index. See also SelectionCount."
Dim iRow As Long
Dim iCol As Long
Dim lSelIndex As Long
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected) Then
lSelIndex = lSelIndex + 1
If (lIndex = lSelIndex) Then
SelectedColByIndex = iCol
Exit Property
End If
If (m_bRowMode) Then
Exit For
End If
End If
Next iCol
Next iRow
End Property
Public Property Get SelectedRow() As Long
Attribute SelectedRow.VB_Description = "Gets the selected row. In multi-select
mode, this is the most recently selected row."
Attribute SelectedRow.VB_MemberFlags = "400"
SelectedRow = m_iSelRow
End Property
Public Property Let SelectedRow(ByVal lRow As Long)
Dim iCol As Long
Dim iRow As Long
If (m_iSelCol = 0) Then
'm_iSelCol = plGetFirstVisibleColumn()
End If
If (lRow > 0) And (lRow <= m_iRows) Then
m_iSelRow = lRow
If (m_bMultiSelect) Then
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_bRowMode) Then
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected
<> (iRow = m_iSelRow))
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
(iRow = m_iSelRow)
Else
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected)
<> ((iCol = m_iSelCol) And (iRow = m_iSelRow))
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
((iCol = m_iSelCol) And (iRow = m_iSelRow))
End If
Next iCol
Next iRow
Else
pSingleModeSelect
End If
If Not (pbEnsureVisible(m_iSelRow, m_iSelCol)) Then
Draw
End If
Else
gErr 9, "Row subscript out of range"
End If
End Property
Public Property Get HotCol() As Long
Attribute HotCol.VB_Description = "Gets the current Hot column (or 0 if no hot
column) when HotTrack is True."
If (m_bHotTrack) Then
HotCol = m_lHotTrackCol
End If
End Property
Public Property Get HotRow() As Long
Attribute HotRow.VB_Description = "Gets the current hot row (or 0 if no hot
row) when HotTrack is True."
If (m_bHotTrack) Then
HotRow = m_lHotTrackRow
End If
End Property
Public Property Get SelectedCol() As Long
Attribute SelectedCol.VB_Description = "Gets the selected column. In
multi-select mode, this is the most recently selected column."
Attribute SelectedCol.VB_MemberFlags = "400"
SelectedCol = m_iSelCol
End Property
Public Property Let SelectedCol(ByVal lCol As Long)
Dim iRow As Long
Dim iCol As Long
If (lCol > 0) And (lCol <= m_iCols) Then
m_iSelCol = lCol
If (m_bMultiSelect) Then
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_bRowMode) Then
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected
<> (iRow = m_iSelRow))
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
(iRow = m_iSelRow)
Else
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected)
<> ((iCol = m_iSelCol) And (iRow = m_iSelRow))
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
((iCol = m_iSelCol) And (iRow = m_iSelRow))
End If
Next iCol
Next iRow
Else
pSingleModeSelect
End If
If Not (pbEnsureVisible(m_iSelRow, m_iSelCol)) Then
Draw
End If
Else
gErr 9, "Column subscript out of range"
End If
End Property
Public Property Let ScrollBarStyle(ByVal eStyle As ECGScrollBarStyles)
Attribute ScrollBarStyle.VB_Description = "Gets/sets the style in which scroll
bars are drawn. Flat or Encarta style scroll bars are only supported in
systems with COMCTL32.DLL version 4.72 or higher."
m_eScrollStyle = eStyle
If Not (m_cScroll Is Nothing) Then
m_cScroll.Style = eStyle
End If
PropertyChanged "ScrollBarStyle"
End Property
Public Property Get ScrollBarStyle() As ECGScrollBarStyles
ScrollBarStyle = m_eScrollStyle
End Property
Public Property Get CellFormattedText(ByVal lRow As Long, ByVal lCol As Long)
As String
Attribute CellFormattedText.VB_Description = "Gets the text of a cell with any
formatting string applicable to the cell's column applied."
Dim iCCol As Long
Dim iCol As Long
For iCol = 1 To m_iCols
If (m_tCols(iCol).lCellColIndex = lCol) Then
iCCol = iCol
Exit For
End If
Next iCol
If Len(m_tCols(iCCol).sFmtString) > 0 Then
CellFormattedText = Format$(m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).sText, m_tCols(iCCol).sFmtString)
Else
CellFormattedText = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText
End If
End Property
Public Property Get CellText(ByVal lRow As Long, ByVal lCol As Long) As Variant
Attribute CellText.VB_Description = "Gets/sets the text associated with a cell.
This property is a variant allowing you to store Numbers and Dates as well.
In columns which are not visible, it could also be used to store objects. "
If pbValid(lRow, lCol) Then
CellText = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText
End If
End Property
Public Property Let CellText(ByVal lRow As Long, ByVal lCol As Long, ByVal
sText As Variant)
Dim bMissing As Boolean
Dim bMissingNew As Boolean
Dim bChanged As Boolean
If pbValid(lRow, lCol) Then
bMissing = IsMissing(m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).sText)
bMissingNew = IsMissing(sText)
If (bMissing Or bMissingNew) Then
If Not (bMissing = bMissingNew) Then
bChanged = True
End If
Else
If Not (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText = sText)
Then
bChanged = True
End If
End If
If (bChanged) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).sText = sText
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End If
End Property
Public Property Get CellTextAlign(ByVal lRow As Long, ByVal lCol As Long) As
ECGTextAlignFlags
Attribute CellTextAlign.VB_Description = "Gets/sets the alignment and
formatting properties used to draw cell text."
If pbValid(lRow, lCol) Then
CellTextAlign = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).eTextFlags
End If
End Property
Public Property Let CellTextAlign(ByVal lRow As Long, ByVal lCol As Long, ByVal
eAlign As ECGTextAlignFlags)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).eTextFlags = eAlign Or
DT_NOPREFIX And Not DT_CALCRECT
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Property
Public Property Get CellIndent(ByVal lRow As Long, ByVal lCol As Long) As Long
Attribute CellIndent.VB_Description = "Gets/sets the horizontal indentation of
a cell from the cell's border."
If pbValid(lRow, lCol) Then
CellIndent = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).lIndent
End If
End Property
Public Property Let CellIndent(ByVal lRow As Long, ByVal lCol As Long, ByVal
lIndent As Long)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).lIndent = lIndent
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Property
Public Property Get CellExtraIcon(ByVal lRow As Long, ByVal lCol As Long) As
Long
Attribute CellExtraIcon.VB_Description = "Gets/sets the extra icon for a cell.
This icon will always appear in the leftmost position for the cell. Set
CellExtraIcon to -1 to remove an icon. CellExtraIcons represent ImageList
icon indexes and run from 0 to Count-1."
If pbValid(lRow, lCol) Then
CellExtraIcon = m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).lExtraIconIndex
End If
End Property
Public Property Let CellExtraIcon(ByVal lRow As Long, ByVal lCol As Long, ByVal
lIconIndex As Long)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).lExtraIconIndex =
lIconIndex
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Property
Public Property Get CellItemData(ByVal lRow As Long, ByVal lCol As Long) As Long
Attribute CellItemData.VB_Description = "Gets/sets a long value associated with
the cell."
If pbValid(lRow, lCol) Then
CellItemData = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).lItemData
End If
End Property
Public Property Let CellItemData(ByVal lRow As Long, ByVal lCol As Long, ByVal
lItemData As Long)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).lItemData = lItemData
End If
End Property
Public Property Get CellSelected(ByVal lRow As Long, ByVal lCol As Long) As
Boolean
Attribute CellSelected.VB_Description = "Gets/sets whether a cell is selected
or not."
If pbValid(lRow, lCol) Then
CellSelected = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bSelected
End If
End Property
Public Property Let CellSelected(ByVal lRow As Long, ByVal lCol As Long, ByVal
bState As Boolean)
Dim iInitSelCol As Long
Dim iInitSelRow As Long
Dim iCol As Long
If pbValid(lRow, lCol) Then
' for single select mode, bstate is ignored.
If (m_bMultiSelect) Then
iInitSelCol = m_iSelCol
iInitSelRow = m_iSelRow
m_iSelRow = lRow
m_iSelCol = lCol
If (m_bRowMode) Then
For iCol = 1 To m_iCols
m_tCells(iCol, m_tRows(m_iSelRow).lGridCellArrayRow).bDirtyFlag
= (m_tCells(iCol,
m_tRows(m_iSelRow).lGridCellArrayRow).bSelected <> bState)
m_tCells(iCol, m_tRows(m_iSelRow).lGridCellArrayRow).bSelected =
bState
Next iCol
Else
m_tCells(m_iSelCol,
m_tRows(m_iSelRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(m_iSelCol,
m_tRows(m_iSelRow).lGridCellArrayRow).bSelected <> bState)
m_tCells(m_iSelCol, m_tRows(m_iSelRow).lGridCellArrayRow).bSelected
= bState
End If
Draw
Else
iInitSelCol = m_iSelCol
iInitSelRow = m_iSelRow
m_iSelRow = lRow
m_iSelCol = lCol
pSingleModeSelect
If Not (pbEnsureVisible(m_iSelRow, m_iSelCol)) Then
Draw
End If
If (iInitSelCol <> m_iSelCol) Or (iInitSelRow <> m_iSelRow) Then
RaiseEvent SelectionChange(m_iSelRow, m_iSelCol)
End If
End If
End If
End Property
Public Property Get CellIcon(ByVal lRow As Long, ByVal lCol As Long) As Long
Attribute CellIcon.VB_Description = "Gets/sets the icon for a cell. If the
cell has an icon set via the CellExtraIcon property, this icon will appear
after it. Set CellIcon to -1 to remove an icon. CellIcons represent
ImageList icon indexes and run from 0 to Count-1."
If pbValid(lRow, lCol) Then
CellIcon = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iIconIndex
End If
End Property
Public Property Let CellIcon(ByVal lRow As Long, ByVal lCol As Long, ByVal
lIconIndex As Long)
If pbValid(lRow, lCol) Then
If Not (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iIconIndex =
lIconIndex) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iIconIndex = lIconIndex
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End If
End Property
Public Property Get CellBackColor(ByVal lRow As Long, ByVal lCol As Long) As
OLE_COLOR
Attribute CellBackColor.VB_Description = "Gets/sets the background colour for a
cell. Set to -1 to make the cell transparent."
If pbValid(lRow, lCol) Then
CellBackColor = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).oBackColor
End If
End Property
Public Property Let CellBackColor(ByVal lRow As Long, ByVal lCol As Long, ByVal
oColor As OLE_COLOR)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).oBackColor = oColor
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Property
Public Property Get CellForeColor(ByVal lRow As Long, ByVal lCol As Long) As
OLE_COLOR
Attribute CellForeColor.VB_Description = "Gets/sets the foreground colour to
draw a cell in. Set to -1 to use the default foreground colour."
If pbValid(lRow, lCol) Then
CellForeColor = m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).oForeColor
End If
End Property
Public Property Let CellForeColor(ByVal lRow As Long, ByVal lCol As Long, ByVal
oColor As OLE_COLOR)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).oForeColor = oColor
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Property
Public Sub CellDefaultForeColor(ByVal lRow As Long, ByVal lCol As Long)
Attribute CellDefaultForeColor.VB_Description = "Sets a cell to use the default
foreground colour (the fore colour of the control)."
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).oForeColor = CLR_NONE
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Sub
Public Sub CellDefaultBackColor(ByVal lRow As Long, ByVal lCol As Long)
Attribute CellDefaultBackColor.VB_Description = "Sets a cell to use the default
background colour (transparent)."
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).oBackColor = CLR_NONE
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Sub
Public Property Get CellFont(ByVal lRow As Long, ByVal lCol As Long) As StdFont
Attribute CellFont.VB_Description = "Gets/sets the font to use to draw a cell."
If pbValid(lRow, lCol) Then
If (m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iFntIndex = 0) Then
Set CellFont = UserControl.Font
Else
Set CellFont = m_Fnt(m_tCells(lCol,
m_tRows(lRow).lGridCellArrayRow).iFntIndex)
End If
End If
End Property
Public Property Let CellFont(ByVal lRow As Long, ByVal lCol As Long, ByVal sFnt
As StdFont)
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iFntIndex =
plAddFontIfRequired(sFnt)
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Property
Public Sub CellDefaultFont(ByVal lRow As Long, ByVal lCol As Long)
Attribute CellDefaultFont.VB_Description = "Sets a cell to use the default
font."
If pbValid(lRow, lCol) Then
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).iFntIndex = 0
m_tCells(lCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Draw
End If
End Sub
Public Property Get MultiSelect() As Boolean
Attribute MultiSelect.VB_Description = "Gets/sets whether multiple grid cells
or rows can be selected or not."
Attribute MultiSelect.VB_ProcData.VB_Invoke_Property = ";Behavior"
MultiSelect = m_bMultiSelect
End Property
Public Property Let MultiSelect(ByVal bState As Boolean)
Dim iCol As Long
Dim iRow As Long
If (bState <> m_bMultiSelect) Then
If Not (bState) Then
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_bRowMode) Then
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected
<> (iRow = m_iSelRow))
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
(iRow = m_iSelRow)
Else
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
(m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected
<> ((iRow = m_iSelRow) And (iCol = m_iSelCol)))
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
((iRow = m_iSelRow) And (iCol = m_iSelCol))
End If
Next iCol
Next iRow
End If
End If
m_bMultiSelect = bState
m_bMarquee = bState
Draw
PropertyChanged "MultiSelect"
End Property
Public Property Get SplitRow() As Long
Attribute SplitRow.VB_Description = "Gets/sets the index of the row to split
the grid at. Set to 0 for no split."
SplitRow = m_lSplitRow
End Property
Public Property Let SplitRow(ByVal lRow As Long)
If Not (m_lSplitRow = lRow) Then
m_lSplitRow = lRow
pResizeHeader
If (m_iRows > m_lSplitRow) Then
m_tRows(m_lSplitRow + 1).lStartY = 0
pRowVisibility m_lSplitRow + 1
End If
UserControl_Paint
End If
End Property
Public Property Get SplitSeparatorSize() As Long
Attribute SplitSeparatorSize.VB_Description = "Gets/sets the height of the
separator between rows before SplitRow and rows after."
SplitSeparatorSize = m_lSplitSeparatorSize
End Property
Public Property Let SplitSeparatorSize(ByVal lSize As Long)
If Not (m_lSplitSeparatorSize = lSize) Then
m_lSplitSeparatorSize = lSize
pResizeHeader
Draw
PropertyChanged "SplitSeparatorSize"
End If
End Property
Private Function plSplitSize() As Long
If (m_lSplitRow > 0) Then
Dim lSplitSize As Long
Dim iRow As Long
For iRow = 1 To m_lSplitRow
If (iRow < m_iRows) Then
lSplitSize = lSplitSize + m_tRows(iRow).lHeight
Else
lSplitSize = lSplitSize + m_lDefaultRowHeight
End If
Next iRow
plSplitSize = lSplitSize + m_lSplitSeparatorSize
End If
End Function
Public Property Get RowMode() As Boolean
Attribute RowMode.VB_Description = "Gets/sets whether cells can be selected in
the grid (False) or rows (True)."
Attribute RowMode.VB_ProcData.VB_Invoke_Property = ";Behavior"
RowMode = m_bRowMode
End Property
Public Property Let RowMode(ByVal bState As Boolean)
Dim iCol As Long
Dim iRow As Long
Dim bSelRow As Boolean
m_bRowMode = bState
If Not (m_bMultiSelect) Then
If (m_iSelRow > 0) And (m_iSelCol > 0) Then
For iCol = 1 To m_iCols
m_tCells(iCol, m_tRows(m_iSelRow).lGridCellArrayRow).bDirtyFlag =
True
If (bState) Then
m_tCells(iCol, m_tRows(m_iSelRow).lGridCellArrayRow).bSelected =
True
Else
m_tCells(iCol, m_tRows(m_iSelRow).lGridCellArrayRow).bSelected =
(iCol = m_iSelCol)
End If
Next iCol
End If
Else
If (bState) Then
For iRow = 1 To m_iRows
For iCol = 1 To m_iCols
If (m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected)
Then
bSelRow = True
Exit For
End If
Next iCol
If (bSelRow) Then
For iCol = 1 To m_iCols
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bSelected =
True
m_tCells(iCol, m_tRows(iRow).lGridCellArrayRow).bDirtyFlag =
True
Next iCol
End If
Next iRow
End If
End If
m_bDirty = True
Draw
PropertyChanged "RowMode"
End Property
Public Property Get RowIsGroup(ByVal lRow As Long) As Boolean
Attribute RowIsGroup.VB_Description = "Gets/sets whether a row should be
regarded as a group row."
If (lRow > 0) And (lRow <= m_iRows) Then
RowIsGroup = m_tRows(lRow).bGroupRow
Else
gErr 9, "Invalid Row Subscript"
End If
End Property
Public Property Get RowGroupingState(ByVal lRow As Long) As ECGGroupRowState
Attribute RowGroupingState.VB_Description = "Gets/sets the state (expanded or
collapsed) for a grouping row."
If (lRow > 0) And (lRow <= m_iRows) Then
If (m_tRows(lRow).bGroupRow) Then
If (lRow < m_iRows) Then
If (m_tRows(lRow + 1).bCollapsed) Then
RowGroupingState = ecgCollapsed
Else
RowGroupingState = ecgExpanded
End If
End If
Else
gErr 501, "The selected row is not a grouping row."
End If
Else
gErr 9, "Invalid Row Subscript"
End If
End Property
Public Property Let RowGroupingState(ByVal lRow As Long, ByVal eState As
ECGGroupRowState)
Dim eCurrentState As ECGGroupRowState
If (lRow > 0) And (lRow <= m_iRows) Then
If (m_tRows(lRow).bGroupRow) Then
If (lRow < m_iRows) Then
If (m_tRows(lRow + 1).bCollapsed) Then
eCurrentState = ecgCollapsed
Else
eCurrentState = ecgExpanded
End If
If Not (eCurrentState = eState) Then
pExpandCollapseGroupingRow lRow
End If
End If
Else
gErr 501, "The selected row is not a grouping row."
End If
Else
gErr 9, "Invalid Row Subscript"
End If
End Property
Public Property Get RowGroupingLevel(ByVal lRow As Long) As Long
Attribute RowGroupingLevel.VB_Description = "Gets the grouping level of the
specified row if the row is a group row. The grouping level specifies how far
this group row is indented, with level 1 being the first group, 2 being the
second and so on."
Dim lMax As Long
If (lRow > 0) And (lRow < m_iRows) Then
lMax = m_cHeader.ColumnGroupCount
If (lMax = 0) Then
RowGroupingLevel = 0
Else
If (m_tRows(lRow).lGroupIndentLevel > 0) Then
RowGroupingLevel = m_tRows(lRow).lGroupIndentLevel
Else
RowGroupingLevel = lMax
End If
End If
Else
gErr 9, "Invalid Row Subscript"
End If
End Property
Public Property Get RowGroupStartColumn(ByVal lRow As Long) As Long
Attribute RowGroupStartColumn.VB_Description = "Gets/sets the row at which the
grouped column's cells start drawing."
If (lRow > 0) And (lRow <= m_iRows) Then
RowGroupStartColumn = m_tRows(lRow).lGroupStartColIndex
Else
gErr 9, "Invalid Row Subscript"
End If
End Property
Public Property Let RowGroupStartColumn(ByVal lRow As Long, ByVal lColumn As
Long)
Dim iCol As Long
If (lRow > 0) And (lRow <= m_iRows) Then
If m_tRows(lRow).lGroupStartColIndex <> lColumn Then
m_tRows(lRow).lGroupStartColIndex = lColumn
For iCol = 1 To m_iCols
m_tCells(iCol, m_tRows(lRow).lGridCellArrayRow).bDirtyFlag = True
Next iCol
Draw
End If
Else
gErr 9, "Invalid Row Subscript"
End If
End Property
Public Property Get GridLines() As Boolean
Attribute GridLines.VB_Description = "Gets/sets whether grid-lines are drawn or
not."
Attribute GridLines.VB_ProcData.VB_Invoke_Property = ";Appearance"
GridLines = m_bGridLines
End Property
Public Property Let GridLines(ByVal bState As Boolean)
m_bDirty = Not (bState = m_bGridLines)
m_bGridLines = bState
If (m_bDirty) Then
Draw
End If
PropertyChanged "GridLines"
End Property
Public Property Get NoVerticalGridLines() As Boolean
Attribute NoVerticalGridLines.VB_Description = "Gets/sets whether vertical grid
lines should be supressed when grid lines are on."
' 2003-11-26
NoVerticalGridLines = m_bNoVerticalGridLines
End Property
Public Property Let NoVerticalGridLines(ByVal bState As Boolean)
' 2003-11-26
m_bDirty = (m_bGridLines And (bState <> m_bNoVerticalGridLines))
m_bNoVerticalGridLines = bState
If (m_bDirty) Then
Draw
End If
PropertyChanged "NoVerticalGridLines"
End Property
Public Property Get NoHorizontalGridLines() As Boolean
Attribute NoHorizontalGridLines.VB_Description = "Gets/sets whether horizontal
grid lines should be supressed when grid lines are on."
' 2003-11-26
NoHorizontalGridLines = m_bNoHorizontalGridLines
End Property
Public Property Let NoHorizontalGridLines(ByVal bState As Boolean)
' 2003-11-26
m_bDirty = (m_bGridLines And (bState <> m_bNoHorizontalGridLines))
m_bNoHorizontalGridLines = bState
If (m_bDirty) Then
Draw
End If
PropertyChanged "NoHorizontalGridLines"
End Property
Public Property Get GridLineMode() As ECGGridLineMode
Attribute GridLineMode.VB_Description = "Gets/sets the grid line mode. The
mode can either be standard, in which grid lines are only drawn around cells,
or fill, in which case the grid lines fill the control."
' 2003-11-26
GridLineMode = m_eGridLineMode
End Property
Public Property Let GridLineMode(ByVal eMode As ECGGridLineMode)
' 2003-11-26
If Not (m_eGridLineMode = eMode) Then
m_eGridLineMode = eMode
If (m_bGridLines) Then
m_bDirty = True
Draw
End If
PropertyChanged "GridLineMode"
End If
End Property
Public Property Let HeaderImageList(vThis As Variant)
Attribute HeaderImageList.VB_Description = "Gets/sets an ImageList to associate
with the Header control. By default, the ImageList associated with the
control is used."
Dim hImlHeader As Long
' Set the ImageList handle property either from a VB
' image list or directly:
If VarType(vThis) = vbObject Then
' Assume VB ImageList control. Note that unless
' some call has been made to an object within a
' VB ImageList the image list itself is not
' created. Therefore hImageList returns error. So
' ensure that the ImageList has been initialised by
' drawing into nowhere:
On Error Resume Next
' Get the image list initialised..
vThis.ListImages(1).Draw 0, 0, 0, 1
hImlHeader = vThis.hImagelist
If (Err.Number <> 0) Then
hImlHeader = 0
Else
' Check for VB6 image list:
If (TypeName(vThis) = "ImageList") Then
If (vThis.ListImages.Count <>
ImageList_GetImageCount(hImlHeader)) Then
' VB6 Image List is no good
gErr 1049, _
"Cannot use MSCOMCTL.OCX ImageList for the
HeaderImageList."
hImlHeader = 0
End If
End If
End If
On Error GoTo 0
ElseIf IsNumeric(vThis) Then
On Error Resume Next
' Assume ImageList handle:
hImlHeader = CLng(vThis)
If Not (Err.Number = 0) Then
gErr 1049, "ImageList property expects ImageList object or long
hImageList handle."
End If
Else
gErr 1049, "ImageList property expects ImageList object or long
hImageList handle."
End If
' Set or remove the header image list:
m_cHeader.SetImageList UserControl.hdc, hImlHeader
m_bHeaderImageListSet = True
End Property
Public Property Let ImageList(vThis As Variant)
Attribute ImageList.VB_Description = "Sets an ImageList as the source of icons
for the control. The ImageList can be either a VB ImageList, a vbAccelerator
ImageList or an API hIml handle. If it is a VB Image List, the Image List
must have had at least one icon in it before using this prop"
Attribute ImageList.VB_ProcData.VB_Invoke_PropertyPut = ";Behavior"
Dim hIml As Long
m_hIml = 0
m_ptrVb6ImageList = 0
' Set the ImageList handle property either from a VB
' image list or directly:
If VarType(vThis) = vbObject Then
' Assume VB ImageList control. Note that unless
' some call has been made to an object within a
' VB ImageList the image list itself is not
' created. Therefore hImageList returns error. So
' ensure that the ImageList has been initialised by
' drawing into nowhere:
On Error Resume Next
' Get the image list initialised..
vThis.ListImages(1).Draw 0, 0, 0, 1
hIml = vThis.hImagelist
If (Err.Number <> 0) Then
hIml = 0
Else
' Check for VB6 image list:
If (TypeName(vThis) = "ImageList") Then
If (vThis.ListImages.Count <> ImageList_GetImageCount(hIml))
Then
Dim o As Object
Set o = vThis
m_ptrVb6ImageList = ObjPtr(o)
End If
End If
End If
On Error GoTo 0
ElseIf IsNumeric(vThis) Then
On Error Resume Next
' Assume ImageList handle:
hIml = CLng(vThis)
If Not (Err.Number = 0) Then
gErr 1049, "ImageList property expects ImageList object or long
hImageList handle."
End If
Else
gErr 1049, "ImageList property expects ImageList object or long
hImageList handle."
End If
' If we have a valid image list, then associate it with the control:
If Not (hIml = 0) Or Not (m_ptrVb6ImageList = 0) Then
m_hIml = hIml
If Not (m_hIml = 0) Then
If Not (m_bHeaderImageListSet) Then
m_cHeader.SetImageList UserControl.hdc, hIml
End If
End If
If (m_ptrVb6ImageList = 0) Then
ImageList_GetIconSize m_hIml, m_lIconSizeX, m_lIconSizeY
Else
m_lIconSizeX = vThis.ImageWidth
m_lIconSizeY = vThis.ImageHeight
End If
End If
End Property
Public Property Set BackgroundPicture(sPic As StdPicture)
Attribute BackgroundPicture.VB_Description = "Gets/sets a picture to be used as
the grid's background."
Attribute BackgroundPicture.VB_ProcData.VB_Invoke_PropertyPutRef = ";Appearance"
On Error Resume Next
Set picImage.Picture = sPic
picImage.Refresh
If (Err.Number <> 0) Or (picImage.ScaleWidth = 0) Or (sPic Is Nothing) Then
m_hDCSrc = 0
m_bBitmap = False
Else
m_bBitmap = True
m_hDCSrc = picImage.hdc
m_lBitmapW = picImage.ScaleWidth \ Screen.TwipsPerPixelX
m_lBitmapH = picImage.ScaleHeight \ Screen.TwipsPerPixelY
End If
m_bDirty = True
Draw
PropertyChanged "BackgroundPicture"
End Property
Public Property Get BackgroundPictureHeight() As Long
Attribute BackgroundPictureHeight.VB_Description = "Gets/sets the height of the
background picture."
Attribute BackgroundPictureHeight.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute BackgroundPictureHeight.VB_MemberFlags = "400"
BackgroundPictureHeight = m_lBitmapH
End Property
Public Property Let BackgroundPictureHeight(ByVal lHeight As Long)
m_lBitmapH = lHeight
PropertyChanged "BackgroundPictureHeight"
End Property
Public Property Get BackgroundPictureWidth() As Long
Attribute BackgroundPictureWidth.VB_Description = "Gets/sets the width of the
background picture."
Attribute BackgroundPictureWidth.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute BackgroundPictureWidth.VB_MemberFlags = "400"
BackgroundPictureWidth = m_lBitmapW
End Property
Public Property Let BackgroundPictureWidth(ByVal lWidth As Long)
m_lBitmapW = lWidth
PropertyChanged "BackgroundPictureWidth"
End Property
Public Property Get BackgroundPicture() As StdPicture
Set BackgroundPicture = picImage.Picture
End Property
Public Property Get AlternateRowBackColor() As OLE_COLOR
Attribute AlternateRowBackColor.VB_Description = "Gets/sets the background
colour to use when rendering alternate rows. Set to -1 to use the standard
back colour."
AlternateRowBackColor = m_oAlternateRowBackColor
End Property
Public Property Let AlternateRowBackColor(ByVal oColor As OLE_COLOR)
If Not (m_oAlternateRowBackColor = oColor) Then
m_oAlternateRowBackColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "AlternateRowBackColor"
End If
End Property
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Gets/sets the background color of the
grid."
Attribute BackColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute BackColor.VB_UserMemId = -501
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
UserControl.BackColor = oColor
If (m_hDC <> 0) Then
SetBkColor m_hDC, TranslateColor(UserControl.BackColor)
End If
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "BackColor"
End Property
Public Property Get HighlightBackColor() As OLE_COLOR
Attribute HighlightBackColor.VB_Description = "Gets/sets the background colour
of highlighted cells. Set to -1 to use the default."
' 19/10/1999 (8)
HighlightBackColor = m_oHighlightBackColor
End Property
Public Property Let HighlightBackColor(oColor As OLE_COLOR)
' 19/10/1999 (8)
m_oHighlightBackColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "HighlightBackColor"
End Property
Public Property Get HighlightForeColor() As OLE_COLOR
Attribute HighlightForeColor.VB_Description = "Gets/sets the foreground colour
of highlighted cells. Set to -1 to use the default."
' 19/10/1999 (8)
HighlightForeColor = m_oHighlightForeColor
End Property
Public Property Let HighlightForeColor(oColor As OLE_COLOR)
' 19/10/1999 (8)
m_oHighlightForeColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "HighlightForeColor"
End Property
Public Property Get NoFocusHighlightBackColor() As OLE_COLOR
Attribute NoFocusHighlightBackColor.VB_Description = "Gets/sets the highlight
background colour for cells when the grid is out of focus. Use -1 for the
default colour."
' 2003-11-26
NoFocusHighlightBackColor = m_oNoFocusHighlightBackColor
End Property
Public Property Let NoFocusHighlightBackColor(ByVal oColor As OLE_COLOR)
' 2003-11-26
m_oNoFocusHighlightBackColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "NoFocusHighlightBackColor"
End Property
Public Property Get NoFocusHighlightForeColor() As OLE_COLOR
Attribute NoFocusHighlightForeColor.VB_Description = "Gets/sets the highlight
foreground colour for cells when the grid is out of focus. Use -1 for the
default colour."
' 2003-11-26
NoFocusHighlightForeColor = m_oNoFocusHighlightForeColor
End Property
Public Property Let NoFocusHighlightForeColor(ByVal oColor As OLE_COLOR)
' 2003-11-26
m_oNoFocusHighlightForeColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "NoFocusHighlightForeColor"
End Property
Public Property Get GroupingAreaBackColor() As OLE_COLOR
Attribute GroupingAreaBackColor.VB_Description = "Gets/sets the colour of the
column grouping area."
GroupingAreaBackColor = m_oGroupAreaBackColor
End Property
Public Property Let GroupingAreaBackColor(ByVal oColor As OLE_COLOR)
m_oGroupAreaBackColor = oColor
If (m_bRedraw And m_cHeader.AllowGrouping And Not
(m_cHeader.HideGroupingBox)) Then
m_bDirty = True
UserControl_Paint
End If
PropertyChanged "GroupingAreaBackColor"
End Property
Public Property Get GroupingGutterBackColor() As OLE_COLOR
Attribute GroupingGutterBackColor.VB_Description = "Gets/sets the colour used
to fill the gutter to the near side of a row which is indented in a group."
GroupingGutterBackColor = m_oGutterBackColor
End Property
Public Property Let GroupingGutterBackColor(ByVal oColor As OLE_COLOR)
m_oGutterBackColor = oColor
If (m_bRedraw And m_cHeader.AllowGrouping) Then
m_bDirty = True
Draw
End If
PropertyChanged "GutterBackColor"
End Property
Public Property Get GroupRowBackColor() As OLE_COLOR
Attribute GroupRowBackColor.VB_Description = "Gets/sets the background colour
for grouping rows."
GroupRowBackColor = m_oGroupRowBackColor
End Property
Public Property Let GroupRowBackColor(ByVal oColor As OLE_COLOR)
m_oGroupRowBackColor = oColor
If (m_bRedraw And m_cHeader.AllowGrouping And m_cHeader.ColumnGroupCount >
0) Then
m_bDirty = True
Draw
End If
PropertyChanged "GroupRowBackColor"
End Property
Public Property Get GroupRowForeColor() As OLE_COLOR
Attribute GroupRowForeColor.VB_Description = "Gets/sets the foreground colour
of the text in grouping rows."
GroupRowForeColor = m_oGroupRowForeColor
End Property
Public Property Let GroupRowForeColor(ByVal oColor As OLE_COLOR)
m_oGroupRowForeColor = oColor
If (m_bRedraw And m_cHeader.AllowGrouping And m_cHeader.ColumnGroupCount >
0) Then
m_bDirty = True
Draw
End If
PropertyChanged "GroupRowForeColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Gets/sets the foreground color used to
draw the control."
Attribute ForeColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute ForeColor.VB_UserMemId = -513
ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal oColor As OLE_COLOR)
UserControl.ForeColor = oColor
If (m_hDC <> 0) Then
SetTextColor m_hDC, TranslateColor(oColor)
End If
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "ForeColor"
End Property
Public Property Get GridLineColor() As OLE_COLOR
Attribute GridLineColor.VB_Description = "Gets/sets the colour used to draw
grid lines."
Attribute GridLineColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
GridLineColor = m_oGridLineColor
End Property
Public Property Let GridLineColor(ByVal oColor As OLE_COLOR)
m_oGridLineColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "GridLineColor"
End Property
Public Property Get GridFillLineColor() As OLE_COLOR
Attribute GridFillLineColor.VB_Description = "Gets the colour used to draw fill
grid lines. Set to -1 to use the default grid line colour."
GridFillLineColor = m_oGridFillLineColor
End Property
Public Property Let GridFillLineColor(ByVal oColor As OLE_COLOR)
m_oGridFillLineColor = oColor
If (m_bRedraw) Then
m_bDirty = True
Draw
End If
PropertyChanged "GridFillLineColor"
End Property
Public Property Get Font() As StdFont
Attribute Font.VB_Description = "Gets/sets the font used by the control."
Attribute Font.VB_ProcData.VB_Invoke_Property = ";Appearance"
Attribute Font.VB_UserMemId = -512
Dim tLF As LOGFONT
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal sFont As StdFont)
Dim tLF As LOGFONT
Set UserControl.Font = sFont
m_cHeader.SetFont UserControl.hdc, sFont
If (m_hFntDC <> 0) Then
If (m_hDC <> 0) Then
If (m_hFntOldDC <> 0) Then
SelectObject m_hDC, m_hFntOldDC
End If
DeleteObject m_hFntDC
End If
End If
pOLEFontToLogFont sFont, UserControl.hdc, tLF
m_hFntDC = CreateFontIndirect(tLF)
If (m_hDC <> 0) Then
m_hFntOldDC = SelectObject(m_hDC, m_hFntDC)
End If
PropertyChanged "Font"
End Property
Public Property Get AddRowsOnDemand() As Boolean
Attribute AddRowsOnDemand.VB_Description = "Gets/sets whether the grid is in
Virtual Mode (i.e. rows are added as required via the RequestRow and
RequestRowData events)."
AddRowsOnDemand = m_bAddRowsOnDemand
End Property
Public Property Let AddRowsOnDemand(ByVal bAddRowsOnDemand As Boolean)
m_bAddRowsOnDemand = bAddRowsOnDemand
If Not m_bAddRowsOnDemand Then
m_bInAddRowRequest = False
Else
m_bInAddRowRequest = True
End If
PropertyChanged "AddRowsOnDemand"
End Property
''' <summary>
''' Draws all the dirty cells in the grid.
''' </summary>
Public Sub Draw()
Attribute Draw.VB_Description = "Draws the control."
Dim bDirty As Boolean
If (m_bRedraw) Then
' Draw split row cells:
If (m_lSplitRow > 0) Then
bDirty = m_bDirty
pDraw True
m_bDirty = bDirty
End If
' Draw main grid:
pDraw False
End If
End Sub
''' <summary>
''' Draws all the dirty cells in the grid.
''' </summary>
''' <param name="bSplitArea">Whether drawing the split area or not</param>
Private Sub pDraw(ByVal bSplitArea As Boolean)
''' TODO this function is hopelessly procedural, it needs to be split
''' up so each cell draws itself. However, there are issues with
''' making sure the selection is drawn correctly in that case.
''' Not just that, but variables are being reused for other purposes
''' which is pretty rubbish. Bad Boy! In your bed!
Dim iStartRow As Long
Dim iStartCol As Long
Dim iStartX As Long
Dim iStartY As Long
Dim lRowStartX As Long
Dim lThisRowStartX As Long
Dim lRowEndX As Long
Dim iEndRow As Long
Dim iEndCol As Long
Dim lStartX As Long
Dim lStartY As Long
Dim iEndX As Long
Dim iEndY As Long
Dim iY As Long
Dim iRow As Long
Dim iCol As Long
Dim iCellCol As Long
Dim iCRowTextCol As Long
Dim iFirstColInSelect As Long
Dim iLastColInSelect As Long
Dim tR As RECT
Dim tTR As RECT
Dim tBR As RECT
Dim tFR As RECT
Dim tLR As RECT
Dim tGR As RECT
Dim sText As String
Dim sCopy As String
Dim sHeaderTitle As String
Dim lBltOffset As Long
Dim lBltStart As Long
Dim lBltHeight As Long
Dim hBr As Long
Dim hBrGrid As Long
Dim hBrGridFill As Long
Dim hBrGutter As Long
Dim hFntOld As Long
Dim lLastPos As Long
Dim lOffsetX As Long
Dim lOffsetY As Long
Dim bSel As Boolean
Dim bDoIt As Boolean
Dim bCellSelected As Boolean
Dim bGroupLastDrawn As Boolean
Dim lStartColIndex As Long
Dim lItemData As Long
Dim bVisible As Boolean
Dim bGroupRow As Boolean
Dim bNoMoreRows As Boolean
Dim lHeight As Long
Dim bRecall As Boolean
Dim bDefaultStartCol As Boolean
Dim bHeaderTruncateDraw As Boolean
Dim bAlternateRow As Boolean
Dim lHighlightColor As Long
Dim bLastSelCol() As Boolean
Dim impl As IGridCellOwnerDraw
Dim cCell As cGridCell
Dim bSkipDefault As Boolean
' No redrawing is done unless we are in run mode and
' the redraw flag is set:
If m_bRedraw And m_bUserMode Then
If Not (m_lPtrOwnerDraw = 0) Then
Set impl = ObjectFromPtr(m_lPtrOwnerDraw)
End If
lStartY = m_lStartY
' Get the initial offset for the top row of the grid:
If (m_cHeader.Visible) Then
lOffsetX = m_cHeader.ColumnGroupCount * m_lDefaultRowHeight
lOffsetY = m_cHeader.Height + m_cHeader.top
End If
If (bSplitArea) Then
lStartY = 0
Else
lOffsetY = lOffsetY + plSplitSize()
End If
' Get the size of the control and prepare to draw:
GetClientRect UserControl.hwnd, tR
tBR.right = m_lAvailWidth + 24 + Abs(m_tCols(iStartCol).lStartX -
m_lStartX)
tBR.bottom = m_lMaxRowHeight
' Ensure the scroll bars are set correctly:
If pbScrollVisible() Then
UserControl_Resize
' Resize redraws entire control;
' no need to do it again
Exit Sub
End If
' Find the start and end of drawing:
GetStartEndCell _
bSplitArea, _
iStartRow, iStartCol, iStartX, iStartY, _
iEndRow, iEndCol, iEndX, iEndY, bAlternateRow
If (iEndCol >= iStartCol) Then
ReDim bLastSelCol(iStartCol To iEndCol) As Boolean
End If
' If in add rows on demand mode then we prepare for more rows:
If (m_bAddRowsOnDemand And m_bInAddRowRequest) Then
If (iEndY < m_lAvailheight) Then
iY = iEndY
Do
iEndRow = iEndRow + 1
iY = iY + m_lDefaultRowHeight
Loop While iY < m_lAvailheight
End If
End If
' Evaluate the default group column start & end:
lStartColIndex = m_lRowTextStartCol
bDefaultStartCol = (lStartColIndex = 0)
For iCol = 1 To m_iCols
If iFirstColInSelect = 0 Then
If (m_tCols(iCol).bIncludeInSelect And m_tCols(iCol).bVisible) Then
iFirstColInSelect = iCol
iLastColInSelect = iCol
iCRowTextCol = iCol
lRowStartX = m_tCols(iCol).lStartX - m_lStartX
If (m_lRowTextStartCol = 0) Then
lStartColIndex = iCol
End If
End If
ElseIf (m_tCols(iCol).bVisible And Not (m_tCols(iCol).bRowTextCol))
Then
iLastColInSelect = iCol
End If
If (m_tCols(iCol).lCellColIndex = lStartColIndex) And Not
(bDefaultStartCol) Then
lRowStartX = m_tCols(iCol).lStartX - m_lStartX
ElseIf (m_tCols(iCol).lCellColIndex = m_iRowTextCol) Then
iCRowTextCol = iCol
ElseIf (m_tCols(iCol).bVisible And m_tCols(iCol).iGroupOrder = -1) Then
If (m_tCols(iCol).lStartX + m_tCols(iCol).lWidth - m_lStartX) >
lRowEndX Then
lRowEndX = m_tCols(iCol).lStartX + m_tCols(iCol).lWidth -
m_lStartX
End If
End If
Next iCol
'Set up for grid lines:
If (m_bGridLines) Then
If (m_bEnabled) Then
hBrGrid = CreateSolidBrush(TranslateColor(m_oGridLineColor))
hBrGridFill = CreateSolidBrush(TranslateColor(m_oGridFillLineColor))
Else
hBrGrid = GetSysColorBrush(vbGrayText And &H1F&)
hBrGridFill = GetSysColorBrush(vbGrayText And &H1F&)
End If
End If
' Text colour for disabled grid:
If Not (m_bEnabled) Then
SetTextColor m_hDC, TranslateColor(vbGrayText)
End If
' Draw the dirty cells:
For iRow = iStartRow To iEndRow
' Request new row if in add rows on demand mode:
If (iRow > m_iRows) Then
If m_iCols > 0 Then
If (m_bAddRowsOnDemand) Then
lHeight = m_lDefaultRowHeight
bVisible = True
RaiseEvent RequestRow(iRow, lItemData, bVisible, lHeight,
bNoMoreRows)
If bNoMoreRows Then
' that's it
m_bInAddRowRequest = False
pbScrollVisible
bRecall = True
Exit For
Else
AddRow , lItemData, bVisible, lHeight
pbScrollVisible
RaiseEvent RequestRowData(iRow)
End If
Else
' This does not occur:
Debug.Assert iRow <= m_iRows
Exit For
End If
Else
' Can't do it until cols are set up
' 2004-01-14: Removed exit sub here, it caused GDI leak - erk..
End If
End If
' If the row should be drawn:
If (m_tRows(iRow).bVisible) Then
bAlternateRow = Not (bAlternateRow)
tR.top = 0
tR.bottom = tR.top + m_tRows(iRow).lHeight
pFillBackground m_hDC, tBR, 0, m_tRows(iRow).lStartY - lStartY,
bAlternateRow
If Not (m_oGutterBackColor = CLR_NONE) Then
' *** not working yet, doh... ***
'hBrGutter = CreateSolidBrush(TranslateColor(m_oGutterBackColor))
'LSet tGR = tBR
'tGR.right = tGR.left + (m_cHeader.ColumnGroupCount -
m_tRows(iRow).lGroupIndentLevel + 1) * 16
'FillRect m_HDC, tGR, hBrGutter
'DeleteObject hBrGutter
End If
bDoIt = m_bDirty
If Not (bDoIt) Then
' Any dirty cells on this row?
If m_tRows(iRow).bGroupRow Then
If m_tCells(m_iRowTextCol,
m_tRows(iRow).lGridCellArrayRow).bDirtyFlag Then
bDoIt = True
m_tCells(m_iRowTextCol,
m_tRows(iRow).lGridCellArrayRow).bDirtyFlag = False
End If
Else
For iCol = iStartCol To iEndCol
iCellCol = m_tCols(iCol).lCellColIndex
If m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).bDirtyFlag Then
bDoIt = True
m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).bDirtyFlag = False
End If
Next iCol
End If
End If
If (bDoIt) Then
' Draw individual columns unless this row has the group row
style, in
' which case we draw only the RowTextColumn.
If Not (m_tRows(iRow).bGroupRow) Then
For iCol = iStartCol To iEndCol
If (m_tCols(iCol).bVisible And m_tCols(iCol).iGroupOrder =
-1) And Not (iCol = m_iRowTextCol) Then
bSkipDefault = False
bCellSelected = False
iCellCol = m_tCols(iCol).lCellColIndex
tR.left = m_tCols(iCol).lStartX - m_lStartX +
m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).lIndent
tR.right = tR.left + m_tCols(iCol).lWidth -
m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).lIndent
OffsetRect tR, -1, 0
' 2004-01-15 Owner Draw pre
If Not (m_lPtrOwnerDraw = 0) Then
Set cCell = cell(iRow, iCellCol)
impl.Draw cCell, m_hDC, ecgBeforeAll, tR.left,
tR.top, tR.right, tR.bottom, bSkipDefault
End If
If Not (bSkipDefault) Then
' 2004-01-10
' Moving this here ensures that if there is an
indent with a background colour
' then the background is correctly filled before the
selection starts
If (m_bEnabled) Then
If Not (m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).oBackColor =
CLR_NONE) Then
hBr =
CreateSolidBrush(TranslateColor(m_tCells(iCell
Col,
m_tRows(iRow).lGridCellArrayRow).oBackColor))
LSet tTR = tR
If Not (m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).lIndent = 0)
Then
tTR.left = tTR.left - m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).lIndent
End If
FillRect m_hDC, tTR, hBr
DeleteObject hBr
End If
If Not (m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).oForeColor =
CLR_NONE) Then
SetTextColor m_hDC,
TranslateColor(m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).oForeColor)
bSel = True
Else
If (bSel) Then
SetTextColor m_hDC,
TranslateColor(UserControl.ForeColor)
bSel = False
End If
End If
End If
' Draw selection for this cell if that is appropriate
If (m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).bSelected) And
(m_bEnabled) Then
If (m_tCols(iCol).bIncludeInSelect) Or (iCol >=
iFirstColInSelect) Then
lHighlightColor = m_oHighlightBackColor
If (m_bInFocus) Or (m_bInEdit) Then
bCellSelected = True
Else
lHighlightColor =
m_oNoFocusHighlightBackColor
End If
If (m_bAlphaBlendSelection And m_bTrueColor)
Then
If (m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).oBackColor
= CLR_NONE) Then
hBr =
CreateSolidBrush(BlendColor(lHighlightCo
lor, UserControl.BackColor, 92))
Else
hBr =
CreateSolidBrush(BlendColor(lHighlightCo
lor, m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).oBackCo
lor))
End If
Else
hBr =
CreateSolidBrush(TranslateColor(lHighlightC
olor))
End If
LSet tTR = tR
If (m_bGridLines) Then
InflateRect tTR, Not
(m_bNoVerticalGridLines), Not
(m_bNoHorizontalGridLines)
End If
If (m_bRowMode) Then
If (iCol > iFirstColInSelect) Then
tTR.left = tTR.left - m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).lIndent
End If
End If
LSet tFR = tTR
If Not (m_bRowMode) Then
If m_bGridLines And (m_bEnabled) Then
If (iCellCol = m_iSelCol) And (iRow =
m_iSelRow) Then
If m_bDrawFocusRectangle Then
LSet tFR = tTR
InflateRect tFR, Not
(m_bNoVerticalGridLines), Not
(m_bNoHorizontalGridLines)
If Not (m_bNoVerticalGridLines)
Then
tFR.left = tFR.left - 1
Else
tFR.top = tFR.top - 1
tFR.bottom = tFR.bottom - 1
End If
If Not (m_bNoHorizontalGridLines)
Then
tFR.bottom = tFR.bottom + 1
End If
End If
End If
End If
Else
If Not (m_bGridLines) Then
tFR.top = tFR.top - 1
Else
If Not (m_bNoVerticalGridLines) Then
tFR.top = tFR.top + 1
If (iCol > iFirstColInSelect) Then
tFR.left = tFR.left - 1
Else
tFR.left = tFR.left + 1
End If
If (iCol >= iLastColInSelect) Then
tFR.right = tFR.right - 2
Else
tFR.right = tFR.right + 1
End If
End If
If Not (m_bNoHorizontalGridLines) Then
If (m_bNoVerticalGridLines) Then
tFR.bottom = tFR.bottom - 2
Else
If (iRow = m_iSelRow) Then
tFR.bottom = tFR.bottom - 1
Else
tFR.bottom = tFR.bottom + 1
End If
End If
End If
End If
End If
If (bLastSelCol(iCol)) Then
tFR.top = tFR.top - 4
End If
FillRect m_hDC, tFR, hBr
bLastSelCol(iCol) = True
DeleteObject hBr
Else
bLastSelCol(iCol) = False
End If
bSel = True
Else
bLastSelCol(iCol) = False
End If
If (m_bGridLines) Then
LSet tTR = tR
tTR.left = tTR.left - m_tCells(iCellCol,
m_tRows(iRow).lGridCellArrayRow).lIndent
tTR.right = tR.right + 1
tTR.bottom = tR.bottom + 1
If Not (m_bNoHorizontalGridLines Or
m_bNoVerticalGridLines) Then
LSet tLR = tTR
OffsetRect tLR, -1, 0
If (iRow < m_iRows) Then
If (m_tRows(iRow + 1).bGroupRow) Then
tLR.bottom = tLR.bottom - 1
End If
End If
FrameRect m_hDC, tLR, hBrGrid
Else
If (m_bNoHorizontalGridLines) And Not
(m_bNoVerticalGridLines) Then
LSet tLR = tTR
tLR.left = tLR.right - 2
tLR.right = tLR.right - 1
tLR.top = tLR.top - 1
tLR.bottom = tLR.bottom + 1
FillRect m_hDC, tLR, hBrGrid
ElseIf (m_bNoVerticalGridLines) And Not
(m_bNoHorizontalGridLines) Then
LSet tLR = tTR
tLR.top = tLR.bottom - 2
tLR.bottom = tLR.top + 1
FillRect m_hDC, tLR, hBrGrid
End If
End If
LSet tTR = tR
InflateRect tTR, -1 + Not
(m_bNoVerticalGridLines), -1 + Not
(m_bNoVerticalGridLines)
Else
LSet tTR = tR
InflateRect tTR, -1, -1
End If
If Not (m_bRowMode) Then
If (m_bEnabled) Then
If (iCellCol = m_iSelCol) And (iRow =
m_iSelRow) Then
pDrawFocusRectangle m_hDC, tFR, iCellCol,
iRow, False
ElseIf (m_tCols(iCol).lCellColIndex =
m_lHotTrackCol)