frmvirtual.frm

一款Grid表格控件源代码,非常棒.不下你一定会后悔

'/* the database client.

Private m_lRowCount     As Long
Private m_cTiming       As clsTiming


Private Sub Form_Load()

Dim lX  As Long
Dim lCt As Long
    
    Set m_cTiming = New clsTiming
    With ucVHGrid1
        lX = (.Width / Screen.TwipsPerPixelX) / 8
        '/* auto set draw after last cell is loaded
        .FastLoad = True
        '/* enable unicode
        .UseUnicode = True
        '/* add header icons
        .InitImlHeader
        For lCt = 1 To 5
            .ImlHeaderAddIcon imlHdr.ListImages.Item(lCt).Picture
        Next lCt
        '/* add row icons
        .InitImlRow 32, 32
        For lCt = 1 To 20
            .ImlRowAddIcon iml32.ListImages(lCt).Picture
        Next lCt
        '/* add columns
        .ColumnAdd 0, "", (lX * 0.4), ecaColumnLeft, 0, ecsSortIcon
        .ColumnAdd 1, "Column 1", (lX * 1.8), ecaColumnLeft, 1, ecsSortDefault
        .ColumnAdd 2, "Column 2", (lX * 1.8), ecaColumnLeft, 2, ecsSortDefault
        .ColumnAdd 3, "Column 3", (lX * 1.8), ecaColumnLeft, 3, ecsSortDefault
        .ColumnAdd 4, "Column 4", (lX * 1.8), ecaColumnLeft, 4, ecsSortDefault
        '/* use xp colors
        .XPColors = True
        '/* grid backcolor
        .BackColor = &H8A8181
        '/* set the row height
        .RowHeight = 35
        '/* double buffer grid
        .DoubleBuffer = True
        '/* enable cell editing
        .CellEdit = True
        '/* lock the first column
        .LockFirstColumn = True
        '/* set alphbar transparency
        .AlphaBarTransparency = 120
        '/* enable sorting
        .CellsSorted = True
        '/* enable header drag and drop
        .HeaderDragDrop = True
        
        '/* set header height
        .HeaderHeight = 50
        '/* enable checkboxes
        .Checkboxes = True
        '/* use gridlines
        .GridLines = EGLBoth
        '/* set the drag effect style
        .DragEffectStyle = edsClientArrow
        '/* enable header vertical text
        .ColumnVerticalText = True
        '/* enable virtual mode
        .VirtualMode = True
        '/* apply skin
        .ThemeManager etmXP, False, , , &H333333, &H887466, &HC4B0A2, _
            &HF1C19B, &HC4946E, &H808080, 210, True, True, &HF1C19B, _
            True, False, True, False
        '/* apply cell decoration: layout, startcolor, offset color, xp color offset, depth
        .CellDecoration erdCellChecker, &HCDBBBC, &H8A8181, True, 1
    End With

End Sub

Private Sub cmdLoad_Click()

    If TestInput Then
        m_cTiming.Reset
        InitGrid
        picBar.Print (m_lRowCount + 1) & " items added to HyperList in: " & _
            Format$(m_cTiming.Elapsed / 1000, "0.0000") & "s"
    End If

End Sub

Private Function TestInput() As Boolean
    
    If Not IsNumeric(txtCount.Text) Then
        MsgBox "Please choose a row number between 1 and 10000000", vbExclamation, "Invalid Input!"
        Exit Function
    ElseIf (txtCount.Text) > 10000000 Then
        MsgBox "Please choose a row number between 1 and 10000000", vbExclamation, "Invalid Input!"
        Exit Function
    ElseIf CLng(txtCount.Text) < 1 Then
        MsgBox "Please choose a row number between 1 and 10000000", vbExclamation, "Invalid Input!"
        Exit Function
    ElseIf ucVHGrid1.Count > 0 Then
        ucVHGrid1.ClearList
    End If
    '/* set the row count
    m_lRowCount = CLng((txtCount.Text)) - 1
    '/* success
    TestInput = True

End Function

Private Sub InitGrid()

    With ucVHGrid1
        '/* init the list
        .GridInit m_lRowCount, 5
        .Draw = True
    End With
    
End Sub

