vbAccelerator - Contents of code file: frmTestGridOwnerDraw.frm

VERSION 5.00
Object = "{3D811CB0-6F63-4CA8-BD1E-7858AC6C9A00}#5.6#0"; "vbalSGrid.ocx"
Begin VB.Form frmTestGridOwnerDraw 
   Caption         =   "vbAccelerator SGrid Owner-Draw Cell Demonstration"
   ClientHeight    =   5640
   ClientLeft      =   2490
   ClientTop       =   2280
   ClientWidth     =   7425
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTestGridOwnerDraw.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5640
   ScaleWidth      =   7425
   Begin VB.PictureBox picControls 
      BorderStyle     =   0  'None
      Height          =   4875
      Left            =   5940
      ScaleHeight     =   4875
      ScaleWidth      =   1335
      TabIndex        =   1
      Top             =   600
      Width           =   1335
      Begin VB.CommandButton cmdAbout 
         Caption         =   "&About..."
         Height          =   375
         Left            =   0
         TabIndex        =   5
         Top             =   1440
         Width           =   1335
      End
      Begin VB.Timer tmrProgress 
         Enabled         =   0   'False
         Interval        =   50
         Left            =   0
         Top             =   780
      End
      Begin VB.CommandButton cmdProgress 
         Caption         =   "&Progress"
         Height          =   375
         Left            =   0
         TabIndex        =   3
         Top             =   420
         Width           =   1335
      End
      Begin VB.CommandButton cmdColours 
         Caption         =   "&Colours"
         Height          =   375
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   1335
      End
   End
   Begin vbAcceleratorSGrid.vbalGrid grdOwnerDrawDemo 
      Height          =   4815
      Left            =   120
      TabIndex        =   0
      Top             =   660
      Width           =   5715
      _ExtentX        =   10081
      _ExtentY        =   8493
      BackgroundPictureHeight=   0
      BackgroundPictureWidth=   0
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BorderStyle     =   2
      DisableIcons    =   -1  'True
   End
   Begin VB.Label lblInfo 
      Caption         =   $"frmTestGridOwnerDraw.frx":1272
      Height          =   435
      Left            =   120
      TabIndex        =   4
      Top             =   120
      Width           =   7155
   End
End
Attribute VB_Name = "frmTestGridOwnerDraw"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

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 DeleteObject Lib "gdi32" (ByVal hObject As Long) 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 DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect
 As RECT) As Long

Implements IGridCellOwnerDraw

Private Function HexPad(ByVal lValue As Long, ByVal lMinChars As Long) As String
Dim sRet As String
   sRet = Hex(lValue)
   If Len(sRet) < lMinChars Then
      sRet = String(lMinChars - Len(sRet), "0") & sRet
   End If
   HexPad = sRet
End Function


Private Sub configureGrid()
   With grdOwnerDrawDemo
   
      .AddColumn "Name", "Name"
      .AddColumn "Colour", "Colour", eSortType:=CCLSortItemData
      .AddColumn "Progress", "Progress", eSortType:=CCLSortNumeric
      
      .OwnerDrawImpl = Me
      
      .RowMode = True
      .GridLines = True
      
      .SelectionAlphaBlend = True
      .SelectionOutline = True
      .DrawFocusRectangle = False
      .HighlightForeColor = vbWindowText
      .HotTrack = True
      
   End With
End Sub

