gridedit.cls

表格修改控件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsGridEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public RowsPerPage As Long
Public Editable As Boolean

Private Const CB_GETDROPPEDSTATE = &H157

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private grd As MSFlexGrid
Private txt As TextBox
Private arrColEditable() As Boolean
Private arrIscbo() As Boolean
Private arrcbo() As ComboBox

Private grdUpdateable As Boolean
Private grdScrollByKeyDown As Boolean
Private LastTopRow As Long

Sub grdInit(ctlgrd As MSFlexGrid, Optional ctltxt)
  Dim I As Long
  
  Set grd = ctlgrd
  With grd
    .AllowUserResizing = flexResizeNone
    RowsPerPage = .Rows - .FixedRows
    LastTopRow = .FixedRows
    
    If IsMissing(ctltxt) Then
      Set txt = Nothing
    Else
      Set txt = ctltxt
    End If
    
    ReDim arrColEditable(.Cols - 1)
    ReDim arrIscbo(.Cols - 1)
    ReDim arrcbo(.Cols - 1)
    For I = 0 To .Cols - 1
      arrColEditable(I) = ((Not IsMissing(ctltxt)) And (I >= .FixedCols))
      arrIscbo(I) = False
      Set arrcbo(I) = Nothing
    Next I
    Editable = True
  End With
End Sub

Sub cboInit(ctlcbo As ComboBox, ByVal ColIndex As Long)
  arrColEditable(ColIndex) = True
  arrIscbo(ColIndex) = True
  Set arrcbo(ColIndex) = ctlcbo
End Sub

Private Sub Class_Terminate()
  Dim I As Long
  
  Set txt = Nothing
  For I = 0 To grd.Cols - 1
    Set arrcbo(I) = Nothing
  Next I
  Set grd = Nothing
End Sub

Sub grdGotFocus()
  If Not Editable Then Exit Sub
  With grd
    On Error Resume Next
    If .Row < .FixedRows Then .Row = .FixedRows
    If .Col < .FixedCols Then .Col = .FixedCols
    If Err = 0 Then ctlMove
  End With
End Sub

Sub grdScroll()
  On Error Resume Next
  With grd
    If Editable Then
      If Not grdScrollByKeyDown Then
        grdScrollByKeyDown = True
        If LastTopRow <> .TopRow Then
          .Row = .Row + (.TopRow - LastTopRow)
          ctlMove
        Else
          ctlMove .LeftCol
        End If
        grdScrollByKeyDown = False
      End If
    End If
    LastTopRow = .TopRow
  End With
End Sub

Sub txtChange()
  If Editable And grdUpdateable Then grd.Text = txt.Text
End Sub

Sub cboChange()
  If Editable And grdUpdateable Then grd.Text = arrcbo(grd.Col).Text
End Sub

Sub txtKeyDown(KeyCode As Integer, Shift As Integer)
  Dim N As Long
  Dim I As Long
  
  If Not Editable Then Exit Sub
  grdScrollByKeyDown = True
  With grd
    Select Case KeyCode
      Case vbKeyUp
        KeyCode = 0
        If .Row > .FixedRows Then
          .Row = .Row - 1
          ctlMove
        End If
      Case vbKeyDown
        KeyCode = 0
        If .Row < .Rows - 1 Then
          grd.Row = grd.Row + 1
          ctlMove
        End If
      Case vbKeyPageUp
        KeyCode = 0
        N = .Row - RowsPerPage
        If N < .FixedRows Then N = .FixedRows
        If .Row <> N Then
          .Row = N
          ctlMove
        End If
      Case vbKeyPageDown
        KeyCode = 0
        N = .Row + RowsPerPage
        If N >= .Rows Then N = .Rows - 1
        If .Row <> N Then
          .Row = N
          ctlMove
        End If
      Case vbKeyLeft
        If (Shift = 2) Or ((txt.SelStart = 0) And (txt.SelLength = 0)) Then
          KeyCode = 0
          If .Col > .FixedCols Then ctlMove .Col - 1, True
        End If
      Case vbKeyRight
        If (Shift = 2) Or (txt.SelStart = Len(txt.Text)) Then
          KeyCode = 0
          If .Col < .Cols - 1 Then ctlMove .Col + 1
        End If
      Case vbKeyHome
        If (Shift = 2) Or ((txt.SelStart = 0) And (txt.SelLength = 0)) Then
          KeyCode = 0
          If .Col > .FixedCols Then ctlMove .FixedCols
        End If
      Case vbKeyEnd
        If (Shift = 2) Or (txt.SelStart = Len(txt.Text)) Then
          KeyCode = 0
          If .Col < .Cols - 1 Then ctlMove .Cols - 1
        End If
      Case vbKeyReturn
        N = -1
        For I = .Col + 1 To .Cols - 1
          If arrColEditable(I) Then
            N = I
            Exit For
          End If
        Next I
        If N = -1 Then
          If .Row < .Rows - 1 Then
            .Row = .Row + 1
            ctlMove .FixedCols
          End If
        Else
          ctlMove N
        End If
    End Select
  End With
  grdScrollByKeyDown = False
End Sub

