Visual Basic Controls

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / axgrid / axgrid.ctl < prev next >

Wrap

Visual Basic user-defined control file | 1998-12-10 | 115.4 KB | 3,527 lines

VERSION 5.00 Begin VB.UserControl axgrid ClientHeight = 4545 ClientLeft = 0 ClientTop = 0 ClientWidth = 7050 EditAtDesignTime= -1 'True ScaleHeight = 303 ScaleMode = 3 'Pixel ScaleWidth = 470 ToolboxBitmap = "axGrid.ctx":0000 Begin VB.CommandButton cmdLookup Height = 330 Left = 585 Picture = "axGrid.ctx":0312 Style = 1 'Graphical TabIndex = 6 TabStop = 0 'False Top = 3735 Visible = 0 'False Width = 285 End Begin VB.ListBox List1 Appearance = 0 'Flat Height = 615 ItemData = "axGrid.ctx":078C Left = 1710 List = "axGrid.ctx":078E TabIndex = 5 Top = 3465 Visible = 0 'False Width = 1185 End Begin VB.PictureBox picSizer Height = 3855 Left = 135 ScaleHeight = 3855 ScaleWidth = 15 TabIndex = 4 Top = 45 Visible = 0 'False Width = 15 End Begin VB.VScrollBar scrVertical Height = 4245 Left = 6720 Min = 1 TabIndex = 2 Top = 0 Value = 1 Visible = 0 'False Width = 285 End Begin VB.HScrollBar scrHorizontal Height = 285 Left = 0 Min = 1 TabIndex = 1 Top = 4200 Value = 1 Visible = 0 'False Width = 6735 End Begin VB.TextBox txtEdit BorderStyle = 0 'None Height = 195 Left = 5160 TabIndex = 0 Top = 3840 Visible = 0 'False Width = 1365 End Begin VB.PictureBox picGrid AutoRedraw = -1 'True BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 3360 Left = 270 ScaleHeight = 224 ScaleMode = 3 'Pixel ScaleWidth = 388 TabIndex = 3 Top = 225 Width = 5820 End End Attribute VB_Name = "axgrid" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes" Option Base 0 Private Const ALIGN_LEFT = 0 Private Const ALIGN_CENTER = 1 Private Const ALIGN_RIGHT = 2 Private Const ALIGNV_TOP = 0 Private Const ALIGNV_CENTER = 1 Private Const ALIGNV_BOTTOM = 2 Private Const STYLE_NORMAL = 0 Private Const STYLE_BUTTON = 1 Private Const STYLE_EDIT = 2 Private Const COLOR_GREY = &HC0C0C0 Private Const COLOR_DARKGREY = &H808080 Private Const m_BorderStyle_Def = 1 Private iBorderStyle As Integer Public Enum axgridBorderStyleEnum [No Border] = 0 [Single] = 1 [Thin Raised] = 2 [Thick Raised] = 3 [Thin Inset] = 4 [Thick Inset] = 5 [Etched] = 6 [Bump] = 7 End Enum Public Enum FixedStyles [Flat] = 0 [3D] = 1 End Enum Public Enum SelectModes [SelectionFree] = 0 [SelectionByRow] = 1 [SelectionByCol] = 2 End Enum Private sName As String Private bColSizing As Boolean Private bRowSizing As Boolean Private bSizingCol As Boolean Private bSizingRow As Boolean Private lTopMargin As Long Private lLeftMargin As Long Private lRightMargin As Long Private lBottomMargin As Long Private lRow1 As Long Private lCol1 As Long Private lRow2 As Long Private lCol2 As Long Private bMouseDown As Boolean Private bEditMode As Boolean Private bytEvent As Byte Private lblEvents As Label Private lCols As Long Private lRows As Long Private bColHeader As Boolean Private bRowHeader As Boolean Private bShowGrid As Boolean Private bGridSolid As Boolean Private lGridLineColor As Long Private bWidthOverflow As Boolean Private bHeightOverflow As Boolean Private bytGridLine As Byte Private lGridHeight As Long Private lGridWidth As Long Private lCol As Long Private lRow As Long Private bRedraw As Boolean Private lLargeVChange As Long Private lLargeHChange As Long Private bSelectingCols As Boolean Private bSelectingRows As Boolean Private bDAO As Boolean Private bRDO As Boolean Private bAutoNewRow As Boolean Private LookupValues As New Collection Private m_ListBoxRows As Integer Private lBackColorFixed As Long, lForeColorFixed As Long, lBackColorBkg As Long 'Private lBackColorSel As Long, lForeColorSel As Long Private bAllowSelection As Boolean, iFixedStyle As Integer, iSelectionMode As Integer Private fFont As StdFont, fFontFixed As StdFont, sFormatString As String Private bAllowUserResizing As Boolean Private lCurrentRowSizer As Long Private lCurrentColSizer As Long Private Cells As clsCellArray Private lRowHeight() As Integer Private lColWidth() As Integer, lColAlign() As Integer, bColEdit() As Boolean Private lColMask() As Integer Private hSizers As Collection Private vSizers As Collection Private lLeftCol As Long Private lTopRow As Long 'Private Type RECT ' Left As Long ' Top As Long ' Right As Long ' Bottom As Long 'End Type 'Private Type POINTAPI ' x As Long ' y As Long 'End Type Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Boolean Private Declare Function SetCursorPos Lib "user32" (ByVal lX As Long, ByVal lY As Long) As Boolean Private Declare Function InvertRect 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 LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpPoint As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 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 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 DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long 'kdq090498 added to show focus rectangle instead of black invert Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long Private Const DT_BOTTOM = &H8 Private Const DT_CALCRECT = &H400 Private Const DT_CENTER = &H1 Private Const DT_LEFT = &H0 Private Const DT_RIGHT = &H2 Private Const DT_SINGLELINE = &H20 Private Const DT_TOP = &H0 Private Const DT_VCENTER = &H4 Private Const DT_WORDBREAK = &H10 'Flags for DrawFrameControl Private Const DFC_CAPTION = 1 'Title bar Private Const DFC_MENU = 2 'Menu Private Const DFC_SCROLL = 3 'Scroll bar Private Const DFC_BUTTON = 4 'Standard button Private Const DFCS_CAPTIONCLOSE = &H0 'Close button Private Const DFCS_CAPTIONMIN = &H1 'Minimize button Private Const DFCS_CAPTIONMAX = &H2 'Maximize button Private Const DFCS_CAPTIONRESTORE = &H3 'Restore button Private Const DFCS_CAPTIONHELP = &H4 'Windows 95 only: 'Help button Private Const DFCS_MENUARROW = &H0 'Submenu arrow Private Const DFCS_MENUCHECK = &H1 'Check mark Private Const DFCS_MENUBULLET = &H2 'Bullet Private Const DFCS_MENUARROWRIGHT = &H4 Private Const DFCS_SCROLLUP = &H0 'Up arrow of scroll 'bar Private Const DFCS_SCROLLDOWN = &H1 'Down arrow of 'scroll bar Private Const DFCS_SCROLLLEFT = &H2 'Left arrow of 'scroll bar Private Const DFCS_SCROLLRIGHT = &H3 'Right arrow of 'scroll bar Private Const DFCS_SCROLLCOMBOBOX = &H5 'Combo box scroll 'bar Private Const DFCS_SCROLLSIZEGRIP = &H8 'Size grip Private Const DFCS_SCROLLSIZEGRIPRIGHT = &H10 'Size grip in 'bottom-right 'corner of window Private Const DFCS_BUTTONCHECK = &H0 'Check box Private Const DFCS_BUTTONRADIO = &H4 'Radio button Private Const DFCS_BUTTON3STATE = &H8 'Three-state button Private Const DFCS_BUTTONPUSH = &H10 'Push button Private Const DFCS_INACTIVE = &H100 'Button is inactive '(grayed) Private Const DFCS_PUSHED = &H200 'Button is pushed Private Const DFCS_CHECKED = &H400 'Button is checked Private Const DFCS_ADJUSTRECT = &H2000 'Bounding rectangle is 'adjusted to exclude the 'surrounding edge of the 'push button Private Const DFCS_FLAT = &H4000 'Button has a flat border Private Const DFCS_MONO = &H8000 'Button has a monochrome 'border Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC&, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Boolean 'Default Property Values: Const m_def_Recordset = 0 'Const m_def_RecordSource = 0 Const m_def_DataSource = 0 'Property Variables: Dim m_Recordset As Variant 'Dim m_RecordSource As Variant Dim m_DataSource As Variant 'Event EnterCell() 'MappingInfo=flxGrid,flxGrid,-1,EnterCell 'Event LeaveCell() 'MappingInfo=flxGrid,flxGrid,-1,LeaveCell Event Click() 'MappingInfo=flxGrid,flxGrid,-1,Click Event DblClick() Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=flxGrid,flxGrid,-1,KeyDown Attribute KeyDown.VB_MemberFlags = "40" Event KeyPress(KeyAscii As Integer) 'MappingInfo=flxGrid,flxGrid,-1,KeyPress Attribute KeyPress.VB_MemberFlags = "40" Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=flxGrid,flxGrid,-1,KeyUp Attribute KeyUp.VB_MemberFlags = "40" Event MouseDown(button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=flxGrid,flxGrid,-1,MouseDown Event MouseMove(button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=flxGrid,flxGrid,-1,MouseMove Attribute MouseMove.VB_MemberFlags = "40" Event MouseUp(button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=flxGrid,flxGrid,-1,MouseUp Attribute MouseUp.VB_MemberFlags = "40" Event Scroll() 'MappingInfo=flxGrid,flxGrid,-1,Scroll Event BeforeEdit(Row As Long, Col As Long, Cancel As Boolean) Attribute BeforeEdit.VB_Description = "Occurs before editing a cell" Event AfterEdit(Row As Long, Col As Long, NewValue As String) Attribute AfterEdit.VB_Description = "Occurs after ediing a cell" Event BeforeAddRow(ByVal Cancel As Boolean) Attribute BeforeAddRow.VB_Description = "Occurs before adding a new row" Event AfterAddRow(Row As Long) Attribute AfterAddRow.VB_Description = "Occurs after adding a row" Event BeforeDeleteRow(Row As Long, Cancel As Boolean) Attribute BeforeDeleteRow.VB_Description = "Occurs before deleting a row" Event AfterDeleteRow(Row As Long) Attribute AfterDeleteRow.VB_Description = "Occurs after deleting a row" Public Property Get Rows() As Long Attribute Rows.VB_Description = "Sets/gets the total number of rows in the grid" Rows = lRows End Property Public Property Let Rows(lNewValue As Long) scrVertical.Max = lNewValue InitializeRows lNewValue& lRows = lNewValue Refresh End Property Public Property Get Cols() As Long Attribute Cols.VB_Description = "Gets/sets the total number of columns in the grid" Cols = lCols End Property Public Property Let Cols(lNewValue As Long) scrHorizontal.Max = lNewValue InitializeCols lNewValue lCols = lNewValue Refresh End Property Public Sub Refresh() Dim lThisRow As Long, lThisCol As Long Dim lMyColWidth As Long, lMyRowHeight As Long Dim lpRect As RECT Dim lScaleHeight As Long, lScaleWidth As Long If bRedraw = False Then Exit Sub picGrid.Cls If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If lScaleHeight = picGrid.ScaleHeight lScaleWidth = picGrid.ScaleWidth 'Draw all the cells that will fit in the viewport RedrawAllCells True 'Draw the vertical scroll bar (if necessary) If bHeightOverflow Then If bWidthOverflow = False Then 'kdq090898 changed so scrollbars size properly scrVertical.Height = lScaleHeight Else scrVertical.Height = lScaleHeight - scrHorizontal.Height End If scrVertical.Visible = True scrVertical.Tag = True Else scrVertical.Visible = False scrVertical.Tag = False End If 'Draw the horizontal scroll bar (if necessary) If bWidthOverflow Then If bHeightOverflow = False Then 'kdq090898 changed so scrollbars size properly scrHorizontal.Width = lScaleWidth Else scrHorizontal.Width = lScaleWidth - scrVertical.Width End If scrHorizontal.Visible = True scrHorizontal.Tag = True Else scrHorizontal.Visible = False scrHorizontal.Tag = False End If 'Draw the grid border 'lpRect.Left = 0 'lpRect.Top = 0 'lpRect.Bottom = lScaleHeight 'lpRect.Right = 0 'DrawLine lpRect, vbBlack ' 'lpRect.Right = lScaleWidth 'lpRect.Bottom = 0 'DrawLine lpRect, vbBlack End Sub Private Sub DrawButton(x As Long, y As Long, lWidth As Long, lHeight As Long, Value As Integer) Dim lpRect As RECT If Value Then un2 = DFCS_BUTTONPUSH Or DFCS_PUSHED Else un2 = DFCS_BUTTONPUSH End If '********************** Draw the button **************************** un1 = DFC_BUTTON lpRect.Left = x lpRect.Top = y lpRect.Right = x + lWidth lpRect.Bottom = y + lHeight DrawBox x, y, lWidth, lHeight, COLOR_GREY 'kdq090198 clear out center of button Select Case Value Case False di = DrawEdge(picGrid.hDC, lpRect, BDR_RAISEDINNER, BF_TOPLEFT) di = DrawEdge(picGrid.hDC, lpRect, BDR_RAISEDOUTER, BF_BOTTOMRIGHT) Case True di = DrawEdge(picGrid.hDC, lpRect, BDR_SUNKENINNER, BF_TOPLEFT) di = DrawEdge(picGrid.hDC, lpRect, BDR_SUNKENOUTER, BF_BOTTOMRIGHT) End Select End Sub Public Property Get ColHeader() As Boolean Attribute ColHeader.VB_Description = "Determines if column headers are displayed" ColHeader = bColHeader End Property Public Property Let ColHeader(bNewValue As Boolean) bColHeader = bNewValue Refresh PropertyChanged "ColHeader" End Property Public Property Get RowHeader() As Boolean Attribute RowHeader.VB_Description = "Determines if row headers are displayed" RowHeader = bRowHeader End Property Public Property Let RowHeader(bNewValue As Boolean) bRowHeader = bNewValue Refresh PropertyChanged "RowHeader" End Property Public Property Get CellBackColor(lThisCol As Long, lThisRow As Long) As Long Attribute CellBackColor.VB_MemberFlags = "440" CellBackColor = Cells.BackColor(lThisCol, lThisRow) End Property Public Property Let CellBackColor(lThisCol As Long, lThisRow As Long, lNewValue As Long) Dim x As Long, y As Long, lMyColWidth As Long, lMyRowHeight As Long If bBlockMode Then Cells.BackColor(lThisCol, lThisRow) = lNewValue GetCellCoordinates lThisRow, lThisCol, x&, y& lMyColWidth = lColWidth(lThisCol) lMyRowHeight = lRowHeight(lThisRow) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight Else HilightCell HilightSelection HilightSelection lRow1, lCol1, lRow1, lCol1 For lThisRow& = lRow1 To lRow2 For lThisCol& = lCol1 To lCol2 Cells.BackColor(lThisCol, lThisRow) = lNewValue GetCellCoordinates lThisRow, lThisCol, x&, y& lMyColWidth = lColWidth(lThisCol) lMyRowHeight = lRowHeight(lThisRow) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight Next Next HilightSelection HilightSelection lRow1, lCol1, lRow1, lCol1 HilightCell End If End Property Public Property Get CellForeColor(lThisCol As Long, lThisRow As Long) As Long Attribute CellForeColor.VB_MemberFlags = "440" CellForeColor = Cells.ForeColor(lThisCol, lThisRow) End Property Public Property Let CellForeColor(lThisCol As Long, lThisRow As Long, lNewValue As Long) Dim x As Long, y As Long, lMyColWidth As Long, lMyRowHeight As Long If bBlockMode Then Cells.ForeColor(lThisCol, lThisRow) = lNewValue GetCellCoordinates lThisRow, lThisCol, x&, y& lMyColWidth = lColWidth(lThisCol) lMyRowHeight = lRowHeight(lThisRow) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight Else HilightCell HilightSelection HilightSelection lRow1, lCol1, lRow1, lCol1 For lThisRow& = lRow1 To lRow2 For lThisCol& = lCol1 To lCol2 Cells.ForeColor(lThisCol, lThisRow) = lNewValue GetCellCoordinates lThisRow, lThisCol, x&, y& lMyColWidth = lColWidth(lThisCol) lMyRowHeight = lRowHeight(lThisRow) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight Next Next HilightSelection HilightSelection lRow1, lCol1, lRow1, lCol1 HilightCell End If End Property Public Property Get TopRow() As Long Attribute TopRow.VB_Description = "Returns or sets the uppermost visible row (other than a fixed row) in the grid. " Attribute TopRow.VB_MemberFlags = "400" TopRow = lTopRow End Property Public Property Let TopRow(lNewValue As Long) lTopRow = lNewValue End Property Public Property Get LeftCol() As Long Attribute LeftCol.VB_Description = "Returns or sets the left-most visible column (other than a fixed column) in the grid control" Attribute LeftCol.VB_MemberFlags = "400" LeftCol = lLeftCol End Property Public Property Let LeftCol(lNewValue As Long) lLeftCol = lNewValue If bRedraw Then RedrawAllCells True End If End Property Private Sub DrawCell(lThisRow As Long, lThisCol As Long, x As Long, y As Long, lWidth As Long, lHeight As Long, Optional Selected) Dim XOffset As Byte, YOffset As Byte Dim lpRect As RECT, iFlags As Integer Dim cx As Long If IsMissing(Selected) Then Selected = False 'Draw the cell box If Cells.Style(lThisCol, lThisRow) = STYLE_BUTTON Then If (lThisCol = 0 Or lThisRow = 0) And iFixedStyle = 0 Then DrawBox x, y, lWidth, lHeight, lBackColorFixed Else DrawButton x, y, lWidth + 1, lHeight + 1, Cells.Value(lThisCol, lThisRow) End If XOffset = 2 YOffset = 0 Else XOffset = 2 'lCellforecolor& = Cells.BackColor(lThisCol, lThisRow) lcellbackcolor& = Cells.BackColor(lThisCol, lThisRow) If lcellbackcolor& < 0 Then lcellbackcolor& = lBackColor DrawBox x, y, lWidth, lHeight, lcellbackcolor& End If 'Print the cell text in the cell If bDAO Then If lThisRow > 0 And lThisCol > 0 Then m_Recordset.AbsolutePosition = lThisRow - 1 sCellText$ = m_Recordset(lThisCol - 1) & "" Else sCellText$ = Cells.Text(lThisCol, lThisRow) End If ElseIf bRDO Then sCellText$ = Cells.Text(lThisCol, lThisRow) Else sCellText$ = Cells.Text(lThisCol, lThisRow) End If If lThisCol <> 0 And lThisRow <> 0 And lColMask(lThisCol) = 4 Then 'draw checkmark if checkbox mask cx = x + (lWidth / 2) - 5 If Cells.Text(lThisCol, lThisRow) = "1" Then DrawRect cx, y + 2, cx + 10, y + lHeight - 2, vbBlack lpRect.Left = cx lpRect.Top = y + 2 lpRect.Bottom = y + lHeight - 2 lpRect.Right = cx + 10 DrawLine lpRect, vbBlack lpRect.Right = cx + 10 lpRect.Bottom = y + 2 lpRect.Top = y + lHeight - 2 lpRect.Left = cx DrawLine lpRect, vbBlack Else DrawBox x + 2, y + 2, lWidth - 2, lHeight - 2, lcellbackcolor& DrawRect cx, y + 2, cx + 10, y + lHeight - 2, vbBlack End If End If If (Len(sCellText$) And lColMask(lThisCol) <> 4) Or (lThisCol = 0 Or lThisRow = 0) Then If lThisCol = 0 Or lThisRow = 0 Then picGrid.ForeColor = lForeColorFixed Set picGrid.Font = fFontFixed Else If Cells.ForeColor(lThisCol, lThisRow) < 0 Then picGrid.ForeColor = lForeColor Else picGrid.ForeColor = Cells.ForeColor(lThisCol, lThisRow) End If Set picGrid.Font = fFont End If ' picGrid.FontName = Cells.FontName(lThisCol, lThisRow) ' picGrid.FontSize = Cells.FontSize(lThisCol, lThisRow) ' picGrid.FontBold = Cells.FontBold(lThisCol, lThisRow) ' picGrid.FontItalic = Cells.FontItalic(lThisCol, lThisRow) ' picGrid.FontUnderline = Cells.FontUnderline(lThisCol, lThisRow) ' picGrid.FontStrikethru = Cells.FontStrikethru(lThisCol, lThisRow) iFlags = DT_SINGLELINE 'Select Case Cells.TextAlign(lThisCol, lThisRow) Select Case lColAlign(lThisCol) 'kdq091498 Case ALIGN_LEFT iFlags = iFlags + DT_LEFT Case ALIGN_CENTER iFlags = iFlags + DT_CENTER Case ALIGN_RIGHT iFlags = iFlags + DT_RIGHT End Select Select Case Cells.TextAlignVertical(lThisCol, lThisRow) Case ALIGNV_TOP iFlags = iFlags + DT_TOP Case ALIGNV_CENTER iFlags = iFlags + DT_VCENTER Case ALIGNV_BOTTOM iFlags = iFlags + DT_BOTTOM End Select lpRect.Top = y + YOffset lpRect.Left = x + XOffset lpRect.Right = lpRect.Left + lWidth - (XOffset * 2) lpRect.Bottom = lpRect.Top + lHeight - (YOffset * 2) DrawText picGrid.hDC, sCellText$, Len(sCellText$), lpRect, iFlags End If End Sub Public Property Get ShowGrid() As Boolean Attribute ShowGrid.VB_Description = "Determines if grid lines are to be drawn" ShowGrid = bShowGrid End Property Public Property Let ShowGrid(bNewValue As Boolean) bShowGrid = bNewValue Refresh End Property Public Property Get GridSolid() As Boolean Attribute GridSolid.VB_Description = "Determines if the grid is solid or dashed" GridSolid = bGridSolid End Property Public Property Let GridSolid(bNewValue As Boolean) bGridSolid = bNewValue Refresh End Property Public Sub HChange() Attribute HChange.VB_MemberFlags = "40" Dim iDirection As Integer, lNewLeftCol As Long Dim lOldLeftCol As Long Dim lpRect As RECT, lpOldRect As RECT Dim lMyColWidth As Long Dim lMyRowHeight As Long Dim x As Long, y As Long If bEditMode Then Cells.Text(lCol, lRow) = txtEdit.Text bEditMode = False GetCellCoordinates lRow, lCol, x&, y& lMyColWidth = lColWidth(lCol) lMyRowHeight = lRowHeight(lRow) txtEdit.Visible = False txtEdit.ZOrder 1 DrawCell lRow, lCol, x&, y&, lMyColWidth, lMyRowHeight DrawGridBorder HilightCell lRow, lCol ''raiseevent leavecell End If lNewLeftCol& = scrHorizontal.Value iDirection% = lLeftCol& - lNewLeftCol& If Abs(iDirection%) = 1 Then 'picGrid.AutoRedraw = True bOldRedraw = bRedraw bRedraw = False 'Un-hilight the old selection HilightSelection 'Un-hilight the previous selected cell HilightSelection lRow1, lCol1, lRow1, lCol1 'Un-hilight the border of the previous selected cell 'HilightCell lOldLeftCol = lLeftCol lLeftCol = lNewLeftCol& 'Scroll the DC lpRect.Top = 1 If bRowHeader Then lpRect.Left = lColWidth(0) + 2 Else lpRect.Left = 1 End If lpRect.Right = picGrid.ScaleWidth - 1 If iDirection > 0 Then lMyColWidth& = lColWidth(lLeftCol&) + 1 Else lMyColWidth& = lColWidth(lOldLeftCol&) + 1 End If lpRect.Bottom = picGrid.ScaleHeight - 1 lRet = ScrollDC(picGrid.hDC, lMyColWidth& * iDirection, 0, lpRect, lpRect, hRegion, lpOldRect) If iDirection > 0 Then DrawCol lNewLeftCol&, lpRect.Left, True Else DrawRightCols lLeftCol&, lMyColWidth& End If 'DrawGrid 'kdq090498 replace because background was not being redrawn correctly RedrawAllCells True 'Hilight the new selection HilightSelection 'Un-hilight the beginning of the selection HilightSelection lRow1, lCol1, lRow1, lCol1 'Hilight the selection cell 'HilightCell bRedraw = bOldRedraw If bRedraw Then picGrid.Refresh 'picGrid.AutoRedraw = False Else lLeftCol = lNewLeftCol& RedrawAllCells True End If SetSizers End Sub Public Sub VChange() Attribute VChange.VB_MemberFlags = "40" Dim iDirection As Integer Dim lpRect As RECT, lpOldRect As RECT Dim hRegion As Long Dim lMyColWidth As Long Dim lMyRowHeight As Long Dim x As Long, y As Long If bEditMode Then 'Cells.Text(lCol, lRow) = txtEdit.Text bEditMode = False GetCellCoordinates lRow, lCol, x&, y& lMyColWidth = lColWidth(lCol) lMyRowHeight = lRowHeight(lRow) txtEdit.Visible = False txtEdit.ZOrder 1 DrawCell lRow, lCol, x&, y&, lMyColWidth, lMyRowHeight DrawGridBorder HilightCell lRow, lCol ''raiseevent leavecell End If lNewTopRow& = scrVertical.Value iDirection = lTopRow - lNewTopRow& If Abs(iDirection) = 1 Then 'picGrid.AutoRedraw = True bOldRedraw = bRedraw bRedraw = False 'Un-hilight the old selection HilightSelection 'Un-hilight the previous selected cell HilightSelection lRow1, lCol1, lRow1, lCol1 'Un-hilight the border of the previous selected cell 'HilightCell lOldTopRow& = lTopRow lTopRow = lNewTopRow& 'Scroll the DC lpRect.Left = 1 If bColHeader Then lpRect.Top = lRowHeight(0) + 2 Else lpRect.Top = 1 End If lpRect.Right = picGrid.ScaleWidth - 1 If iDirection > 0 Then lMyRowHeight& = lRowHeight(lTopRow&) + 1 Else lMyRowHeight& = lRowHeight(lOldTopRow&) + 1 End If 'If scrHorizontal.Visible Then ' lScrollHeight = scrHorizontal.Height 'Else lScrollHeight = 0 'End If lpRect.Bottom = picGrid.ScaleHeight - lScrollHeight - 1 lRet = ScrollDC(picGrid.hDC, 0, lMyRowHeight& * iDirection, lpRect, lpRect, hRegion, lpOldRect) If iDirection > 0 Then DrawRow lTopRow&, lpRect.Top, True Else DrawBottomRows lTopRow&, lMyRowHeight& End If 'DrawGrid kdq090498 replaced because background was not redrawing correctly RedrawAllCells False 'Hilight the new selection HilightSelection 'Un-hilight the beginning of the selection HilightSelection lRow1, lCol1, lRow1, lCol1 'Hilight the selection cell 'HilightCell bRedraw = bOldRedraw If bRedraw Then picGrid.Refresh 'picGrid.AutoRedraw = False Else lTopRow = lNewTopRow& RedrawAllCells False End If SetSizers End Sub Public Sub DrawRow(lThisRow As Long, y As Long, bDrawHeader As Boolean) Attribute DrawRow.VB_MemberFlags = "40" Dim lThisCol As Long, x As Long, lMyColWidth As Long, lMyRowHeight As Long Dim lScaleWidth As Long If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If lMyRowHeight = lRowHeight(lThisRow) If bRowHeader Then x& = 1 lMyColWidth = lColWidth(0) 'If bDrawHeader Then DrawCell lThisRow, 0, x&, y&, lMyColWidth, lMyRowHeight 'End If x& = x& + lMyColWidth + bytGridLine Else x& = 1 End If lScaleWidth = picGrid.ScaleWidth If lLeftCol > 1 Then bWidthOverflow = True Else bWidthOverflow = False 'kdq090198 added to make sure scrollbars turn on/off End If For lThisCol = lLeftCol To lCols lMyColWidth = lColWidth(lThisCol) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight x& = x& + lMyColWidth + bytGridLine If x& > lScaleWidth - 1 Then bWidthOverflow = True If lLargeHChange = 0 Then lLargeHChange = lThisCol - lLeftCol '- 1 scrHorizontal.LargeChange = lLargeHChange End If Exit For End If Next lGridWidth = x& - 1 If lGridWidth > lScaleWidth - 1 Then lGridWidth = lScaleWidth - 1 End Sub Public Sub DrawCol(lThisCol As Long, x As Long, bDrawHeader) Attribute DrawCol.VB_MemberFlags = "40" Dim lThisRow As Long, y As Long, lMyColWidth As Long, lMyRowHeight As Long Dim lScaleHeight As Long If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If lMyColWidth = lColWidth(lThisCol) If bColHeader Then y& = 1 lMyRowHeight = lRowHeight(0) If bDrawHeader Then DrawCell 0, lThisCol, x&, y&, lMyColWidth, lMyRowHeight End If y& = y& + lMyRowHeight + bytGridLine Else y& = 1 End If lScaleHeight& = picGrid.ScaleHeight If lTopRow > 1 Then bHeightOverflow = True Else bHeightOverflow = False 'kdq090198 added to make sure scrollbars turn on/off End If For lThisRow = lTopRow To lRows lMyRowHeight = lRowHeight(lThisRow) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight y& = y& + lMyRowHeight + bytGridLine If y& > lScaleHeight Then bHeightOverflow = True 'scrVertical.LargeChange = lThisRow - lTopRow - 2 Exit For End If Next lGridHeight = y& - 1 If lGridHeight > lScaleHeight - 1 Then lGridHeight = lScaleHeight - 1 End Sub Private Sub DrawBottomRows(lThisTopRow As Long, lUpdateHeight As Long) Dim lScaleHeight As Long, lScaleWidth As Long lScaleHeight = picGrid.ScaleHeight lScaleWidth = picGrid.ScaleWidth If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If 'If scrHorizontal.Visible Then ' lScrollHeight = scrHorizontal.Height 'Else lScrollHeight = 0 'End If If bColHeader Then y& = lRowHeight(0) + 1 + bytGridLine Else y& = 1 End If For l& = lThisTopRow To lRows lMyRowHeight = lRowHeight(l&) If y& < lScaleHeight - lScrollHeight - lUpdateHeight - lMyRowHeight - 2 Then y& = y& + lMyRowHeight + bytGridLine Else For lRemainder& = l& To lRows DrawRow lRemainder&, y&, True y& = y& + lRowHeight(lRemainder&) + bytGridLine If l& = lRows& Or y& > lScaleHeight Then Exit For End If Next Exit For End If Next lGridHeight& = y& - 1 DrawBox 1, lGridHeight + 1, lScaleWidth, lScaleHeight - lGridHeight, COLOR_GREY End Sub 'kdq090398 added this sub to draw grid border in black Private Sub DrawGridBorder(Optional StartRow, Optional StartCol, Optional EndRow, Optional EndCol) Dim lpRect As RECT If IsMissing(StartRow) Then StartRow = lTopRow If IsMissing(StartCol) Then StartCol = lLeftCol If IsMissing(EndRow) Then EndRow = lRows If IsMissing(EndCol) Then EndCol = lCols If IsMissing(Inverted) Then Inverted = False GetCellCoordinates StartRow, StartCol, x1&, y1& GetCellCoordinates EndRow, EndCol, x2&, Y2& If iFixedStyle = 0 Then 'draw top black line lpRect.Left = x1& lpRect.Top = y1& lpRect.Right = x2& + lColWidth(EndCol) lpRect.Bottom = y1& DrawLine lpRect, vbBlack End If 'draw bottom black line lpRect.Left = x1& lpRect.Top = Y2& + lRowHeight(EndRow) lpRect.Right = x2& + lColWidth(EndCol) lpRect.Bottom = Y2& + lRowHeight(EndRow) DrawLine lpRect, vbBlack 'draw left side black line If bRowHeader = False Then lpRect.Left = x1& lpRect.Top = y1& lpRect.Right = x1& lpRect.Bottom = Y2& + lRowHeight(EndRow) DrawLine lpRect, vbBlack End If 'draw right side black line lpRect.Left = x2& + lColWidth(EndCol) lpRect.Top = y1& lpRect.Right = x2& + lColWidth(EndCol) lpRect.Bottom = Y2& + lRowHeight(EndRow) DrawLine lpRect, vbBlack If iFixedStyle = 0 Then DrawRect x1&, y1& - lRowHeight(StartRow) - 1, x2& + lColWidth(EndCol), y1&, vbBlack End If End Sub Private Sub DrawGrid(Optional StartRow, Optional StartCol, Optional EndRow, Optional EndCol, Optional Inverted) Dim lScaleWidth As Long, lScaleHeight As Long Dim lpRect As RECT If IsMissing(StartRow) Then StartRow = lTopRow If IsMissing(StartCol) Then StartCol = lLeftCol If IsMissing(EndRow) Then EndRow = lRows If IsMissing(EndCol) Then EndCol = lCols If IsMissing(Inverted) Then Inverted = False lScaleHeight = picGrid.ScaleHeight lScaleWidth = picGrid.ScaleWidth If bShowGrid Then If bGridSolid = False Then picGrid.DrawStyle = 2 'dotted GetCellCoordinates StartRow, StartCol, x1&, y1& x1& = x1& y1& = y1& GetCellCoordinates EndRow, EndCol, x2&, Y2& x2& = x2& Y2& = Y2& lpRect.Top = y1& lpRect.Bottom = Y2& + lRowHeight(EndRow) 'X& = X1& + lColWidth(StartCol) If bRowHeader Then x& = lColWidth(0) + bytGridLine Else x& = 0 End If For lThisCol = StartCol To EndCol x& = x& + lColWidth(lThisCol) + bytGridLine If x& > lScaleWidth Then Exit For lpRect.Left = x& lpRect.Right = x& DrawLine lpRect, lGridLineColor Next If bColHeader Then y& = lRowHeight(0) + bytGridLine Else y& = 0 End If lpRect.Left = x1& lpRect.Right = x2& + lColWidth(EndCol) 'Y& = Y1& + lRowHeight(StartRow) For lThisRow = StartRow To EndRow y& = y& + lRowHeight(lThisRow) + bytGridLine If y& > lScaleHeight Then Exit For lpRect.Top = y& lpRect.Bottom = y& DrawLine lpRect, lGridLineColor Next picGrid.DrawStyle = 0 'Solid End If 'Draw the right, bottom and the grey box at the bottom right 'DrawBottomRight DrawGridBorder StartRow, StartCol, EndRow, EndCol 'Draw the blank grey box at the end of the scroll bars If (bWidthOverflow And bHeightOverflow) Or (scrHorizontal.Visible And scrVertical.Visible) Then DrawBox lScaleWidth - 20, lScaleHeight - 20, 20, 20, COLOR_GREY End Sub 'Public Sub SetRowHeight(lThisRow&, lNewHeight&) ' lRowHeight(lThisRow&) = lNewHeight& ' RedrawAllCells True 'End Sub Public Property Get Row() As Long Attribute Row.VB_Description = "Sets/gets the current row" Attribute Row.VB_MemberFlags = "400" Row = lRow End Property Public Property Let Row(lNewValue As Long) HilightCell lRow, lCol lRow = lNewValue HilightCell End Property Public Property Get Col() As Long Attribute Col.VB_Description = "Gets/sets the current column number" Attribute Col.VB_MemberFlags = "400" Col = lCol End Property Public Property Let Col(lNewValue As Long) HilightCell lRow, lCol lCol = lNewValue HilightCell End Property Public Property Get Text() As String Attribute Text.VB_Description = "Gets/sets the text for the current row and column" Attribute Text.VB_MemberFlags = "400" Text = Cells.Text(lCol, lRow) End Property Public Property Let Text(sNewValue As String) Cells.Text(lCol, lRow) = sNewValue End Property Public Property Get TextMatrix(vRow As Long, vCol As Long) As String Attribute TextMatrix.VB_Description = "Gets/sets the text for the specified row and column" TextMatrix = Cells.Text(vCol, vRow) End Property Public Property Let TextMatrix(vRow As Long, vCol As Long, sNewValue As String) Cells.Text(vCol, vRow) = sNewValue End Property Public Property Get Redraw() As Boolean Redraw = bRedraw End Property Public Property Let Redraw(bNewValue As Boolean) bRedraw = bNewValue Refresh End Property Private Sub DrawRightCols(lThisLeftCol As Long, lUpdateWidth As Long) Dim lScaleWidth As Long, lScaleHeight As Long Dim lMyColWidth As Long lScaleWidth = picGrid.ScaleWidth lScaleHeight = picGrid.ScaleHeight If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If 'If scrVertical.Visible Then ' lScrollWidth = scrVertical.Width 'Else lScrollWidth = 0 'End If If bRowHeader Then x& = lColWidth(0) + 1 + bytGridLine Else x& = 1 End If For l& = lThisLeftCol To lCols lMyColWidth = lColWidth(l&) If x& < lScaleWidth - lUpdateWidth - lMyColWidth - lScrollWidth Then x& = x& + lMyColWidth + bytGridLine Else For lRemainder& = l& To lCols DrawCol lRemainder&, x&, True x& = x& + lColWidth(lRemainder&) + bytGridLine If l& = lCols& Or x& > lScaleWidth Then Exit For End If Next Exit For End If Next lGridWidth& = x& - 1 DrawBox lGridWidth + 1, 1, lScaleWidth - 1, lScaleHeight - 1, COLOR_GREY End Sub Private Sub RedrawAllCells(bDrawColHeader As Boolean) Dim lMyRowHeight As Long Dim lScaleHeight As Long, lScaleWidth As Long Dim lpRect As RECT 'picGrid.AutoRedraw = True If bColHeader Then If bDrawColHeader Then DrawRow 0, 1, True End If y& = 1 + lRowHeight(0) + bytGridLine lGridHeight = 1 + lRowHeight(0) Else lGridHeight = 0 y& = 1 End If lScaleHeight = picGrid.ScaleHeight lScaleWidth = picGrid.ScaleWidth For lThisRow& = lTopRow To lRows lMyRowHeight& = lRowHeight(lThisRow&) DrawRow lThisRow&, y&, True y& = y& + lRowHeight(lThisRow&) + bytGridLine If lThisRow& = lRows Or y& > lScaleHeight - 1 Then If lLargeVChange = 0 Then lLargeVChange = lThisRow& - lTopRow - 1 If lLargeVChange > 0 Then scrVertical.LargeChange = lLargeVChange End If lGridHeight = y& - 1 Exit For End If Next If lGridHeight >= lScaleHeight - 1 Then bHeightOverflow = True lGridHeight = lScaleHeight - 1 scrVertical.Tag = True Else If lTopRow > 1 Then bHeightOverflow = True scrVertical.Tag = True Else bHeightOverflow = False 'kdq090198 added to make sure scrollbars turn on/off scrVertical.Tag = False End If End If If lGridWidth >= lScaleWidth - 1 Then bWidthOverflow = True lGridWidth = lScaleWidth - 1 scrHorizontal.Tag = True Else If lLeftCol > 1 Then bWidthOverflow = True scrHorizontal.Tag = True Else bWidthOverflow = False 'kdq090198 added to make sure scrollbars turn on/off scrHorizontal.Tag = False End If End If 'color in space between grid and horizontal scrollbar DrawBox 1, lGridHeight + 1, lScaleWidth - 1, lScaleHeight - 1, lBackColorBkg 'COLOR_GREY 'color in space between grid and vertical scrollbar DrawBox lGridWidth + 1, 1, lScaleWidth - GridWidth, lScaleHeight - 1, lBackColorBkg 'COLOR_GREY If Rows > 0 Then DrawGrid HilightSelection HilightSelection lRow1, lCol1, lRow1, lCol1 bOver = GetCellCoordinates(lRow, lCol, x&, y&) If bOver = False Then HilightCell End If End If SetSizers ''Draw the grid border 'lpRect.Left = 0 'lpRect.Top = 0 'lpRect.Bottom = UserControl.ScaleHeight 'lpRect.Right = 0 'DrawLine lpRect, vbBlack, UserControl.hDC ' 'lpRect.Right = UserControl.ScaleWidth - 1 'lpRect.Bottom = 0 'DrawLine lpRect, vbBlack, UserControl.hDC ' 'lpRect.Left = lpRect.Right 'lpRect.Bottom = UserControl.ScaleHeight 'DrawLine lpRect, vbBlack, UserControl.hDC 'If bRedraw Then picGrid.Refresh 'picGrid.AutoRedraw = False End Sub Private Sub DrawBox(x As Long, y As Long, lWidth As Long, lHeight As Long, lColor As Long) Dim lpRect As RECT, hBrush As Long lpRect.Top = y lpRect.Left = x lpRect.Right = lpRect.Left + lWidth lpRect.Bottom = lpRect.Top + lHeight hBrush = CreateSolidBrush(lColor) FillRect picGrid.hDC, lpRect, hBrush DeleteObject hBrush End Sub Private Sub DrawRect(x As Long, y As Long, x1 As Long, y1 As Long, lColor As Long) Dim lpRect As RECT picGrid.ForeColor = lColor 'draw top line lpRect.Left = x lpRect.Top = y lpRect.Right = x1 lpRect.Bottom = y MoveToEx picGrid.hDC, lpRect.Left, lpRect.Top, 0 LineTo picGrid.hDC, lpRect.Right, lpRect.Bottom 'draw bottom line lpRect.Left = x lpRect.Top = y1 lpRect.Right = x1 lpRect.Bottom = y1 MoveToEx picGrid.hDC, lpRect.Left, lpRect.Top, 0 LineTo picGrid.hDC, lpRect.Right, lpRect.Bottom 'draw left line lpRect.Left = x lpRect.Top = y lpRect.Right = x lpRect.Bottom = y1 MoveToEx picGrid.hDC, lpRect.Left, lpRect.Top, 0 LineTo picGrid.hDC, lpRect.Right, lpRect.Bottom 'draw right line lpRect.Left = x1 lpRect.Top = y lpRect.Right = x1 lpRect.Bottom = y1 MoveToEx picGrid.hDC, lpRect.Left, lpRect.Top, 0 LineTo picGrid.hDC, lpRect.Right, lpRect.Bottom End Sub Private Sub DrawLine(lpRect As RECT, lColor As Long, Optional DC) If IsMissing(DC) Then DC = picGrid.hDC picGrid.ForeColor = lColor MoveToEx DC, lpRect.Left, lpRect.Top, 0 LineTo DC, lpRect.Right, lpRect.Bottom End Sub Public Property Get GridLineColor() As OLE_COLOR Attribute GridLineColor.VB_Description = "Gets/sets the color used to draw the grid lines" GridLineColor = lGridLineColor End Property Public Property Let GridLineColor(lNewValue As OLE_COLOR) lGridLineColor = lNewValue Refresh PropertyChanged "GridLineColor" End Property Private Sub HilightCell(Optional ThisRow, Optional ThisCol) Dim lMyColWidth As Long, lMyRowHeight As Long Dim lScaleWidth As Long, lScaleHeight As Long Dim lpRect As RECT Dim bOver As Boolean Dim bytTopWidth As Byte If lRows < 1 Or lCols < 1 Then Exit Sub 'kdq090298 If IsMissing(ThisRow) Then ThisRow = lRow If IsMissing(ThisCol) Then ThisCol = lCol lScaleWidth = picGrid.ScaleWidth lScaleHeight = picGrid.ScaleHeight If ThisRow >= lTopRow And ThisCol >= lLeftCol Then bOver = GetCellCoordinates(ThisRow, ThisCol, x&, y&) If bOver = False Then 'Now we have the X and Y coordinates of the cell and we know ' that the cell is visible on the screen lMyColWidth = lColWidth(ThisCol) lMyRowHeight = lRowHeight(ThisRow) 'Draw a black box around the cell picGrid.DrawMode = vbInvert 'kdq090498 changed to force highlight to be the same on all columns lpRect.Left = x& lpRect.Top = y& lpRect.Right = lpRect.Left + lMyColWidth lpRect.Bottom = lpRect.Top + lMyRowHeight di = DrawFocusRect(picGrid.hDC, lpRect) picGrid.DrawMode = vbCopyPen picGrid.DrawWidth = 1 'Set the position of the edit box txtEdit.Move x& + 3, y& + 2, lMyColWidth - 3, lMyRowHeight 'kdq090198 x and y were adjusted due to movement of picGrid If bEditMode Then txtEdit.Visible = True Else If txtEdit.Visible Then txtEdit.Visible = False 'raiseevent leavecell RaiseEvent AfterEdit(lRow, lCol, Text) End If txtEdit.ZOrder 1 End If End If End If If bRedraw Then picGrid.Refresh End Sub Public Sub MouseDown(button As Integer, Shift As Integer, x As Single, y As Single) Attribute MouseDown.VB_MemberFlags = "40" Dim lX As Long, lY As Long, lMyColWidth As Long, lMyRowHeight As Long Dim lNewCol As Long, lNewRow As Long Dim iMousePointer As Integer bMouseDown = True 'Find out if we're sizing columns or rows iMousePointer% = UserControl.MousePointer If iMousePointer = vbSizeWE Then 'Initiate the column size drag picSizer.Width = 2 picSizer.Height = UserControl.ScaleHeight picSizer.Top = 0 picSizer.Left = x picSizer.Visible = True bSizingCol = True ElseIf iMousePointer = vbSizeNS Then 'Initiate the row size drag picSizer.Height = 2 picSizer.Width = UserControl.ScaleWidth picSizer.Left = 0 picSizer.Top = y picSizer.Visible = True bSizingRow = True Else 'Un-select the spreadsheet 0,0 selector If Cells.Value(0, 0) Then Cells.Value(0, 0) = False GetCellCoordinates 0, 0, lX, lY lMyColWidth = ColWidth(0) lMyRowHeight = RowHeight(0) DrawCell 0, 0, 1, 1, lMyColWidth, lMyRowHeight End If 'Un-select any col selectors lMyRowHeight = RowHeight(0) For lOldCol& = lCol1 To lCol2 If Cells.Value(lOldCol&, 0) Then Cells.Value(lOldCol&, 0) = False bOver = GetCellCoordinates(0, lOldCol&, lX, lY) If Not bOver Then lMyColWidth = ColWidth(lOldCol) DrawCell 0, lOldCol, lX, 1, lMyColWidth, lMyRowHeight End If End If Next 'Un-select any row selectors lMyColWidth = ColWidth(0) For lOldRow& = lRow1 To lRow2 If Cells.Value(0, lOldRow&) Then Cells.Value(0, lOldRow&) = False bOver = GetCellCoordinates(lOldRow&, 0, lX, lY) If Not bOver Then lMyRowHeight = RowHeight(lOldRow&) DrawCell lOldRow, 0, 1, lY, lMyColWidth, lMyRowHeight End If End If Next 'Process the mouse down If scrHorizontal.Visible And scrVertical.Visible And x > scrVertical.Left And y > scrHorizontal.Top Then Exit Sub lNewRow = RowFromPoint(x, y) lNewCol = ColFromPoint(x, y) If (lNewRow = 0 Or lNewCol = 0) And (lNewRow > -1 And lNewCol > -1) Then 'mouse clicked on a fixed cell If (Shift And 1) And (button And 1) Then 'Extend the existing selection Else If lRow1 <> lRow2 Or lCol1 <> lCol2 Then HilightSelection 'Un-hilight the previous selected cell HilightSelection lRow1, lCol1, lRow1, lCol1 End If HilightCell If bAllowSelection And iSelectionMode > 0 Then Cells.Value(lNewCol, lNewRow) = True bOver = GetCellCoordinates(lNewRow, lNewCol, lX, lY) lMyColWidth = ColWidth(lNewCol) lMyRowHeight = RowHeight(lNewRow) If lNewCol = 0 And lNewRow = 0 Then If bAllowSelection And iSelectionMode = 0 Then DrawCell lNewRow, lNewCol, 1, 1, lMyColWidth, lMyRowHeight lMyRowHeight = RowHeight(0) For lMyCol& = 1 To lCols Cells.Value(lMyCol&, 0) = True bOver = GetCellCoordinates(0, lMyCol, lX, lY) If Not bOver Then lMyColWidth = ColWidth(lMyCol) DrawCell 0, lMyCol, lX, 1, lMyColWidth, lMyRowHeight End If Next lMyColWidth = ColWidth(0) For lMyRow& = 1 To lRows Cells.Value(0, lMyRow&) = True bOver = GetCellCoordinates(lMyRow, 0, lX, lY) If Not bOver Then lMyRowHeight = RowHeight(lMyRow) DrawCell lMyRow, 0, 1, lY, lMyColWidth, lMyRowHeight End If Next lCol1 = 1 lCol2 = lCols lRow1 = 1 lRow2 = lRows bSelectingRows = True bSelectingCols = True End If Else If lNewCol = 0 Then 'clicked on row header If iSelectionMode = 1 And bAllowSelection Then DrawCell lNewRow, lNewCol, 1, lY, lMyColWidth, lMyRowHeight lCol1 = 1 lCol2 = lCols lRow1 = lNewRow lRow2 = lNewRow bSelectingRows = True End If Else 'clicked on column header If iSelectionMode = 2 And bAllowSelection Then DrawCell lNewRow, lNewCol, lX, 1, lMyColWidth, lMyRowHeight lCol1 = lNewCol lCol2 = lNewCol lRow1 = 1 lRow2 = lRows bSelectingCols = True End If End If End If End If 'Hilight the new selection HilightSelection 'Un-hilight the previous selected cell HilightSelection lRow1, lCol1, lRow1, lCol1 lCol = lCol1 lRow = lRow1 HilightCell 'If bRedraw Then picGrid.Refresh ElseIf lNewRow > -1 And lNewCol > -1 Then 'mouse clicked on unfixed cell 'kdq090998 'added so if last col does not fit in grid and is clicked on, auto move grid bOver = GetCellCoordinates(lNewRow, lNewCol, lX, lY) If lX + lColWidth(lNewCol) > scrVertical.Left Then scrHorizontal.Value = scrHorizontal.Value + 1 If lY + lRowHeight(lNewRow) > scrHorizontal.Top Then scrVertical.Value = scrVertical.Value + 1 If (Shift And 1) And (button And 1) Then 'Shift was pressed 'Un-hilight the old selection HilightSelection lRow1, lCol1, lRow2, lCol2 'Hilight the new selection lRow2 = lNewRow lCol2 = lNewCol HilightSelection Else If lCol2 <> lCol1 Or lRow2 <> lRow1 Then HilightSelection 'Un-hilight the previous selected cell HilightSelection lRow1, lCol1, lRow1, lCol1 End If lRow1 = lNewRow lCol1 = lNewCol lRow2 = lRow1 lCol2 = lCol1 If lNewRow <> lRow Or lNewCol <> lCol Then 'Re-set the edit box If bEditMode Then HideEdit 'picGrid.AutoRedraw = False Else HilightCell lRow, lCol End If bRedraw = False If lNewRow > -1 Then lRow = lNewRow If lNewCol > -1 Then lCol = lNewCol If lNewRow > -1 Or lNewCol > -1 Then 'Fire the event 'FireEvent 1 End If bRedraw = True HilightCell End If End If End If End If 'UserControl.Refresh If txtEdit.Visible Then txtEdit.Visible = False 'raiseevent leavecell RaiseEvent AfterEdit(lRow, lCol, Text) End If List1.Visible = False cmdLookup.Visible = False ShowLookup End Sub Private Function RowFromPoint(x As Single, y As Single) As Long Dim lY As Long, lMyRowHeight As Long If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If If bColHeader Then lY& = lRowHeight(0) + bytGridLine + 1 Else lY& = 1 End If If y! > 0 And y! <= lY& Then RowFromPoint = 0 Exit Function End If RowFromPoint = -1 For lThisRow& = lTopRow To lRows lMyRowHeight = lRowHeight(lThisRow&) If y >= lY& And y <= lY& + lMyRowHeight Then RowFromPoint = lThisRow& Exit For End If lY& = lY& + lMyRowHeight& + bytGridLine Next End Function Private Function ColFromPoint(x As Single, y As Single) Dim lX As Long, lMyColWidth As Long If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If If bRowHeader Then lX& = lColWidth(0) + bytGridLine + 1 Else lX& = 1 End If If x! > 0 And x! <= lX& Then ColFromPoint = 0 Exit Function End If ColFromPoint = -1 For lThisCol& = lLeftCol To lCols lMyColWidth = lColWidth(lThisCol&) If x >= lX& And x <= lX& + lMyColWidth Then ColFromPoint = lThisCol& Exit For End If lX& = lX& + lMyColWidth& + bytGridLine Next End Function Public Sub EditKeyDown(KeyCode As Integer, Shift As Integer) Attribute EditKeyDown.VB_MemberFlags = "40" Dim lX As Long, lY As Long, bOver As Boolean Dim lMyColWidth As Long, lMyRowHeight As Long 'Process the keydown If KeyCode = 13 Then If bEditMode Then Cells.Text(lCol, lRow) = txtEdit.Text bEditMode = False 'RedrawAllCells False GetCellCoordinates lRow, lCol, x&, y& lMyColWidth = lColWidth(lCol) lMyRowHeight = lRowHeight(lRow) txtEdit.Visible = False txtEdit.ZOrder 1 'raiseevent leavecell 'picGrid.AutoRedraw = True DrawCell lRow, lCol, x&, y&, lMyColWidth, lMyRowHeight 'picGrid.AutoRedraw = False DrawGridBorder HilightCell lRow, lCol End If End If If KeyCode = 27 Then If bEditMode Then bEditMode = False 'RedrawAllCells False GetCellCoordinates lRow, lCol, x&, y& lMyColWidth = lColWidth(lCol) lMyRowHeight = lRowHeight(lRow) txtEdit.Visible = False txtEdit.ZOrder 1 'raiseevent leavecell 'picGrid.AutoRedraw = True DrawCell lRow, lCol, x&, y&, lMyColWidth, lMyRowHeight 'picGrid.AutoRedraw = False DrawGridBorder HilightCell lRow, lCol End If End If End Sub Public Sub EditKeyPress(KeyAscii As Integer) Attribute EditKeyPress.VB_MemberFlags = "40" If KeyAscii = 13 Then KeyAscii = 0 End If End Sub Public Sub DblClick() Dim lMyColWidth As Long, lMyRowHeight As Long If lRow >= 0 And lCol >= 0 Then If lColMask(lCol) = 4 Then 'checkmark If Cells.Text(lCol, lRow) = "1" Then Cells.Text(lCol, lRow) = "0" Else Cells.Text(lCol, lRow) = "1" End If GetCellCoordinates lRow, lCol, x&, y& lMyColWidth = lColWidth(lCol) lMyRowHeight = lRowHeight(lRow) DrawCell lRow, lCol, x&, y&, lMyColWidth, lMyRowHeight DrawGridBorder HilightCell lRow, lCol Else GridEdit Asc(" ") End If End If End Sub Public Sub MouseUp(button As Integer, Shift As Integer, x As Single, y As Single) Attribute MouseUp.VB_MemberFlags = "40" bMouseDown = False bSelectingRows = False bSelectingCols = False picSizer.Visible = False If bSizingCol Then If lCurrentColSizer& > 1 Then lNewWidth = picSizer.Left - hSizers(lCurrentColSizer& - 1) Else lNewWidth = picSizer.Left End If If lNewWidth < 0 Then lNewWidth = 10 'changed default to 10 from 0 If bRowHeader Then ColWidth(lLeftCol + lCurrentColSizer& - 2) = lNewWidth Else ColWidth(lLeftCol + lCurrentColSizer& - 1) = lNewWidth End If ShowLookup End If bSizingCol = False ' If bSizingRow Then ' If lCurrentRowSizer& > 1 Then ' lNewHeight = picSizer.Top - vSizers(lCurrentRowSizer& - 1) ' Else ' lNewHeight = picSizer.Top ' End If ' If lNewHeight < 0 Then lNewHeight = 0 ' RowHeight(lTopRow + lCurrentRowSizer - 2) = lNewHeight ' End If bSizingRow = False End Sub Public Sub MouseMove(button As Integer, Shift As Integer, x As Single, y As Single) Attribute MouseMove.VB_MemberFlags = "40" Dim lpRect As RECT, bytPointer As Byte Dim lScaleWidth As Integer, lScaleHeight As Integer Dim bShouldRedraw As Boolean, lNewCol2 As Long, lNewRow2 As Long Dim lPt As POINTAPI lScaleWidth = picGrid.ScaleWidth lScaleHeight = picGrid.ScaleHeight lNewRow2 = RowFromPoint(x, y) lNewCol2 = ColFromPoint(x, y) If bSizingCol Then If scrVertical.Visible Then lRightEdge = scrVertical.Left - 1 Else lRightEdge = lScaleWidth End If If x <= lRightEdge Then picSizer.Left = x ElseIf bSizingRow Then If scrHorizontal.Visible Then lBottomEdge = scrHorizontal.Top - 1 Else lBottomEdge = lScaleHeight End If If y <= lBottomEdge Then picSizer.Top = y ElseIf bMouseDown And bAllowSelection And iSelectionMode = 0 Then If bSelectingRows = True Or bSelectingCols = True Then 'Select more rows Else 'See if they're selecting multiple cells 'picGrid.AutoRedraw = True bRedraw = False bShouldRedraw = False bMouseHit = False 'See if we need to auto scroll up If y < 0 Or lNewRow2 = 0 Then If scrVertical.Value > 1 Then scrVertical = scrVertical - 1 lNewRow2 = lTopRow bShouldRedraw = True bMouseHit = True End If 'See if we need to auto scroll left If x < 0 Or lNewCol2 = 0 Then If scrHorizontal.Value > 1 Then scrHorizontal = scrHorizontal - 1 lNewCol2 = lLeftCol bShouldRedraw = True bMouseHit = True End If 'See if we need to auto scroll right If lNewCol2 < 0 Then lNewCol2 = 0 If x > lScaleWidth Then If scrHorizontal.Value < scrHorizontal.Max Then scrHorizontal.Value = scrHorizontal.Value + 1 bShouldRedraw = True End If bMouseHit = True End If 'See if we need to auto scroll down If lNewRow2 < 0 Then lNewRow2 = 0 If y > lScaleHeight Then If scrVertical.Value < scrVertical.Max Then scrVertical.Value = scrVertical.Value + 1 bShouldRedraw = True End If bMouseHit = True End If 'Now find out if we need to hilight the selection If lNewRow2 = lRow2 And lNewCol2 = lCol2 Then 'do nothing Else 'Un-hilight the old selection HilightSelection lRow1, lCol1, lRow2, lCol2 'Hilight the new selection lRow2 = lNewRow2 lCol2 = lNewCol2 HilightSelection lRow1, lCol1, lRow2, lCol2 bShouldRedraw = True End If bRedraw = True If bShouldRedraw Then picGrid.Refresh 'picGrid.AutoRedraw = False If bMouseHit Then GetCursorPos lPt SetCursorPos lPt.x, lPt.y End If End If Else If bColHeader = True And lNewRow2 = 0 Then 'If the X is within one of the sizers, change the mouse pointer to a sizer lCurrentColSizer& = -1 For lCount& = 1 To hSizers.Count If Abs(hSizers(lCount&) - x) < 2 Then 'It's within 2 pixels of a sizer, so set the MousePointer lCurrentColSizer& = lCount& Exit For End If Next If lCurrentColSizer& > -1 Then UserControl.MousePointer = vbSizeWE Else UserControl.MousePointer = vbDefault End If ' ElseIf bRowHeader = True And lNewCol2 = 0 Then ' 'If the Y is within one of the sizers, change the mouse pointer to a sizer ' lCurrentRowSizer& = -1 ' For lCount& = 1 To vSizers.Count ' If Abs(vSizers(lCount&) - y) < 2 Then ' 'It's within 2 pixels of a sizer, so set the MousePointer ' lCurrentRowSizer& = lCount& ' Exit For ' End If ' Next ' ' If lCurrentRowSizer& > -1 Then ' UserControl.MousePointer = vbSizeNS ' Else ' UserControl.MousePointer = vbDefault ' End If Else UserControl.MousePointer = vbDefault End If End If MouseMoveExit: End Sub Public Sub HilightSelection(Optional Row1, Optional Col1, Optional Row2, Optional Col2) Attribute HilightSelection.VB_MemberFlags = "40" Dim lpRect As RECT Dim lThisRow As Long, lThisCol As Long Dim lMyRowHeight As Long, lMyColWidth As Long Dim x1 As Long, y1 As Long, lCol1Width As Long, lRow1Height As Long Dim x2 As Long, Y2 As Long 'picGrid.AutoRedraw = True If IsMissing(Row1) Then Row1 = lRow1 If IsMissing(Col1) Then Col1 = lCol1 If IsMissing(Row2) Then Row2 = lRow2 If IsMissing(Col2) Then Col2 = lCol2 If lRows < 1 Or lCols < 1 Then Exit Sub 'kdq090298 If Row1 < lTopRow And Row2 < lTopRow Then Exit Sub If Col1 < lLeftCol And Col2 < lLeftCol Then Exit Sub bOver = GetCellCoordinates(Row1, Col1, x1&, y1&) bOver = GetCellCoordinates(Row2, Col2, x2&, Y2&) If Col2 < Col1 Then lpRect.Left = x2 lpRect.Right = x1 + lColWidth(Col1) If Col2 > lLeftCol Then lpRect.Left = lpRect.Left - 2 Else lpRect.Left = x1 lpRect.Right = x2 + lColWidth(Col2) If Col1 > lLeftCol Then lpRect.Left = lpRect.Left - 2 End If If Row2 < Row1 Then lpRect.Top = Y2 lpRect.Bottom = y1 + lRowHeight(Row1) If Row2 > lTopRow Then lpRect.Top = lpRect.Top - 2 Else lpRect.Top = y1 lpRect.Bottom = Y2 + lRowHeight(Row2) If Row1 > lTopRow Then lpRect.Top = lpRect.Top - 2 End If If bShowGrid Then lpRect.Right = lpRect.Right + 2 lpRect.Bottom = lpRect.Bottom + 2 End If 'Invert the hilighted rect InvertRect picGrid.hDC, lpRect 'Fix any hilighting of the bottom and right stuff 'DrawBottomRight 'Draw the blank grey box at the end of the scroll bars If (bWidthOverflow And bHeightOverflow) Or (scrHorizontal.Visible And scrVertical.Visible) Then DrawBox lScaleWidth - 20, lScaleHeight - 20, 20, 20, COLOR_GREY If bRedraw Then picGrid.Refresh 'picGrid.AutoRedraw = False End Sub Private Function GetCellCoordinates(ThisRow, ThisCol, x As Long, y As Long) As Boolean Dim lScaleWidth As Long, lScaleHeight As Long Dim lMyColWidth As Long, lMyRowHeight As Long lScaleWidth = picGrid.ScaleWidth lScaleHeight = picGrid.ScaleHeight 'Assume it's not on the screen If bColHeader Then y& = lRowHeight(0) + bytGridLine + 1 Else y& = 1 End If If bRowHeader Then x& = lColWidth(0) + bytGridLine + 1 Else x& = 1 End If ' 'See if the current cell is possibly visible ' If ThisRow >= lTopRow And ThisCol >= lLeftCol Then If bShowGrid Then bytGridLine = 1 Else bytGridLine = 0 End If 'Now see if the selected row is on the screen bRowOver = False For lCurRow& = lTopRow& To ThisRow If y& > lScaleHeight - 1 Then bRowOver = True Exit For End If If lCurRow& < ThisRow Then y& = y& + lRowHeight(lCurRow&) + bytGridLine Next 'If Not bOver Then 'Now find out if the selected col is on the screen bColOver = False For lCurCol& = lLeftCol& To ThisCol If x& > lScaleWidth - 1 Then bColOver = True Exit For End If If lCurCol& < ThisCol Then x& = x& + lColWidth(lCurCol&) + bytGridLine Next 'End If ' Else ' bOver = True ' End If If bColOver = True Or bRowOver = True Then GetCellCoordinates = True Else GetCellCoordinates = False End If End Function Private Sub RedrawCells(lpRect As RECT) Dim x As Long, y As Long Dim lMyColWidth As Long, lMyRowHeight As Long Dim lThisRow As Long, lThisCol As Long For lThisRow = lpRect.Top To lpRect.Bottom For lThisCol = lpRect.Left To lpRect.Right GetCellCoordinates lThisRow, lThisCol, x&, y& lMyColWidth = lColWidth(lThisCol) lMyRowHeight = lRowHeight(lThisRow) DrawCell lThisRow, lThisCol, x&, y&, lMyColWidth, lMyRowHeight, False 'UserControl.Refresh Next Next End Sub Private Sub DrawBottomRight() Dim lScaleWidth As Long, lScaleHeight As Long Dim lpRect As RECT lScaleWidth = picGrid.ScaleWidth lScaleHeight = picGrid.ScaleHeight 'Draw the line on the right lpRect.Left = lScaleWidth - 1 lpRect.Top = 1 lpRect.Right = lpRect.Left lpRect.Bottom = lScaleHeight DrawLine lpRect, vbBlack 'Draw the line on the bottom lpRect.Left = 0 lpRect.Top = lScaleHeight - 1 lpRect.Right = lScaleWidth lpRect.Bottom = lpRect.Top DrawLine lpRect, vbBlack 'Draw the blank grey box at the end of the scroll bars 'If Val(scrVertical.Tag) = True And Val(scrHorizontal.Tag) = True Then DrawBox lScaleWidth - 20, lScaleHeight - 20, 19, 19, COLOR_GREY End Sub Public Sub KeyDown(KeyCode As Integer, Shift As Integer) Attribute KeyDown.VB_MemberFlags = "40" Dim lScrollWidth As Long, lScrollHeight As Long Dim lMyColWidth As Long, lMyRowHeight As Long 'picGrid.AutoRedraw = True If KeyCode = vbKeyLeft Then If lCol > 1 Then HilightCell lCol = lCol - 1 If lCol < lLeftCol Then If scrHorizontal.Value > 1 Then scrHorizontal.Value = scrHorizontal.Value - 1 Else HilightCell End If Else HilightCell End If 'FireEvent 1 End If ElseIf KeyCode = vbKeyUp Then If lRow > 1 Then HilightCell lRow = lRow - 1 If lRow < lTopRow Then If scrVertical.Value > 1 Then scrVertical.Value = scrVertical.Value - 1 Else HilightCell End If Else HilightCell End If 'FireEvent 1 End If ElseIf KeyCode = vbKeyRight Then If lCol < lCols Then HilightCell lCol = lCol + 1 bOver = GetCellCoordinates(lRow, lCol, lX&, lY&) If scrVertical.Visible Then lScrollWidth = scrVertical.Width Else lScrollWidth = 0 End If lMyColWidth = lColWidth(lCol) If lX& > (picGrid.ScaleWidth - lMyColWidth - lScrollWidth) Then If scrHorizontal.Value < scrHorizontal.Max Then HilightCell scrHorizontal.Value = scrHorizontal.Value + 1 Else HilightCell End If Else HilightCell End If 'FireEvent 1 End If ElseIf KeyCode = vbKeyDown Then If lRow < lRows Then HilightCell lRow = lRow + 1 bOver = GetCellCoordinates(lRow, lCol, lX&, lY&) If scrHorizontal.Visible Then lScrollHeight = scrHorizontal.Height Else lScrollHeight = 0 End If lMyRowHeight = lRowHeight(lRow) If lY& > (picGrid.ScaleHeight - lMyRowHeight - lScrollHeight) Then If scrVertical.Value < scrVertical.Max Then HilightCell scrVertical.Value = scrVertical.Value + 1 Else HilightCell End If Else HilightCell End If 'FireEvent 1 End If End If If KeyCode = vbKeyLeft Or KeyCode = vbKeyRight Or KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then If txtEdit.Visible Then txtEdit.Visible = False 'raiseevent leavecell RaiseEvent AfterEdit(lRow, lCol, Text) End If List1.Visible = False cmdLookup.Visible = False ShowLookup End If If bRedraw Then picGrid.Refresh 'picGrid.AutoRedraw = False End Sub Public Function GetColWidth(lThisCol&) As Long Attribute GetColWidth.VB_MemberFlags = "40" GetColWidth = lColWidth(lThisCol&) End Function Public Sub SetColWidth(lThisCol&, lNewColWidth&) Attribute SetColWidth.VB_MemberFlags = "40" lColWidth(lThisCol&) = lNewColWidth& RedrawAllCells True End Sub Public Function BlockSelected() As Boolean Attribute BlockSelected.VB_MemberFlags = "40" If lRow2 <> lRow1 Or lCol2 <> lCol1 Then BlockSelected = True Else BlockSelected = False End If End Function Public Property Get Row1() As Long Attribute Row1.VB_MemberFlags = "440" Row1 = lRow1 End Property Public Property Let Row1(lNewValue As Long) lRow1 = lNewValue End Property Public Property Get Col1() As Long Attribute Col1.VB_MemberFlags = "440" Col1 = lCol1 End Property Public Property Let Col1(lNewValue As Long) lCol1 = lNewValue End Property Public Property Get Row2() As Long Attribute Row2.VB_MemberFlags = "440" Row2 = lRow2 End Property Public Property Let Row2(lNewValue As Long) lRow2 = lNewValue End Property Public Property Get Col2() As Long Attribute Col2.VB_MemberFlags = "440" Col2 = lCol2 End Property Public Property Let Col2(lNewValue As Long) lCol2 = lNewValue End Property 'Public Property Get Name() As String ' Name = sName$ 'End Property ' 'Public Property Let Name(sNewValue As String) ' sName$ = sNewValue$ 'End Property Private Sub picGrid_DblClick() DblClick End Sub Private Sub picGrid_KeyDown(KeyCode As Integer, Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) KeyDown KeyCode, Shift End Sub Private Sub picGrid_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) If Cols > 0 And Rows > 0 And KeyAscii <> vbKeyTab Then GridEdit KeyAscii End If End Sub Private Sub picGrid_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) End Sub Private Sub picGrid_MouseDown(button As Integer, Shift As Integer, x As Single, y As Single) MouseDown button, Shift, x, y RaiseEvent MouseDown(button, Shift, x, y) End Sub Private Sub picGrid_MouseMove(button As Integer, Shift As Integer, x As Single, y As Single) MouseMove button, Shift, x, y RaiseEvent MouseMove(button, Shift, x, y) End Sub Private Sub picGrid_MouseUp(button As Integer, Shift As Integer, x As Single, y As Single) MouseUp button, Shift, x, y RaiseEvent MouseUp(button, Shift, x, y) End Sub Private Sub scrHorizontal_Change() HChange If txtEdit.Visible Then txtEdit.Visible = False 'raiseevent leavecell RaiseEvent AfterEdit(lRow, lCol, Text) End If List1.Visible = False cmdLookup.Visible = False ShowLookup End Sub Private Sub scrHorizontal_GotFocus() 'kdq 083198 added so scrollbars do not get focus picGrid.SetFocus End Sub Private Sub scrVertical_Change() VChange If txtEdit.Visible Then txtEdit.Visible = False 'raiseevent leavecell RaiseEvent AfterEdit(lRow, lCol, Text) End If List1.Visible = False cmdLookup.Visible = False ShowLookup End Sub Private Sub scrVertical_GotFocus() 'kdq 083198 added so scrollbars do not get focus picGrid.SetFocus End Sub Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer) EditKeyDown KeyCode, Shift End Sub Private Sub txtEdit_KeyPress(KeyAscii As Integer) Select Case ColMask(lCol) Case 0 'no mask Case 1 'Uppercase KeyAscii = Asc(UCase(Chr(KeyAscii))) Case 2 'Numeric only KeyAscii = NumOnly(KeyAscii) Case 3 'Date only KeyAscii = DateOnly(KeyAscii) End Select End Sub Private Sub UserControl_DblClick() DblClick End Sub Private Sub UserControl_ExitFocus() If bEditMode Then HideEdit HilightCell End If End Sub Private Sub UserControl_Initialize() Set Cells = New clsCellArray Set txtEdit.Font = picGrid.Font Set hSizers = New Collection Set vSizers = New Collection 'kdq083198 changed these lines to accomodate new borderstyles 'scrHorizontal.Move 2, UserControl.ScaleHeight - 21, UserControl.ScaleWidth - 22, 18 'scrVertical.Move UserControl.ScaleWidth - 21, 2, 18, UserControl.ScaleHeight - 22 'picGrid.Move 2, 2, scrVertical.Left, scrHorizontal.Top lLeftCol = 1 lTopRow = 1 lRow = 1 lCol = 1 lRow1 = 1 lCol1 = 1 lRow2 = 1 lCol2 = 1 End Sub Private Sub UserControl_InitProperties() 'Turn on headers bColHeader = True bRowHeader = True bShowGrid = True bGridSolid = True lGridLineColor = COLOR_GREY bColSizing = True bRowSizing = True bSizingCol = False bSizingRow = False bAllowUserResizing = True sFormatString = "" bAutoNewRow = False m_ListBoxRows = 6 iBorderStyle = 1 lBackColor = vbWhite lBackColorFixed = COLOR_GREY lBackColorBkg = COLOR_DARKGREY lForeColor = vbButtonText lForeColorFixed = vbButtonText bAllowSelection = True iFixedStyle = 1 iSelectionMode = 0 Set fFont = Ambient.Font Set fFontFixed = Ambient.Font fFontFixed.Bold = True 'Set up columns and rows Cols = 5 Rows = 1 lLeftCol = 1 lTopRow = 1 lRow = 1 lCol = 1 lRow1 = 1 lCol1 = 1 lRow2 = 1 lCol2 = 1 bRedraw = True m_DataSource = m_def_DataSource ' m_RecordSource = m_def_RecordSource m_Recordset = m_def_Recordset End Sub Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer) KeyDown KeyCode, Shift End Sub Private Sub UserControl_MouseDown(button As Integer, Shift As Integer, x As Single, y As Single) MouseDown button, Shift, x, y End Sub Private Sub UserControl_MouseMove(button As Integer, Shift As Integer, x As Single, y As Single) MouseMove button, Shift, x, y End Sub Private Sub UserControl_MouseUp(button As Integer, Shift As Integer, x As Single, y As Single) MouseUp button, Shift, x, y End Sub Private Sub UserControl_Paint() Dim di As Long Dim rc As RECT Dim xTwips As Integer, yTwips As Integer xTwips = Screen.TwipsPerPixelX yTwips = Screen.TwipsPerPixelY 'draw outside border 'get dimensions of usercontrol di = GetClientRect(UserControl.hwnd, rc) Select Case iBorderStyle Case [No Border] Case [Single] di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDOUTER, BF_RECT Or BF_MONO) Case [Thin Raised] di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDINNER, BF_TOPLEFT) di = DrawEdge(UserControl.hDC, rc, BDR_RAISEDOUTER, BF_BOTTOMRIGHT) Case [Thick Raised] di = DrawEdge(UserControl.hDC, rc, EDGE_RAISED, BF_TOPLEFT) di = DrawEdge(UserControl.hDC, rc, EDGE_RAISED, BF_BOTTOMRIGHT) Case [Thin Inset] di = DrawEdge(UserControl.hDC, rc, BDR_SUNKENINNER, BF_TOPLEFT) di = DrawEdge(UserControl.hDC, rc, BDR_SUNKENOUTER, BF_BOTTOMRIGHT) Case [Thick Inset] di = DrawEdge(UserControl.hDC, rc, EDGE_SUNKEN, BF_TOPLEFT) di = DrawEdge(UserControl.hDC, rc, EDGE_SUNKEN, BF_BOTTOMRIGHT) Case [Etched] di = DrawEdge(UserControl.hDC, rc, EDGE_ETCHED, BF_TOPLEFT) di = DrawEdge(UserControl.hDC, rc, EDGE_ETCHED, BF_BOTTOMRIGHT) Case [Bump] di = DrawEdge(UserControl.hDC, rc, EDGE_BUMP, BF_TOPLEFT) di = DrawEdge(UserControl.hDC, rc, EDGE_BUMP, BF_BOTTOMRIGHT) End Select End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) Dim totcnt As Integer, cnt As Integer Dim Index As Integer Dim pCol As Integer, pVal As String Rows = PropBag.ReadProperty("Rows", 10) Cols = PropBag.ReadProperty("Cols", 10) Row = PropBag.ReadProperty("Row", 1) Col = PropBag.ReadProperty("Col", 1) bShowGrid = PropBag.ReadProperty("ShowGrid", True) bGridSolid = PropBag.ReadProperty("GridSolid", True) lGridLineColor = PropBag.ReadProperty("GridLineColor", vbButtonFace) bRedraw = PropBag.ReadProperty("Redraw", True) iBorderStyle = PropBag.ReadProperty("BorderStyle", m_BorderStyle_Def) UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0) m_DataSource = PropBag.ReadProperty("DataSource", m_def_DataSource) ' m_RecordSource = PropBag.ReadProperty("RecordSource", m_def_RecordSource) m_Recordset = PropBag.ReadProperty("Recordset", m_def_Recordset) bAllowSelection = PropBag.ReadProperty("AllowSelection", True) lBackColor = PropBag.ReadProperty("BackColor", vbWhite) lBackColorFixed = PropBag.ReadProperty("BackColorFixed", vbButtonFace) 'lBackColorSel = PropBag.ReadProperty("BackColorSel", vbHighlight) lForeColor = PropBag.ReadProperty("ForeColor", vbButtonText) lForeColorFixed = PropBag.ReadProperty("ForeColorFixed", vbButtonText) 'lForeColorSel = PropBag.ReadProperty("ForeColorSel", vbButtonText) iFixedStyle = PropBag.ReadProperty("FixedStyle", 1) bColHeader = PropBag.ReadProperty("ColHeader", True) bRowHeader = PropBag.ReadProperty("RowHeader", True) iSelectionMode = PropBag.ReadProperty("SelectionMode", 0) UserControl.Enabled = PropBag.ReadProperty("Enabled", True) Set fFont = PropBag.ReadProperty("Font", Ambient.Font) Set fFontFixed = PropBag.ReadProperty("FontFixed", Ambient.Font) lBackColorBkg = PropBag.ReadProperty("BackColorBkg", COLOR_DARKGREY) bAllowUserResizing = PropBag.ReadProperty("AllowUserResizing", True) sFormatString = PropBag.ReadProperty("FormatString", "") bAutoNewRow = PropBag.ReadProperty("AutoNewRow", False) m_ListBoxRows = PropBag.ReadProperty("ListBoxRows", 6) totcnt = PropBag.ReadProperty("Count", 0) For Index = 1 To totcnt pCol = PropBag.ReadProperty("Column" & Index) pVal = PropBag.ReadProperty("Value" & Index) AddLookup pCol, pVal Next UpdateHeader Refresh End Sub Private Sub UserControl_Resize() 'kdq083198 changed these lines to accomodate new borderstyles scrHorizontal.Move 2, UserControl.ScaleHeight - 21, UserControl.ScaleWidth - 23, 18 scrVertical.Move UserControl.ScaleWidth - 21, 2, 18, UserControl.ScaleHeight - 23 'picGrid.Move 2, 2, scrVertical.Left, scrHorizontal.Top picGrid.Move 2, 2, UserControl.ScaleWidth - 5, UserControl.ScaleHeight - 5 'kdq083198 added so cells get redrawn properly when grid is resized Refresh 'kdq083198 added to draw borderstyles UserControl.Cls UserControl_Paint End Sub Private Sub UserControl_Terminate() Set Cells = Nothing Set hSizers = Nothing Set vSizers = Nothing Erase lRowHeight Erase lColWidth Erase bColEdit End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Dim Index As Integer PropBag.WriteProperty "Rows", Rows, 10 PropBag.WriteProperty "Cols", Cols, 10 PropBag.WriteProperty "Row", Row, 1 PropBag.WriteProperty "Col", Col, 1 PropBag.WriteProperty "Redraw", bRedraw PropBag.WriteProperty "ShowGrid", bShowGrid PropBag.WriteProperty "GridSolid", bGridSolid PropBag.WriteProperty "GridLineColor", GridLineColor Call PropBag.WriteProperty("BorderStyle", iBorderStyle, m_BorderStyle_Def) Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0) Call PropBag.WriteProperty("DataSource", m_DataSource, m_def_DataSource) ' Call PropBag.WriteProperty("RecordSource", m_RecordSource, m_def_RecordSource) Call PropBag.WriteProperty("Recordset", m_Recordset, m_def_Recordset) Call PropBag.WriteProperty("AllowSelection", bAllowSelection, True) Call PropBag.WriteProperty("BackColor", lBackColor, vbWhite) Call PropBag.WriteProperty("BackColorFixed", lBackColorFixed, vbButtonFace) 'Call PropBag.WriteProperty("BackColorSel", lBackColorSel, vbHighlight) Call PropBag.WriteProperty("ForeColor", lForeColor, vbButtonText) Call PropBag.WriteProperty("ForeColorFixed", lForeColorFixed, vbButtonText) 'Call PropBag.WriteProperty("ForeColorSel", lForeColorSel, vbButtonText) Call PropBag.WriteProperty("FixedStyle", iFixedStyle, 1) Call PropBag.WriteProperty("ColHeader", bColHeader, True) Call PropBag.WriteProperty("RowHeader", bRowHeader, True) Call PropBag.WriteProperty("SelectionMode", iSelectionMode, 0) Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True) Call PropBag.WriteProperty("Font", fFont, Ambient.Font) Call PropBag.WriteProperty("FontFixed", fFontFixed, Ambient.Font) Call PropBag.WriteProperty("BackColorBkg", lBackColorBkg, COLOR_DARKGREY) Call PropBag.WriteProperty("AllowUserResizing", bAllowUserResizing, True) Call PropBag.WriteProperty("FormatString", sFormatString, "") Call PropBag.WriteProperty("AutoNewRow", bAutoNewRow, False) Call PropBag.WriteProperty("ListBoxRows", m_ListBoxRows, 6) If Not UserControl.Ambient.UserMode Then Call PropBag.WriteProperty("Count", LookupValues.Count, 0) For Index = 1 To LookupValues.Count Call PropBag.WriteProperty("Column" & Index, LookupValues(Index).Column) Call PropBag.WriteProperty("Value" & Index, LookupValues(Index).Value) Next End If End Sub Private Sub InitializeCols(lTopCol&) Dim lStartCol As Long, lStartRow As Long Dim fntTemp As Font 'Set up the defaults for cells ReDim Preserve lColWidth(0 To lTopCol&) As Integer ReDim Preserve lColAlign(0 To lTopCol&) As Integer ReDim Preserve bColEdit(0 To lTopCol&) As Boolean ReDim Preserve lColMask(0 To lTopCol&) As Integer If lCols& = 0 Then lStartCol& = 0 Else lStartCol& = lCols& + 1 End If If lRows& = 0 Then ReDim Preserve lRowHeight(0 To 1) As Integer lStartRow& = 0 lTopRowMember& = lRows& If lTopRowMember& = 0 Then lTopRowMember& = 1 lTopColMember& = lTopCol& If lTopColMember& = 0 Then lTopColMember& = 1 Cells.Cols = lTopColMember& lColCount& = 0 lRowCount& = 0 iCharscount% = 1 For lMyCol& = lStartCol& To lTopCol& If lMyCol& = 0 Then lColWidth(lMyCol&) = 32 Else lColWidth(lMyCol&) = 64 End If lColAlign(lMyCol&) = ALIGN_LEFT 'kdq091498 added for easier FormatString implementation bColEdit(lMyCol&) = True 'cell editing TRUE lColMask(lMyCol&) = 0 'no mask For lMyRow& = lStartRow& To lRows& lRowHeight(lMyRow&) = 15 If lMyRow& > 0 And lMyCol& > 0 Then Cells.Style(lMyCol&, lMyRow&) = STYLE_EDIT ElseIf lMyRow& = 0 Then If lMyCol& > 0 Then lColCount& = lColCount& + 1 iChar% = 64 + lColCount& sChar$ = Chr$(iChar%) If sChar$ > "Z" Then lColCount& = 1 iCharscount% = iCharscount% + 1 iChar% = 65 End If 'Cells.Text(lMyCol&, lMyRow&) = String$(iCharscount%, iChar%) End If 'Cells.TextAlign(lMyCol&, lMyRow&) = ALIGN_LEFT Cells.TextAlignVertical(lMyCol&, lMyRow&) = ALIGNV_CENTER 'Set fntTemp = Cells.Font(lMyCol&, lMyRow&) 'fntTemp.Bold = True 'Set Cells.Font(lMyCol&, lMyRow&).Bold = fntTemp Cells.Style(lMyCol&, lMyRow&) = STYLE_BUTTON ElseIf lMyCol& = 0 Then 'Cells.TextAlign(lMyCol&, lMyRow&) = ALIGN_LEFT Cells.TextAlignVertical(lMyCol&, lMyRow&) = ALIGNV_CENTER 'Set fntTemp = Cells.Font(lMyCol&, lMyRow&) 'fntTemp.Bold = True 'Set Cells.Font(lMyCol&, lMyRow&).Bold = fntTemp If lMyRow& > 0 Then lRowCount& = lRowCount& + 1 'Cells.Text(lMyCol&, lMyRow&) = CStr(lRowCount&) Cells.Style(lMyCol&, lMyRow&) = STYLE_BUTTON Cells.Value(lMyCol&, lMyRow&) = False End If End If Next Next End Sub Private Sub InitializeRows(lTopRow&) Dim lStartCol As Long, lStartRow As Long 'Set up the defaults for cells If lCols& = 0 Then ReDim Preserve lColWidth(0 To 1) As Integer ReDim Preserve lColAlign(0 To 1) As Integer ReDim Preserve bColEdit(0 To 1) As Boolean ReDim Preserve lColMask(0 To 1) As Integer End If lStartCol& = 0 ReDim Preserve lRowHeight(0 To lTopRow&) As Integer If lRows& = 0 Then lStartRow& = 0 Else lStartRow& = lRows& + 1 End If lTopRowMember& = lTopRow& If lTopRowMember& = 0 Then lTopRowMember& = 1 lTopColMember& = lCols& If lTopColMember& = 0 Then lTopColMember& = 1 Cells.Rows = lTopRowMember& lColCount& = 0 lRowCount& = 0 iCharscount% = 1 For lMyCol& = lStartCol& To lCols& 'If lMyCol& = 0 Then ' lColWidth(lMyCol&) = 32 'Else ' lColWidth(lMyCol&) = 64 'End If 'lColAlign(lMyCol&) = ALIGN_LEFT 'kdq091498 added for easier FormatString implementation For lMyRow& = lStartRow& To lTopRow& lRowHeight(lMyRow&) = 15 If lMyRow& > 0 And lMyCol& > 0 Then 'Cells.Style(lMyCol&, lMyRow&) = STYLE_NORMAL Cells.Style(lMyCol&, lMyRow&) = STYLE_EDIT ElseIf lMyRow& = 0 Then If lMyCol& > 0 Then lColCount& = lColCount& + 1 iChar% = 64 + lColCount& sChar$ = Chr$(iChar%) If sChar$ > "Z" Then lColCount& = 1 iCharscount% = iCharscount% + 1 iChar% = 65 End If 'Cells.Text(lMyCol&, lMyRow&) = String$(iCharscount%, iChar%) End If 'Cells.TextAlign(lMyCol&, lMyRow&) = ALIGN_LEFT Cells.TextAlignVertical(lMyCol&, lMyRow&) = ALIGNV_CENTER 'Cells.Font(lMyCol&, lMyRow&).Bold = True Cells.Style(lMyCol&, lMyRow&) = STYLE_BUTTON ElseIf lMyCol& = 0 Then 'Cells.TextAlign(lMyCol&, lMyRow&) = ALIGN_LEFT Cells.TextAlignVertical(lMyCol&, lMyRow&) = ALIGNV_CENTER 'Cells.Font(lMyCol&, lMyRow&).Bold = True If lMyRow& > 0 Then lRowCount& = lRowCount& + 1 'Cells.Text(lMyCol&, lMyRow&) = CStr(lRowCount&) Cells.Style(lMyCol&, lMyRow&) = STYLE_BUTTON Cells.Value(lMyCol&, lMyRow&) = False End If End If Next Next End Sub Private Sub HideEdit() Dim lX As Long, lY As Long If bDAO Then If lRow > 0 And lCol > 0 Then m_Recordset.AbsolutePosition = lRow - 1 m_Recordset.Edit m_Recordset(lCol - 1) = Left$(txtEdit, m_Recordset.Fields(lCol - 1).Size) m_Recordset.Update Else Cells.Text(lCol, lRow) = txtEdit End If ElseIf bRDO Then Cells.Text(lCol, lRow) = txtEdit Else If Not ColHasLookup(lCol) Then Cells.Text(lCol, lRow) = txtEdit End If If txtEdit.Visible Then txtEdit.Visible = False 'raiseevent leavecell RaiseEvent AfterEdit(lRow, lCol, Text) End If txtEdit.ZOrder 1 bEditMode = False lMyColWidth& = lColWidth(lCol&) lMyRowHeight& = lRowHeight(lRow&) GetCellCoordinates lRow, lCol, lX, lY DrawCell lRow, lCol, lX&, lY&, lMyColWidth&, lMyRowHeight& DrawGridBorder End Sub Public Property Get RowHeight(lThisRow As Long) As Long Attribute RowHeight.VB_Description = "Sets/gets the height of a row" Attribute RowHeight.VB_MemberFlags = "400" RowHeight = lRowHeight(lThisRow) End Property Public Property Let RowHeight(lThisRow As Long, ByVal lNewValue As Long) lRowHeight(lThisRow) = lNewValue Refresh End Property Public Property Get ColWidth(lThisCol As Long) As Long Attribute ColWidth.VB_Description = "Gets/sets width of a column" Attribute ColWidth.VB_MemberFlags = "400" ColWidth = lColWidth(lThisCol) End Property Public Property Let ColWidth(lThisCol As Long, ByVal lNewValue As Long) lColWidth(lThisCol) = lNewValue Refresh End Property Public Property Get ColAlign(lThisCol As Long) As Long Attribute ColAlign.VB_Description = "Gets/sets the text alignment for a column" ColAlign(lThisCol) = lColAlign(lThisCol) End Property Public Property Let ColAlign(lThisCol As Long, ByVal lNewValue As Long) If lNewValue = ALIGN_LEFT Or lNewValue = ALIGN_CENTER Or lNewValue = ALIGN_RIGHT Then lColAlign(lThisCol) = lNewValue Refresh End If End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MappingInfo=UserControl,UserControl,-1,BorderStyle Public Property Get BorderStyle() As axgridBorderStyleEnum Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object." BorderStyle = iBorderStyle End Property Public Property Let BorderStyle(ByVal New_BorderStyle As axgridBorderStyleEnum) If Not (iBorderStyle = New_BorderStyle) Then iBorderStyle = New_BorderStyle UserControl.Cls UserControl_Paint PropertyChanged "BorderStyle" End If End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 'MappingInfo=UserControl,UserControl,-1,MousePointer Public Property Get MousePointer() As MousePointerConstants Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object." MousePointer = UserControl.MousePointer End Property Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants) UserControl.MousePointer() = New_MousePointer PropertyChanged "MousePointer" End Property Public Property Get Recordset() As Variant Attribute Recordset.VB_MemberFlags = "40" Recordset = m_Recordset End Property Public Property Set Recordset(ByVal New_Recordset As Variant) Set m_Recordset = New_Recordset PropertyChanged "Recordset" 'Now set the grid up to get its data from the Recordset bDAO = True bRDO = False m_Recordset.MoveLast Rows = m_Recordset.AbsolutePosition + 1 SetupColumns End Property Private Sub SetupColumns() Dim lIndex As Long If bDAO Then Cols = m_Recordset.Fields.Count For lIndex& = 0 To m_Recordset.Fields.Count - 1 Cells.Text(lIndex& + 1, 0) = m_Recordset.Fields(lIndex&).Name 'Now set the column width Select Case m_Recordset.Fields(lIndex&).Type Case dbText ColWidth(lIndex& + 1) = UserControl.TextWidth(String$(m_Recordset.Fields(lIndex&).Size, "N")) End Select Next Else 'It's RDO, so use the rdoResultset End If End Sub Public Property Get AllowSelection() As Boolean Attribute AllowSelection.VB_Description = "Determines if user can select multiple cells" AllowSelection = bAllowSelection End Property Property Let AllowSelection(bNewVal As Boolean) bAllowSelection = bNewVal PropertyChanged "AllowSelection" End Property Public Property Get BackColor() As OLE_COLOR Attribute BackColor.VB_Description = "Sets/gets background color of the grid" BackColor = lBackColor End Property Public Property Let BackColor(ByVal lNewValue As OLE_COLOR) lBackColor = lNewValue InitializeRows lRows Refresh PropertyChanged "BackColor" End Property Public Property Get BackColorFixed() As OLE_COLOR Attribute BackColorFixed.VB_Description = "Sets/gets the background color of the row and column headers" BackColorFixed = lBackColorFixed End Property Public Property Let BackColorFixed(ByVal lNewValue As OLE_COLOR) lBackColorFixed = lNewValue Refresh PropertyChanged "BackColorFixed" End Property Public Property Get ForeColor() As OLE_COLOR Attribute ForeColor.VB_Description = "Gets/sets foreground color used for text in grid" ForeColor = lForeColor End Property Public Property Let ForeColor(ByVal lNewValue As OLE_COLOR) lForeColor = lNewValue PropertyChanged "ForeColor" End Property Public Property Get ForeColorFixed() As OLE_COLOR Attribute ForeColorFixed.VB_Description = "Gets/sets color used in text for row and column headers" ForeColorFixed = lForeColorFixed End Property Public Property Let ForeColorFixed(ByVal lNewValue As OLE_COLOR) lForeColorFixed = lNewValue Refresh PropertyChanged "ForeColorFixed" End Property Public Property Get FixedStyle() As FixedStyles Attribute FixedStyle.VB_Description = "Determines style of row and column headers" FixedStyle = iFixedStyle End Property Public Property Let FixedStyle(ByVal iNew_Value As FixedStyles) If Not (iFixedStyle = iNew_Value) Then iFixedStyle = iNew_Value Refresh PropertyChanged "FixedStyle" End If End Property Public Property Get SelectionMode() As SelectModes SelectionMode = iSelectionMode End Property Public Property Let SelectionMode(ByVal iNew_Value As SelectModes) iSelectionMode = iNew_Value PropertyChanged "SelectionMode" End Property Public Property Get Enabled() As Boolean Enabled = UserControl.Enabled End Property Property Let Enabled(bNewVal As Boolean) UserControl.Enabled = bNewVal PropertyChanged "Enabled" End Property Public Property Get Font() As Font Attribute Font.VB_Description = "Gets/sets font used for text in grid" Set Font = fFont End Property Property Set Font(New_Font As Font) Set fFont = New_Font Refresh PropertyChanged "Font" End Property Public Property Get FontFixed() As Font Attribute FontFixed.VB_Description = "Gets/sets font used in text for row and column headers" Set FontFixed = fFontFixed End Property Property Set FontFixed(New_Font As Font) Set fFontFixed = New_Font Refresh PropertyChanged "FontFixed" End Property Sub ShowAbout() Attribute ShowAbout.VB_Description = "Show the about box" Attribute ShowAbout.VB_UserMemId = -552 frmAbout.Show vbModal End Sub Public Property Get BackColorBkg() As OLE_COLOR Attribute BackColorBkg.VB_Description = "Sets/gets the background color of the usercontrol (behind the grid)" BackColorBkg = lBackColorBkg End Property Public Property Let BackColorBkg(ByVal lNewValue As OLE_COLOR) lBackColorBkg = lNewValue Refresh PropertyChanged "BackColorBkg" End Property Public Property Get AllowUserResizing() As Boolean Attribute AllowUserResizing.VB_Description = "Determines if user can resize columns" AllowUserResizing = bAllowUserResizing End Property Property Let AllowUserResizing(bNewVal As Boolean) bAllowUserResizing = bNewVal PropertyChanged "AllowUserResizing" End Property Public Property Get FormatString() As String Attribute FormatString.VB_Description = "Sets a format string that sets up a the control's column widths, alignments, and fixed row and column text\r\n" FormatString = sFormatString End Property Property Let FormatString(sNewVal As String) Dim cnt As Long sFormatString = sNewVal ClearAllLookups UpdateHeader Refresh PropertyChanged "FormatString" End Property Private Sub UpdateHeader() Dim ColCnt As Long, Char As String, CharStr As String, cnt As Long Dim AlignStr As String, lAlign As Long, RowText As Boolean, RowCnt As Long RowText = False ColCnt = 1: RowCnt = 1 CharStr = "" For cnt = 1 To Len(sFormatString) Char = Mid(sFormatString, cnt, 1) If Char = "|" Or Char = ";" Then If CharStr > "" And Not RowText Then If ColCnt > Cols Then Cols = ColCnt AlignStr = "" If InStr("<^>", Left(CharStr, 1)) Then AlignStr = Left(CharStr, 1) CharStr = Right(CharStr, Len(CharStr) - 1) End If Select Case AlignStr Case "<" lAlign = ALIGN_LEFT Case "^" lAlign = ALIGN_CENTER Case ">" lAlign = ALIGN_RIGHT Case Else lAlign = ALIGN_LEFT End Select lColAlign(ColCnt) = lAlign lColWidth(ColCnt) = TextWidth(CharStr) + 5 Cells.Text(ColCnt, 0) = RTrim(CharStr) ColCnt = ColCnt + 1 ElseIf CharStr > "" And RowText Then ColCnt = 0 If RowCnt > Rows Then Rows = RowCnt If lColWidth(ColCnt) < TextWidth(CharStr) + 5 Then lColWidth(ColCnt) = TextWidth(CharStr) + 5 End If Cells.Text(ColCnt, RowCnt) = RTrim(CharStr) RowCnt = RowCnt + 1 Else Cells.Text(ColCnt, 0) = "" lColWidth(ColCnt) = 64 ColCnt = ColCnt + 1 End If CharStr = "" If Char = ";" Then RowText = True Else CharStr = CharStr + Char End If Next If CharStr > "" And Not RowText Then If ColCnt > Cols Then Cols = ColCnt AlignStr = "" If InStr("<^>", Left(CharStr, 1)) Then AlignStr = Left(CharStr, 1) CharStr = Right(CharStr, Len(CharStr) - 1) End If Select Case AlignStr Case "<" lAlign = ALIGN_LEFT Case "^" lAlign = ALIGN_CENTER Case ">" lAlign = ALIGN_RIGHT Case Else lAlign = ALIGN_LEFT End Select lColAlign(ColCnt) = lAlign lColWidth(ColCnt) = TextWidth(CharStr) + 5 Cells.Text(ColCnt, 0) = RTrim(CharStr) ColCnt = ColCnt + 1 If ColCnt + 1 <= Cols Then For cnt = ColCnt + 1 To Cols Cells.Text(cnt, 0) = "" lColWidth(cnt) = 64 Next End If ElseIf CharStr > "" And RowText Then ColCnt = 0 If RowCnt > Rows Then Rows = RowCnt If lColWidth(ColCnt) < TextWidth(CharStr) + 5 Then lColWidth(ColCnt) = TextWidth(CharStr) + 5 End If Cells.Text(ColCnt, RowCnt) = RTrim(CharStr) If RowCnt + 1 <= Rows Then For cnt = RowCnt + 1 To Rows Cells.Text(0, Rows) = "" lColWidth(0) = 64 Next End If End If End Sub Public Sub AutoSetup(NRows As Variant, NCols As Variant, vRowHeader As Boolean, vColHeader As Boolean, vFormatString As Variant) Attribute AutoSetup.VB_Description = "Automatically setup the grid by passing rows, cols, and a format string" Dim cnt As Integer ' Always (re)set to zero to avoid errors when fixedrows >= rows bRedraw = False Rows = NRows Cols = NCols RowHeader = vRowHeader ColHeader = vColHeader sFormatString = vFormatString ClearAllLookups UpdateHeader bRedraw = True Refresh End Sub Private Sub SetSizers() If bAllowUserResizing Then Do While hSizers.Count hSizers.Remove 1 Loop Do While vSizers.Count vSizers.Remove 1 Loop lScaleHeight = UserControl.ScaleHeight lScaleWidth = UserControl.ScaleWidth If bRowHeader Then lCumulative& = ColWidth(0) hSizers.Add lCumulative& Else lCumulative& = 0 End If For lColCount& = lLeftCol To lCols lCumulative& = lCumulative& + ColWidth(lColCount&) + 1 If lCumulative& > lScaleWidth Then Exit For Else hSizers.Add lCumulative& End If Next ' If bRowHeader Then ' lCumulative& = RowHeight(0) + 1 ' Else ' lCumulative& = 0 ' End If ' vSizers.Add lCumulative& ' For lRowCount& = lTopRow To lRows ' lCumulative& = lCumulative& + RowHeight(lRowCount&) + 1 ' If lCumulative& > lScaleHeight Then ' Exit For ' Else ' vSizers.Add lCumulative& ' End If ' Next End If End Sub Private Sub GridEdit(KeyAscii As Integer) Dim CancelEdit As Boolean Dim x As Integer Dim strX As String Dim bFoundStart As Boolean Dim intStart Dim ListHeight As Integer, ListRows As Integer Dim cellX As Long, cellY As Long CancelEdit = False RaiseEvent BeforeEdit(lRow, lCol, CancelEdit) If Not CancelEdit Then ' If bEditMode = False And Cells.Style(lCol, lRow) = STYLE_EDIT Then If bEditMode = False And bColEdit(lCol) Then HilightCell lRow, lCol If lRow = lRows And RowEmpty(lRow) And bAutoNewRow Then 'add row bCancel = False RaiseEvent BeforeAddRow(bCancel) If Not bCancel Then Rows = Rows + 1 RaiseEvent AfterAddRow(Rows) End If End If bEditMode = True If ColHasLookup(lCol) Then If Not List1.Visible Then FillCombo (lCol) List1.FontName = picGrid.FontName List1.FontSize = picGrid.FontSize 'position the combo box GetCellCoordinates lRow, lCol, cellX, cellY List1.Left = cellX + 2 List1.Top = cellY + RowHeight(lRow) + 2 List1.Width = ColWidth(lCol) '<-- Need to check for scrollbar ListRows = (picGrid.Height - List1.Top - RowHeight(lRow)) / RowHeight(lRow) If ListRows > ListBoxRows Then ListRows = ListBoxRows 'ListRows = ListBoxRows List1.Height = RowHeight(lRow) * (ListRows) ' in the grid! List1.ZOrder List1.Visible = True List1.SetFocus strX = Chr(KeyAscii) bFoundStart = False On Error Resume Next For x = 0 To List1.ListCount - 1 If UCase(Left(List1.List(x), Len(strX))) = UCase(strX) Then List1.Selected(x) = True Exit For End If Next On Error GoTo 0 Else 'need to hide list List1.Visible = False flxGrid.SetFocus End If Else 'RaiseEvent EnterCell 'Get the text for this cell If bDAO Then If lRow > 0 And lCol > 0 Then m_Recordset.AbsolutePosition = lRow - 1 txtEdit = m_Recordset(lCol - 1) & "" Else txtEdit = Cells.Text(lCol, lRow) End If ElseIf bRDO Then Else txtEdit = Cells.Text(lCol, lRow) End If txtEdit.SelStart = Len(txtEdit) txtEdit.SelLength = 0 'Set txtEdit.Font = Cells.Font(lCol, lRow) txtEdit.BackColor = vbWhite 'Cells.BackColor(lCol, lRow) txtEdit.ForeColor = vbBlack 'Cells.ForeColor(lCol, lRow) txtEdit.Visible = True txtEdit.ZOrder txtEdit.SetFocus End If End If End If End Sub Public Property Get AutoNewRow() As Boolean Attribute AutoNewRow.VB_Description = "Determines if editing a cell on the last row automatically creates a new row" AutoNewRow = bAutoNewRow End Property Public Property Let AutoNewRow(ByVal New_Value As Boolean) bAutoNewRow = New_Value PropertyChanged "AutoNewRow" End Property Public Function RowEmpty(ByVal iRow As Long) Attribute RowEmpty.VB_Description = "Used to determine if a row is empty, meaning it contains no text in any of the columns for that row. Returns a boolean expression\r\n" Dim a As Long Dim bRowEmpty As Boolean bRowEmpty = True For a = 1 To lCols If Len(Trim(TextMatrix(iRow, a))) > 0 Then bRowEmpty = False Exit For End If Next RowEmpty = bRowEmpty End Function Private Sub ShowLookup() Dim x As Long, y As Long GetCellCoordinates lRow, lCol, x, y If ColHasLookup(lCol) And lCol > 0 And lRow > 0 And lLeftCol <= lCol And lTopRow <= lRow And y + RowHeight(lRow) <= scrHorizontal.Top Then 'GetCellCoordinates lRow, lCol, x, y cmdLookup.Move x + ColWidth(lCol) - cmdLookup.Width + 1, y + 3, cmdLookup.Width, RowHeight(lRow) - 2 cmdLookup.Visible = True Else cmdLookup.Visible = False End If End Sub Public Sub AddLookup(iCol As Integer, Value As String) Attribute AddLookup.VB_Description = "Add lookup list item for a specific column" Dim Item As New clsLookup Item.Column = iCol Item.Value = Value LookupValues.Add Item End Sub Public Sub RemoveLookup(iCol As Integer, Value As String) Attribute RemoveLookup.VB_Description = "Remove a specific lookup list item for a column" Dim cnt As Integer For cnt = 1 To LookupValues.Count If LookupValues(cnt).Value = Value And LookupValues(cnt).Column = iCol Then LookupValues.Remove cnt Exit For End If Next End Sub Public Sub ClearLookup(iCol As Integer) Attribute ClearLookup.VB_Description = "Remove lookup items for a specific column" Dim cnt As Integer For cnt = 1 To LookupValues.Count If LookupValues(cnt).Column = iCol Then LookupValues.Remove cnt cnt = 1 End If Next End Sub Public Sub ClearAllLookups() Attribute ClearAllLookups.VB_Description = "Remove all lookup items for all columns" Do Until LookupValues.Count = 0 LookupValues.Remove 1 Loop End Sub Public Function ColHasLookup(ByVal iCol As Integer) As Boolean Attribute ColHasLookup.VB_Description = "Gets a value to determine if a column has lookup items" Dim cnt As Integer For cnt = 1 To LookupValues.Count If LookupValues(cnt).Column = iCol Then ColHasLookup = True Exit Function End If Next ColHasLookup = False End Function Private Sub FillCombo(iCol As Integer) Dim cnt As Integer List1.Clear For cnt = 1 To LookupValues.Count If LookupValues(cnt).Column = iCol Then List1.AddItem LookupValues(cnt).Value End If Next End Sub Public Property Get ListBoxRows() As Integer Attribute ListBoxRows.VB_Description = "Returns or sets the default number of items to display in the dropdown listbox when a column has a dropdown" ListBoxRows = m_ListBoxRows End Property Public Property Let ListBoxRows(ByVal New_ListBoxRows As Integer) m_ListBoxRows = New_ListBoxRows PropertyChanged "ListBoxRows" End Property Public Property Get ColAllowEdit(ByVal iCol As Long) As Boolean Attribute ColAllowEdit.VB_Description = "Determines if a column will allow editing" ColAllowEdit = bColEdit(iCol) End Property Public Property Let ColAllowEdit(ByVal iCol As Long, ByVal Value As Boolean) bColEdit(iCol) = Value PropertyChanged "ColAllowEdit" End Property Public Property Get ColMask(ByVal iCol As Long) As Integer Attribute ColMask.VB_Description = "Gets/sets a value to determine what kind of mask will be used for a column" ColMask = lColMask(iCol) End Property Public Property Let ColMask(ByVal iCol As Long, ByVal Value As Integer) If Value >= 0 And Value <= 4 Then lColMask(iCol) = Value End If End Property Private Sub List1_LostFocus() bEditMode = False 'Text = IIf(List1.ListIndex >= 0, List1.List(List1.ListIndex), Text) List1.Visible = False picGrid.SetFocus GetCellCoordinates lRow, lCol, x&, y& DrawCell lRow, lCol, x&, y&, ColWidth(lCol), RowHeight(lRow) DrawGridBorder HilightCell lRow, lCol 'RaiseEvent AfterEdit(lRow, lCol, Text) End Sub Private Sub list1_DblClick() bEditMode = False Text = IIf(List1.ListIndex >= 0, List1.List(List1.ListIndex), Text) List1.Visible = False picGrid.SetFocus GetCellCoordinates lRow, lCol, x&, y& DrawCell lRow, lCol, x&, y&, ColWidth(lCol), RowHeight(lRow) DrawGridBorder HilightCell lRow, lCol RaiseEvent AfterEdit(lRow, lCol, Text) End Sub Private Sub list1_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case vbKeyEscape bEditMode = False List1.Visible = False Case vbKeyReturn bEditMode = False Text = IIf(List1.ListIndex >= 0, List1.List(List1.ListIndex), Text) List1.Visible = False picGrid.SetFocus GetCellCoordinates lRow, lCol, x&, y& DrawCell lRow, lCol, x&, y&, ColWidth(lCol), RowHeight(lRow) DrawGridBorder HilightCell lRow, lCol RaiseEvent AfterEdit(lRow, lCol, Text) End Select End Sub Private Sub cmdLookup_Click() GridEdit Asc(" ") End Sub Private Function NumOnly(keyin As Integer) As Integer 'only allow numeric characters in a textbox ' put in keypress event If (keyin < Asc("0") Or keyin > Asc("9")) And keyin <> 8 And keyin <> Asc("-") And keyin <> Asc(".") Then NumOnly = 0 Else NumOnly = keyin End If End Function Private Function DateOnly(keyin As Integer) As Integer 'only allow date characters in a text box ' put in KeyPress event If (keyin < Asc("0") Or keyin > Asc("9")) And keyin <> Asc("/") And keyin <> 8 Then DateOnly = 0 Else DateOnly = keyin End If End Function Public Sub Remove(iRow As Integer) Attribute Remove.VB_Description = "Remove the specified row from the grid" If Rows > 0 Then Cells.Remove iRow scrVertical.Max = lRows - 1 InitializeRows lRows - 1 lRows = lRows - 1 If lRow > lRows Then lRow = lRows If lRow1 > lRows Then lRow1 = lRows If lRow2 > lRows Then lRow2 = lRows Refresh End If End Sub