Private Sub addGridData()
Dim h As Single, s As Single, l As Single
Dim r As Long, g As Long, b As Long
Dim i As Long

   RGBToHLS 171, 199, 245, h, s, l
      
   With grdOwnerDrawDemo
      .Redraw = False
      
      For i = 1 To 64
         .AddRow lItemData:=i
         .CellText(i, 1) = "Row " & i
         HLSToRGB h, s, (i * 4 - 1) / 255#, r, g, b
         .CellText(i, 2) = "&H" & HexPad(b, 2) & HexPad(g, 2) & HexPad(r, 2)
         .CellItemData(i, 2) = RGB(r, g, b)
         .CellTextAlign(i, 3) = DT_CENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS
         .CellText(i, 3) = ((65 - i) / 64#)
      Next i
      
      .Redraw = True
   End With
End Sub


Private Sub cmdAbout_Click()
   Dim fA As New frmAbout
   fA.Show vbModal, Me
End Sub

Private Sub cmdColours_Click()
Dim h As Single, s As Single, l As Single
Dim r As Long, g As Long, b As Long
Dim i As Long

   RGBToHLS Rnd * 255, Rnd * 255, Rnd * 255, h, s, l
   For i = 1 To 64
      HLSToRGB h, s, (i * 4 - 1) / 255#, r, g, b
      grdOwnerDrawDemo.CellItemData(i, 2) = RGB(r, g, b)
      grdOwnerDrawDemo.CellText(i, 2) = "&H" & HexPad(b, 2) & HexPad(g, 2) &
       HexPad(r, 2)
   Next i
   
End Sub

Private Sub cmdProgress_Click()
   If (tmrProgress.Tag = "") Then
      tmrProgress.Tag = "1"
   End If
   tmrProgress.Enabled = Not (tmrProgress.Enabled)
End Sub

Private Sub Form_Load()
   
   configureGrid
   addGridData
   
End Sub

Private Sub Form_Resize()
Dim lWidth As Long
   On Error Resume Next
   lWidth = Me.ScaleWidth - picControls.Width - 10 * Screen.TwipsPerPixelX
   grdOwnerDrawDemo.Move 4 * Screen.TwipsPerPixelX, grdOwnerDrawDemo.top, _
      lWidth, _
      Me.ScaleHeight - grdOwnerDrawDemo.top - 4 * Screen.TwipsPerPixelY
   picControls.Move lWidth + 6 * Screen.TwipsPerPixelX, grdOwnerDrawDemo.top, _
      picControls.Width, _
      grdOwnerDrawDemo.Height
   lblInfo.Width = Me.ScaleWidth - lblInfo.left * 2
End Sub

Private Sub grdOwnerDrawDemo_ColumnClick(ByVal lCol As Long)
   With grdOwnerDrawDemo
      If (.ColumnSortOrder(lCol) = CCLOrderAscending) Then
         .ColumnSortOrder(lCol) = CCLOrderDescending
      Else
         .ColumnSortOrder(lCol) = CCLOrderAscending
      End If
      With .SortObject
         .Clear
         .SortColumn(1) = lCol
         .SortOrder(1) = grdOwnerDrawDemo.ColumnSortOrder(lCol)
         .SortType(1) = grdOwnerDrawDemo.ColumnSortType(lCol)
      End With
      .Sort
   End With
End Sub

Private Sub grdOwnerDrawDemo_ColumnDividerDblClick(ByVal lCol As Long, bCancel
 As Boolean)
   If (lCol = 2) Then
      bCancel = True
      ' could evaluate required width as
      ' 6 + Min(13,RowHeight) + TextWidth("&H000000 ")
      grdOwnerDrawDemo.ColumnWidth(lCol) = 84
   End If
End Sub

Private Sub IGridCellOwnerDraw_Draw( _
      cell As cGridCell, _
      ByVal lHDC As Long, _
      ByVal eDrawStage As ECGDrawStage, _
      ByVal lLeft As Long, ByVal lTop As Long, _
      ByVal lRight As Long, ByVal lBottom As Long, _
      bSkipDefault As Boolean _
   )
   If (eDrawStage = ecgBeforeIconAndText) Then
      If (cell.Column = 2) Then
         drawColourCell cell, lHDC, lLeft, lTop, lRight, lBottom
         bSkipDefault = True
      ElseIf (cell.Column = 3) Then
         drawProgressCell cell, lHDC, lLeft, lTop, lRight, lBottom
         bSkipDefault = True
      End If
   End If
End Sub

Private Sub drawColourCell( _
      cell As cGridCell, _
      ByVal lHDC As Long, _
      ByVal lLeft As Long, ByVal lTop As Long, _
      ByVal lRight As Long, ByVal lBottom As Long _
   )
Dim lCol As Long
Dim hBr As Long
Dim tR As RECT
Dim lColourSize As Long

   lColourSize = lBottom - lTop
   If (lColourSize > 13) Then
      lColourSize = 13
   End If
   
   tR.left = lLeft + 2
   tR.right = tR.left + lColourSize
   tR.top = lTop + (lBottom - lTop - lColourSize) \ 2 + 1
   tR.bottom = tR.top + lColourSize
   
   ' Draw the colour box
   lCol = cell.ItemData
   hBr = CreateSolidBrush(lCol)
   FillRect lHDC, tR, hBr
   DeleteObject hBr
   
   ' Frame the colour Box
   hBr = CreateSolidBrush(&H0)
   FrameRect lHDC, tR, hBr
   DeleteObject hBr
   
   ' Draw the text for the colour number
   tR.left = tR.right + 4
   tR.right = lRight
   DrawTextA lHDC, cell.Text, -1, tR, cell.TextAlign
   
End Sub
Private Sub drawProgressCell( _
      cell As cGridCell, _
      ByVal lHDC As Long, _
      ByVal lLeft As Long, ByVal lTop As Long, _
      ByVal lRight As Long, ByVal lBottom As Long _
   )
Dim hBr As Long
Dim tR As RECT
Dim tProgR As RECT

   tR.left = lLeft + 2
   tR.top = lTop + 2
   tR.right = lRight - 2
   tR.bottom = lBottom - 1

   ' Draw the progress bar
   LSet tProgR = tR
   tProgR.right = tProgR.left + (tProgR.right - tProgR.left) * cell.Text
   GradientFillRect lHDC, tProgR, RGB(234, 94, 45), RGB(238, 164, 36),
    GRADIENT_FILL_RECT_H
   
   ' Draw the text in front of the progress bar
   DrawTextA lHDC, Format(cell.Text, "0%"), -1, tR, cell.TextAlign

   ' Frame the progress bar:
   hBr = CreateSolidBrush(&H0&)
   FrameRect lHDC, tR, hBr
   DeleteObject hBr
   

End Sub


Private Function RowForItemData(ByVal sTag As String) As Long
Dim i As Long
Dim lID As Long
   If (IsNumeric(sTag)) Then
      lID = CLng(sTag)
      For i = 1 To grdOwnerDrawDemo.Rows
         If (grdOwnerDrawDemo.RowItemData(i) = lID) Then
            RowForItemData = i
            Exit Function
         End If
      Next i
   End If
End Function

Private Sub tmrProgress_Timer()
Dim iRow As Long
Dim fProg As Single
   
   iRow = RowForItemData(tmrProgress.Tag)
   If (iRow > 0) Then
      fProg = grdOwnerDrawDemo.CellText(iRow, 3)
      fProg = fProg + 0.05
      If (fProg >= 1#) Then
         fProg = 1#
         tmrProgress.Tag = CLng(tmrProgress.Tag) + 1
         If CLng(tmrProgress.Tag) > grdOwnerDrawDemo.Rows Then
            tmrProgress.Tag = ""
         End If
      End If
      grdOwnerDrawDemo.CellText(iRow, 3) = fProg
      grdOwnerDrawDemo.EnsureVisible iRow, 3
   End If
   
End Sub