Private Sub ucVHGrid1_eHVirtualAccess(ByVal lRow As Long, _
                                      ByVal lCell As Long, _
                                      sText As String, _
                                      lIcon As Long)
    
    '/* from database return corresponding row/field
    '/* data into the grid. Ex.
    ' .move lRow
    'If lCell = 1 Then
        'lIcon = .fetchfield(1)
    'Else
        'sText = .fetchfield(lCell)
    'End If
    Select Case lCell
    '/* item
    Case 0
        sText = ""
        lIcon = -1
    Case 1
        sText = "Row: " & Format$(lRow, "#,###,##0") & ", First Cell"
        lIcon = Left(lRow, 1)
    Case Else
        sText = "Row: " & lRow & ", Cell: " & lCell
    End Select
    
End Sub

Private Sub ucVHGrid1_DragDrop(Source As Control, x As Single, y As Single)
'item drag
End Sub

Private Sub ucVHGrid1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
'drag over item
End Sub

Private Sub ucVHGrid1_eHAdvancedEditChange(ByVal lRow As Long, ByVal lCell As Long, ByVal lIcon As Long, ByVal lBackColor As Long, ByVal lForeColor As Long, ByVal sText As String)
'advanced edit data change
End Sub

Private Sub ucVHGrid1_eHAdvancedEditRequest(ByVal lRow As Long, ByVal lCell As Long)
'advanced edit loaded
End Sub

Private Sub ucVHGrid1_eHAdvancedEditRequestText(ByVal lRow As Long, ByVal lCell As Long, lIcon As Long, sText As String)
'advanced edit requesting text
End Sub

Private Sub ucVHGrid1_eHColumnAdded(ByVal lColumn As Long, ByVal lWidth As Long, ByVal lIcon As Long, ByVal sText As String)
'column has been added
End Sub

Private Sub ucVHGrid1_eHColumnClick(ByVal lColumn As Long)
'/* column clicked
    Debug.Print "ColumnClick " & lColumn
End Sub

Private Sub ucVHGrid1_eHColumnDragComplete()
'column drag completed
End Sub

Private Sub ucVHGrid1_eHColumnDragging(ByVal lColumn As Long)
'column is dragging
End Sub

Private Sub ucVHGrid1_eHColumnHorizontalSize(ByVal lColumn As Long)
'header horizontal size change
End Sub

Private Sub ucVHGrid1_eHColumnRemoved(ByVal lColumn As Long)
'column has been removed
End Sub

Private Sub ucVHGrid1_eHColumnVerticalSize(ByVal lHeight As Long)
'column verical size changed
End Sub

Private Sub ucVHGrid1_eHEditChange(ByVal lRow As Long, ByVal lCell As Long, ByVal sText As String)
'edit changed text
End Sub

Private Sub ucVHGrid1_eHEditRequest(ByVal lRow As Long, ByVal lCell As Long)
'edit loaded
End Sub

Private Sub ucVHGrid1_eHEditRequestText(ByVal lRow As Long, ByVal lCell As Long, sText As String)
'edit requesting text
End Sub

Private Sub ucVHGrid1_eHErrCond(ByVal sRtn As String, ByVal lErr As Long)
'/* grid error
    Debug.Print "Error: " & sRtn & " #" & lErr
End Sub

Private Sub ucVHGrid1_eHGridEnable(ByVal bState As Boolean)
'grid enable state change
End Sub

Private Sub ucVHGrid1_eHGridSizeChange(ByVal lWidth As Long, ByVal lHeight As Long)
'grid size changing
End Sub

Private Sub ucVHGrid1_eHItemCheck(ByVal lRow As Long, ByVal bState As Boolean)
'/* item check state change
    Debug.Print "check: " & lRow & " " & bState
End Sub

Private Sub ucVHGrid1_eHItemClick(ByVal lRow As Long, ByVal lCell As Long)
'/* item clicked
    Debug.Print "Item click: Row " & lRow & ", cell " & lCell
End Sub

Private Sub ucVHGrid1_eHItemDeleted(ByVal lRow As Long)
'item deleted
End Sub

Private Sub ucVHGrid1_eHItemDragComplete(ByVal lSource As Long, ByVal lTarget As Long)
'item drag completed
End Sub

Private Sub ucVHGrid1_eHItemDragging(ByVal lRow As Long)
'item dragging
End Sub

Private Sub ucVHGrid1_GotFocus()
'grid has focus
End Sub

Private Sub ucVHGrid1_LostFocus()
'grid lost focus
End Sub

Private Sub ucVHGrid1_Validate(Cancel As Boolean)
'validate drag data
End Sub

Private Function RandomNum(ByVal lBase As Long, _
                           ByVal lSpan As Long) As Long

    RandomNum = Int(Rnd() * lSpan) + lBase

End Function