Sub cboKeyDown(KeyCode As Integer, Shift As Integer)
  Dim N As Long
  Dim I As Long
  
  If Not Editable Then Exit Sub
  grdScrollByKeyDown = True
  With grd
    Select Case KeyCode
      Case vbKeyUp
        If SendMessage(arrcbo(.Col).hwnd, CB_GETDROPPEDSTATE, 0, 0) = 0 Then
          KeyCode = 0
          If .Row > .FixedRows Then
            .Row = .Row - 1
            ctlMove
          End If
        End If
      Case vbKeyDown
        If (Shift <> 4) And (SendMessage(arrcbo(.Col).hwnd, CB_GETDROPPEDSTATE, 0, 0) = 0) Then
          KeyCode = 0
          If .Row < .Rows - 1 Then
            grd.Row = grd.Row + 1
            ctlMove
          End If
        End If
      Case vbKeyPageUp
        If SendMessage(arrcbo(.Col).hwnd, CB_GETDROPPEDSTATE, 0, 0) = 0 Then
          KeyCode = 0
          N = .Row - RowsPerPage
          If N < .FixedRows Then N = .FixedRows
          If .Row <> N Then
            .Row = N
            ctlMove
          End If
        End If
      Case vbKeyPageDown
        If SendMessage(arrcbo(.Col).hwnd, CB_GETDROPPEDSTATE, 0, 0) = 0 Then
          KeyCode = 0
          N = .Row + RowsPerPage
          If N >= .Rows Then N = .Rows - 1
          If .Row <> N Then
            .Row = N
            ctlMove
          End If
        End If
      Case vbKeyLeft
        If arrcbo(.Col).Style = 2 Then
          KeyCode = 0
          If .Col > .FixedCols Then ctlMove .Col - 1, True
        Else
          If (Shift = 2) Or ((arrcbo(.Col).SelStart = 0) And (arrcbo(.Col).SelLength = 0)) Then
            KeyCode = 0
            If .Col > .FixedCols Then ctlMove .Col - 1, True
          End If
        End If
      Case vbKeyRight
        If arrcbo(.Col).Style = 2 Then
          KeyCode = 0
          If .Col < .Cols - 1 Then ctlMove .Col + 1
        Else
          If (Shift = 2) Or (arrcbo(.Col).SelStart = Len(arrcbo(.Col).Text)) Then
            KeyCode = 0
            If .Col < .Cols - 1 Then ctlMove .Col + 1
          End If
        End If
      Case vbKeyHome
        If arrcbo(.Col).Style = 2 Then
          KeyCode = 0
          If .Col > .FixedCols Then ctlMove .FixedCols
        Else
          If (Shift = 2) Or ((arrcbo(.Col).SelStart = 0) And (arrcbo(.Col).SelLength = 0)) Then
            KeyCode = 0
            If .Col > .FixedCols Then ctlMove .FixedCols
          End If
        End If
      Case vbKeyEnd
        If arrcbo(.Col).Style = 2 Then
          KeyCode = 0
          If .Col < .Cols - 1 Then ctlMove .Cols - 1
        Else
          If (Shift = 2) Or (arrcbo(.Col).SelStart = Len(arrcbo(.Col).Text)) Then
            KeyCode = 0
            If .Col < .Cols - 1 Then ctlMove .Cols - 1
          End If
        End If
      Case vbKeyReturn
        If SendMessage(arrcbo(.Col).hwnd, CB_GETDROPPEDSTATE, 0, 0) = 0 Then
          KeyCode = 0
          SendKeys "%{DOWN}"
        Else
          N = -1
          For I = .Col + 1 To .Cols - 1
            If arrColEditable(I) Then
              N = I
              Exit For
            End If
          Next I
          If N = -1 Then
            If .Row < .Rows - 1 Then
              .Row = .Row + 1
              ctlMove .FixedCols
            End If
          Else
            ctlMove N
          End If
        End If
    End Select
  End With
  grdScrollByKeyDown = False
End Sub

Private Sub ctlMove(Optional ColIndex, Optional ByVal ToLeft As Boolean)
  Dim I As Integer
  Dim L As Integer
  Dim T As Integer
  Dim W As Integer
  Dim H As Integer
  
  With grd
    If IsMissing(ColIndex) Then ColIndex = .Col
    If Not arrColEditable(ColIndex) Then
      If ToLeft Then
        For I = ColIndex To .FixedCols Step -1
          ColIndex = I
          If arrColEditable(ColIndex) Then Exit For
        Next I
      End If
      For I = ColIndex To .Cols - 1
        ColIndex = I
        If arrColEditable(ColIndex) Then Exit For
      Next I
      If Not arrColEditable(ColIndex) Then
        For I = ColIndex To .FixedCols Step -1
          ColIndex = I
          If arrColEditable(ColIndex) Then Exit For
        Next I
        If Not arrColEditable(ColIndex) Then GoTo ctlMoveExit   'No Col is Editable
      End If
    End If
    If .Col <> ColIndex Then .Col = ColIndex
    L = .Left + .CellLeft - 15
    T = .Top + .CellTop - 15
    W = .CellWidth + 30
    H = .CellHeight + 30
  End With
  
  grdUpdateable = False
  If arrIscbo(grd.Col) Then
    With arrcbo(grd.Col)
      .Move L, T, W
      .ListIndex = -1
      On Error Resume Next
      .Text = grd.Text
      .Visible = True
      .SetFocus
    End With
  Else
    With txt
      .Move L, T, W, H
      .Text = grd.Text
      .SelStart = 0
      .SelLength = Len(.Text)
      .Visible = True
      .SetFocus
    End With
  End If
  grdUpdateable = True
ctlMoveExit:
End Sub

Public Property Get ColEditable(ByVal ColIndex As Integer) As Boolean
  ColEditable = arrColEditable(ColIndex)
End Property

Public Property Let ColEditable(ByVal ColIndex As Integer, ByVal vNewValue As Boolean)
  arrColEditable(ColIndex) = vNewValue
End Property