玖叶教程网

本文于2023年5月15日首发于本人同名公众号，更多文章案例请关注微信公众号：Excel活学活用！

☆本期内容概要☆

• 用户窗体设置：用户管理代码-

由于是从别的应用中复制过来的用户窗体，有部分代码没有删除干净，待后续调整，目前仅有限测试通过。

Private Declare PtrSafe Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetScrollPos Lib "user32" (ByVal hwnd As LongPtr, ByVal nBar As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As LongPtr
Private Const LVM_FIRST = &H1000
Private Const LVM_SCROLL = (LVM_FIRST + 20)
Private Const SB_HORZ = 0
Private Const LOGPIXELSX = 88


Private EditableCol As String                    '窗体初始化时指定可以编辑的列号，如"01/03/10"
Private EditableField As String                  '可编辑表头字段，根据它来转化成EditableCol
Private strRequiredCol As String                 '必填列，如"01/03/10"，数据库中自动编号不能设置
Private strRequiredField As String               '必填字段，根据它来转化成strRequiredCol
Private sngPixelPerPoint As Double               '每像素的磅数，窗体初始化时计算一次即可
Private intCol As Integer                        '记录ListView第几列被点击，Listview标题索引从1开始
Private blnFlag As Boolean                       '按下Escape键时，指示InkEdit1_Exit事件不保存修改
'Private blnNewItem As Boolean                    '新增一行标识符。如果新增行未保存或未删除，该标识为TRUE
Private strOriginal As String                    '记录每次显示InkEdit时的原始值，用于其退出时的比较
Private arrData As Variant                       '数据数组，如果连接数据库，请使用ADO的Recordset对象




Dim p As Long
Dim SortType As Integer
Dim iTotal As Double
Dim DicMonth
Dim aData()
Dim iRow
Dim iCol
Dim tbTitle(), sTbtitle()
Dim arrStr() As String
Dim ItemStr As String
Dim ModifyStatus As Integer                      '修改状态，点
Dim DeleteStatus As Integer                      '删除状态，记录是否有删除动作
Dim arrModifyCode()                              '修改的科目代码
Dim arrModifyItems()
Dim arrOldItems(), arrNewItems()
Dim LvItem As ListItem
Dim arrWidth()
Dim arr(), arrType() 'Usf_Interm 中组合框数据源
Dim preDate As Date
Dim preColor
Dim preNumber As Integer
Dim intRow As Integer    'selecteditems的行号
'Dim AccCode As String, AccName As String
Dim CheckBoxStatus As Boolean
Dim strDeletedId As String
Dim strDeletedAccCode As String
Dim initSQL As String     'listview初始化数据的sql,在保存后再调用重新加载数据


Dim strModifiedID As String
Dim intStrikeTimes As Integer  '记录Esc键的按键次数
Dim lastEscapeTime As Single  '记录第一次按下ESC的时间
Private Sub Cmd_Exit_Click()


    If ModifyStatus > 0 Or DeleteStatus > 0 Then
        If Not wContinue("所有未保存的操作将丢失！") Then Exit Sub
    End If
    Call RestoreAPI
    ModifyStatus = 0
    DeleteStatus = 0
    Unload Me
End Sub
Private Sub AddNewItem(Optional ByVal AddPos As String = "end")
    Dim IDX As Integer
    If ShiftKeyPressed Then
        If AddPos = "before" Then
            AddPos = "after"
        ElseIf AddPos = "after" Then
            AddPos = "before"
        End If
    End If
    
    If Me.LvDetail.ListItems.Count = 0 Then
        IDX = 1
    Else
        If AddPos = "end" Then
            IDX = Me.LvDetail.ListItems.Count + 1
        ElseIf AddPos = "top" Then
            IDX = 1
        ElseIf AddPos = "before" Then
            If Me.LvDetail.SelectedItem.index = 1 Then
                IDX = 1
            Else
                IDX = Me.LvDetail.SelectedItem.index - 1
            End If
        ElseIf AddPos = "after" Then
            IDX = Me.LvDetail.SelectedItem.index + 1
        Else
            IDX = Me.LvDetail.ListItems.Count + 1
            
        End If
    End If
    
    
    '根据指定字段转化可编辑列、必填列
    With Me.LvDetail
        For i = 1 To .ColumnHeaders.Count
            If InStr(EditableField, "All") Then
                If .ColumnHeaders(i) <> "ID" Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            ElseIf InStr(EditableField, "Except") Then
                If .ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
                
            Else
                If InStr(EditableField, .ColumnHeaders(i)) Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            End If
            
        Next
        
    End With
    'Stop
    With Me.LvDetail
        Set LvItem = .ListItems.Add(IDX, , "")
        If currTable = "tb凭证" Then
            LvItem.SubItems(7) = 0: LvItem.SubItems(8) = 0
            LvItem.SubItems(3) = .ListItems(.ListItems.Count - 1).SubItems(3)
        ElseIf currTable = "tb期初余额" Then
            LvItem.SubItems(1) = CDate(currYear & "/1/1")
            LvItem.SubItems(2) = "期初余额"
            LvItem.SubItems(7) = 0
        End If
        .ListItems(IDX).EnsureVisible
    End With
    
    ModifyStatus = ModifyStatus + 1
End Sub


Private Sub CmdAddNew_Click()
    Call AddNewItem("after")
End Sub


Private Sub CmdChangeColWidth_Click()
    Dim lvWidth As Double
    If Me.CmdChangeColWidth.Caption = "解冻列宽" Then
        Me.FrmHeader.Visible = False
        Me.LvDetail.HideColumnHeaders = False
        Me.LvDetail.Top = Me.FrmHeader.Top
        Me.CmdChangeColWidth.Caption = "固定列宽"
    ElseIf Me.CmdChangeColWidth.Caption = "固定列宽" Then
        Me.FrmHeader.Visible = True
        With Me.LvDetail
            For i = 1 To .ColumnHeaders.Count
                .ColumnHeaders(i).Width = arrWidth(i - 1)
                lvWidth = lvWidth + arrWidth(i - 1)
                
            Next
            
            .HideColumnHeaders = True
            .Top = Me.FrmHeader.Top + Me.FrmHeader.Height
            .Width = lvWidth
            If currTable = "tb凭证" Then
                Me.Width = lvWidth + 20 + 20
            Else
                Me.Width = lvWidth + 20
            End If
        End With
        Me.CmdChangeColWidth.Caption = "解冻列宽"
        Me.CmdChangeColWidth.Left = Me.LvDetail.Left + Me.LvDetail.Width - Me.CmdChangeColWidth.Width
        Me.CmdChangeWidth.Left = Me.CmdChangeColWidth.Left - Me.CmdChangeWidth.Width - 2
        Me.Frame3.Left = Me.LvDetail.Left + Me.LvDetail.Width - Me.Frame3.Width
    End If
    
End Sub


Private Sub CmdCopyRecord_Click()
    Call AddNewItem("after")
    
    For j = 1 To LvDetail.ColumnHeaders.Count - 1
        LvItem.SubItems(j) = Me.LvDetail.SelectedItem.SubItems(j)
    Next
End Sub


Private Sub CmdDateDown_Click()
    Dim temDate
    If Me.TxbDate = "" Then Exit Sub
    preMonth = Month(CDate(Me.TxbDate))
    temDate = CDate(Me.TxbDate) - 1
    
    If VoucherProcType = "凭证修改" Then
        If Month(temDate) <> preMonth Then
            Me.TxbDate = temDate + 1
        Else
            Me.TxbDate = temDate
            
        End If
    Else
        If Year(temDate) < Val(currYear) Then
            Me.TxbDate = CDate(currYear & "/1/1")
        Else
            Me.TxbDate = temDate
        End If
        
        
    End If
    
End Sub


Private Sub CmdDateUp_Click()
    Dim temDate
    If Me.TxbDate = "" Then Exit Sub
    
    preMonth = Month(CDate(Me.TxbDate))
    temDate = CDate(Me.TxbDate) + 1
    
    If VoucherProcType = "凭证修改" Then
        If Month(temDate) <> preMonth Then
            Me.TxbDate = temDate - 1
        Else
            Me.TxbDate = temDate
            
        End If
    Else
        If Year(temDate) > Val(currYear) Then
            Me.TxbDate = CDate(currYear & "/12/31")
        Else
            Me.TxbDate = temDate
        End If
    End If
End Sub


Private Sub CmdDelete_Click()
    Dim AccountCode As String
    Dim AccTypeCode As String
    Dim ItemName As String
    Dim ItemTypeCode As String
    Dim UserName As String
    Dim arr()
    strDeletedId = ""
    strDeletedAccCode = ""
    With LvDetail
        For i = 1 To .ListItems.Count
            If .ListItems(i).Checked = True Then
                If .ListItems(i).Text <> "" Then
                   
                    '把删除的id记录下来
                    
                    strDeletedId = strDeletedId & Me.LvDetail.ListItems(i).Text & "/"
                End If
                s = s + 1
            End If
        Next
    End With
    
    If s = 0 Then
        MsgBox "请钩选想要删除的记录！"
        Exit Sub
    End If
    'Stop
    With Me.LvDetail
        For i = .ListItems.Count To 1 Step -1
            If .ListItems(i).Checked = True Then
                .ListItems.Remove (i)
            End If
        Next
    End With
    
    DeleteStatus = DeleteStatus + 1
    'Stop
    
End Sub


Private Sub CmdIncreaseHeight_Click()
    Dim H As Integer
    If ShiftKeyPressed Then
        Me.CmdIncreaseHeight.Caption = "减高"
        Me.CmdIncreaseHeight.ForeColor = vbBlack
        H = -20
    Else
        Me.CmdIncreaseHeight.Caption = "增高"
        Me.CmdIncreaseHeight.ForeColor = &HFF00FF
        H = 20
    End If
    Me.Height = Me.Height + H
    Me.LvDetail.Height = Me.LvDetail.Height + H
    Me.Frame3.Top = Me.Frame3.Top + H
End Sub
Private Sub CmdNumberDown_Click()
   If VoucherProcType = "凭证修改" Then Exit Sub
    Me.TxbNumber = IIf(Me.TxbNumber - 1 > 0, Me.TxbNumber - 1, 1)
    
End Sub


Private Sub CmdNumberUp_Click()
If VoucherProcType = "凭证修改" Then Exit Sub
    Me.TxbNumber = IIf(Me.TxbNumber + 1 < 999, Me.TxbNumber + 1, 999)
End Sub


Private Sub CmdOutPut_Click()
    If Not wContinue("即将导出！") Then Exit Sub
    On Error Resume Next
    Dim arrT()
    Dim iPath As String, iYear As String
    Dim iSheet As Worksheet
    
    If Me.CkB_ChoseFolder.Value = True Then
        iPath = PathSelected & "\"
    Else
        iPath = ThisWorkbook.Path & "\"
    End If
    fName = Me.LbTitle & Format(VBA.Now, "YYYYMMDDhhmmss") & ".xlsx"
    Application.DisplayAlerts = False
    iRow = Me.LvDetail.ListItems.Count + 1
    iCol = Me.LvDetail.ColumnHeaders.Count
    ReDim arrT(1 To iRow, 1 To iCol)
    For i = 1 To iCol
        arrT(1, i) = Me.LvDetail.ColumnHeaders(i)
    Next
    For i = 2 To iRow
        arrT(i, 1) = Me.LvDetail.ListItems(i - 1).Text
        For j = 2 To iCol
            arrT(i, j) = Me.LvDetail.ListItems(i - 1).SubItems(j - 1)
        Next
    Next
    Workbooks.Add
    ActiveWorkbook.Sheets(1).Range("A1").Resize(iRow, iCol) = arrT
    ActiveWorkbook.SaveAs Filename:=iPath & fName
    ActiveWorkbook.Close
    MsgBox ("成功导出文件" & iPath & fName)
    Unload Me
    Application.DisplayAlerts = True
End Sub


Private Sub CmdSave_Click()
    Dim arrTable()
    Dim LvItem As ListItem
    Dim NullCount As Integer
    Dim arrID() As String       '先不确定数据类型，用来存放split(strdeletedid)
    Dim arrAccCode() As String
    On Error Resume Next
    If CmdChangeColWidth.Caption = "固定列宽" Then
        Call CmdChangeColWidth_Click
    End If


    If ModifyStatus = 0 And DeleteStatus = 0 Then
        MsgBox "数据无任何修改，无需保存！"
        Exit Sub
    End If
    
    '检查数据完整性、准确性↓↓↓↓↓↓↓↓↓↓↓↓↓↓
    '1、检查必填项是否为空
    With Me.LvDetail
        For i = 1 To .ListItems.Count
            If .ListItems(i).Text = "" Then
                For j = 2 To .ColumnHeaders.Count
                    If InStr(strRequiredCol, Format(j, "00")) Then
                        If .ListItems(i).SubItems(j - 1) = "" Then
                            MsgBox "第【" & j & "】列【" & .ColumnHeaders(j) & "】不能为空！"
                            'Stop
                            Exit Sub
                        End If
                    End If
                Next
            Else
            End If
        Next
    End With
    '检查数据完整性、准确性↑↑↑↑↑↑↑↑↑↑↑↑↑↑
    '删除记录
    If Len(Replace(strDeletedId, "/", "")) > 0 Then
        'Stop
        strDeletedId = Left(strDeletedId, Len(strDeletedId) - 1)
        arrID = Split(strDeletedId, "/")
        If Not wContinue("即将删除以下ID的记录：" & Chr(10) & strDeletedId & Chr(10) & "此操作不可恢复，请谨慎执行！") Then Exit Sub
        SQL = "delete * from " & currTable & " where id in (" & Join(arrID, ",") & ")"
       Call ExecuteSQL(dataFile, SQL)
    End If
    
    '增加、修改记录，建立数据连接
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    passWord = "p111111"
    StrCnn = GetStrCnn(dataFile, passWord)
    cnn.Open StrCnn
    rs.Open currTable, cnn, 1, 3
    With Me.LvDetail
        For i = 1 To .ListItems.Count
            If Len(Trim(.ListItems(i).Text)) > 0 Then '对id不为空的记录，即可能被修改的记录进行操作
                If InStr(strModifiedID, .ListItems(i).Text) Then               '判断存放id的数组是否为空值，如果为空，则表明没有修改的记录，不用执行更新
                    
                    rs.movefirst
                    Do Until rs.EOF
                        If rs!ID = .ListItems(i).Text Then
                            'rs.Edit
                            For k = 1 To .ColumnHeaders.Count - 1
                                '数据库中“是/否”字段值为“-1/0”，但显示为“true/false”
                                rs.Fields(k) = IIf(.ListItems(i).SubItems(k) = "true", -1, IIf(.ListItems(i).SubItems(k) = "false", 0, .ListItems(i).SubItems(k)))
                            Next
                            rs.Update
                        End If
                        rs.MoveNext
                      Loop
                  End If
                  Else                                 '对id为空的记录，即新增的记录进行操作，向数据库写入记录
                        rs.AddNew
                        For k = 1 To .ColumnHeaders.Count - 1
                            rs.Fields(k) = IIf(.ListItems(i).SubItems(k) = "true", -1, IIf(.ListItems(i).SubItems(k) = "false", 0, .ListItems(i).SubItems(k)))
                        Next
                        rs.Update
                 End If
                        
              Next
        End With
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
        If currTable = "tb凭证" Then
            If VoucherProcType = "凭证制单" Then
                MsgBox "成功保存凭证【" & Me.TxbNumber & "】号！", , Me.LbTitle
            ElseIf VoucherProcType = "凭证修改" Then
                MsgBox "成功修改凭证【" & Me.TxbNumber & "】号！", , Me.LbTitle
            End If
        Else
            MsgBox "保存成功！", , Me.LbTitle
        End If
        ModifyStatus = 0
        strDeletedId = ""
        DeleteStatus = 0
        Me.LvDetail.ColumnHeaders.Clear
        Me.LvDetail.ListItems.Clear
        Call UserForm_Initialize
End Sub


Private Sub CmdSearch_Click()
    On Error Resume Next
    Me.LvDetail.ListItems.Clear
    iTotal = 0
    Dim searchStr As String
    Dim LvItem As ListItem
    iRow = UBound(aData, 2)
    iCol = UBound(aData, 1)
    For i = 0 To iRow
        For j = 0 To iCol
            searchStr = searchStr & "|" & aData(j, i)
        Next
        If InStr(1, searchStr, Me.TextBox1.Value, 1) Then
            Set LvItem = Me.LvDetail.ListItems.Add
            LvItem.Text = aData(0, i)
            For j = 1 To iCol
                LvItem.SubItems(j) = aData(j, i)
            Next
        End If
        searchStr = ""
    Next
End Sub


Private Sub CmdVoucherCopy_Click()
    Usf_VoucherList.Show
End Sub
Private Sub CmdVoucherProcess_Click()
    If VoucherProcType = "凭证制单" Then
        VoucherProcType = "凭证修改"
    Else
        VoucherProcType = "凭证制单"
    End If
    Unload Me
    Usf_AddAndModify.Show
    
End Sub


Private Sub InkEdit1_DblClick()
    Dim currID As String
    On Error Resume Next
    With Me.LvDetail
        '共同选项
       If .ColumnHeaders(intCol) = "使用状态" Or .ColumnHeaders(intCol) = "状态" Then
            With Usf_Interm
                
                .Caption = "选择【使用状态】"
                
                arrType = Array("正常", "封存")
                With Usf_Interm.CmbInterm
                    .Clear
                    .List = arrType
                    .Text = Me.InkEdit1.Text
                End With
                .Show
            End With
            
        End If
        If currTable = "tb基础信息" Then '基础设置
        ElseIf currTable = "tb用户" Then '用户管理
            If .ColumnHeaders(intCol) = "权限" Then
                With Usf_Interm
                    .Caption = "选择【权限】"
                    '选择用户权限
                    SQL = "select distinct 权限 from tb用户权限"
                    arrType = GetData(dataFile, SQL)
                    With Usf_Interm.CmbInterm
                        .Clear
                        For i = 0 To UBound(arrType, 2)
                            .AddItem arrType(0, i)
                        Next
                        .Text = Me.InkEdit1.Text
                    End With
                    .Show
                End With
            End If
        
            
        End If
    End With
End Sub


Private Sub LbTopDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If Me.TxbDate = "" Then Exit Sub
    preDate = CDate(Me.TxbDate)
    Usf_ChangeDate.Show
    
End Sub


Private Sub LbTopModify_Click()
If Me.TxbDate = "" Then Exit Sub
Usf_ChangeDate.Show
End Sub


Private Sub TxbDate_Change()
    If VoucherProcType = "凭证修改" Then Exit Sub
    iMonth = Format(Me.TxbDate, "YYYYMM")
    If Format(preDate, "YYYYMM") = iMonth Then Exit Sub
    SQL = "select count(*) from tb凭证 where 月份='" & iMonth & "'"
    n = RecordValue(dataFile, SQL)
    If n > 0 Then
        SQL = "select top 1 凭证号 from tb凭证 where 月份='" & iMonth & "' order by 分录号 DESC"
        
        preNumber = RecordValue(dataFile, SQL)
        Me.TxbNumber = preNumber + 1
    Else
        Me.TxbNumber = 1
    End If
    'Stop
End Sub


Private Sub LvDetail_Click()
    If currTable = "tb用户" Then
        EditableField = "All"
    End If
    EditableCol = ""
    With Me.LvDetail
        For i = 1 To .ColumnHeaders.Count
            If InStr(EditableField, "All") Then
                If .ColumnHeaders(i) <> "ID" Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            ElseIf InStr(EditableField, "Except") Then
                If .ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            Else
                If InStr(EditableField, .ColumnHeaders(i)) Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            End If
        Next
    End With
    If InStr(EditableCol, Format(intCol, "00")) Then
        Call ShowInkEdit
    End If
End Sub
Private Sub TxbNumber_Change()
    If VoucherProcType = "凭证修改" Then Exit Sub
    Me.TxbNumber = Left(Me.TxbNumber, 3)
    Me.TxbNumber = IIf(Val(Me.TxbNumber) = 0, 1, Val(Me.TxbNumber))
End Sub
Private Sub CmdChangeWidth_Click()
    With Me.LvDetail
        For i = 1 To .ColumnHeaders.Count
            W = W + .ColumnHeaders(i).Width
        Next
        .Width = W
        If currTable = "tb凭证" Then
            Me.Width = .Width + 20 + 15
        Else
            Me.Width = .Width + 20
        End If
        W = 0
    End With
    Me.CmdChangeColWidth.Left = Me.LvDetail.Left + Me.LvDetail.Width - Me.CmdChangeColWidth.Width
    Me.CmdChangeWidth.Left = Me.CmdChangeColWidth.Left - Me.CmdChangeWidth.Width - 2
    Me.Frame3.Left = Me.LvDetail.Left + Me.LvDetail.Width - Me.Frame3.Width
    Me.LbTitle.Left = Me.Width / 2 - Me.LbTitle.Width / 2
End Sub
Private Sub UserForm_Initialize()
    dataFile = ThisWorkbook.Path & "\收费管理系统数据库.accdb"
    currTable = "tb用户"
    Dim ItemTypeCode As String
    Dim lbCtrl As Control
    If dataFile = "" Then
        MsgBox "数据库文件路径异常，请重新登录！"
        Exit Sub
    End If
'    Stop
    On Error Resume Next
    'SQL语句,列宽 ，指定可编辑列，必填列的字段名称,标题
    If currTable = "tb用户" Then
'        Stop
        initSQL = "select * from " & currTable & " where 用户ID<>'admin' and 用户ID<>'Superuser'"
        arrWidth = Array(40, 100, 100, 80, 80, 80, 80, 80, 80, 80, 80, 60, 60, 60, 60, 60)
        Me.LbTitle = "用户管理"
        EditableField = "Except/用户ID"
        strRequiredField = "All"
    Else
        initSQL = "select * from " & currTable
        arrWidth = Array(40, 100, 100, 80, 80, 80, 80, 80, 80, 80, 80, 60, 60, 60, 60, 60)
        Me.LbTitle = Right(currTable, Len(currTable) - 2)
        EditableField = "All"
        strRequiredField = "All"
    End If
    
'    Stop
    
    '删除动态添加的标签
    For Each lbCtrl In Me.FrmHeader.Controls
        If lbCtrl.Name Like "topLb_*" Then Controls.Remove lbCtrl.Name
    Next
    
    'Stop
    '添加表头字段，以及标签遮盖层
    Me.Frame1.Top = Me.LbTitle.Top + Me.LbTitle.Height + 5
    
    tbTitle = GetFields(dataFile, initSQL)
    For i = 0 To UBound(tbTitle, 1)
        With Me.LvDetail
            If i = 0 Then
                .ColumnHeaders.Add , , tbTitle(i), arrWidth(i)
            ElseIf InStr(tbTitle(i), "金额") Or InStr(tbTitle(i), "余额") Then
                .ColumnHeaders.Add , , tbTitle(i), arrWidth(i), lvwColumnRight
            Else
                .ColumnHeaders.Add , , tbTitle(i), arrWidth(i)
            End If
        End With
        Set lbCtrl = Me.FrmHeader.Controls.Add("Forms.Label.1", "topLb_" & i, True)
        If i = 0 Then
            iwidth = 0
        Else
            iwidth = iwidth + arrWidth(i - 1)
        End If
        With lbCtrl
            .Caption = tbTitle(i)
            .Height = 18.5
            .Top = 0
            .Width = arrWidth(i)
            .Left = iwidth
            .BorderStyle = 1
            .FontSize = 10
            .FontName = "微软雅黑"
            .ForeColor = vbWhite 'RGB(50, 50, 255)
            .BackColor = RGB(153, 153, 255)
            .TextAlign = 2
            .ZOrder (0)
        End With
    Next
    
    'listview控件的显示外观
    With Me.LvDetail
        .View = lvwReport
        .Gridlines = True                        '
        '.Sorted = True
        .CheckBoxes = True
        .LabelEdit = lvwManual
        .FullRowSelect = True
        .ForeColor = vbBlue
        '设置窗体、listview的宽度
        For i = 1 To .ColumnHeaders.Count
            W = W + .ColumnHeaders(i).Width
        Next
        .Width = W
    End With
'    Stop
    
    '根据指定字段转化可编辑列、必填列
    With Me.LvDetail
        For i = 1 To .ColumnHeaders.Count
            If InStr(EditableField, "All") Then
                If .ColumnHeaders(i) <> "ID" Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            ElseIf InStr(EditableField, "Except") Then
                If .ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
                
            Else
                If InStr(EditableField, .ColumnHeaders(i)) Then
                    EditableCol = EditableCol & Format(i, "00") & "/"
                End If
            End If
            If InStr(strRequiredField, "All") Then '如果是所有列都必填，第一列ID也是不需要且不能编辑的
                If .ColumnHeaders(i) <> "ID" Then
                    strRequiredCol = strRequiredCol & Format(i, "00") & "/"
                End If
            ElseIf InStr(strRequiredField, "Except") Then
                If .ColumnHeaders(i) <> "ID" And InStr(strRequiredField, .ColumnHeaders(i)) = 0 Then
                    strRequiredCol = strRequiredCol & Format(i, "00") & "/"
                End If
            Else
                If InStr(strRequiredField, .ColumnHeaders(i)) Then
                    strRequiredCol = strRequiredCol & Format(i, "00") & "/"
                End If
            End If
            
        Next
        
    End With
    
'    Stop
    If currTable = "tb凭证" Then
        ReDim aData(0 To UBound(tbTitle, 1) - 1, 0 To 5)
        '把金额预填0
        For i = 0 To UBound(aData, 2)
            aData(Pxy(tbTitle, "借方金额") - 1, i) = Format(0, "Standard")
            aData(Pxy(tbTitle, "贷方金额") - 1, i) = Format(0, "Standard")
        Next
    Else
        If RecordValue(dataFile, "select count(*) from " & currTable) > 0 Then
            aData = GetData(dataFile, initSQL)
        End If
        
    End If
'    Stop
    '添加明细数据到listview
    
    If Not IsArrEmpty(aData) Then
        iRow = UBound(aData, 2)
        iCol = UBound(aData, 1)
        Me.LvDetail.ListItems.Clear
        For i = 0 To iRow
            Set LvItem = Me.LvDetail.ListItems.Add
            LvItem.Text = aData(0, i)
            ForeColor = IIf(LvItem.index Mod 2, vbBlack, RGB(102, 102, 153))
            LvItem.ForeColor = ForeColor
            
            For j = 1 To iCol
                
                LvItem.SubItems(j) = aData(j, i)
                If InStr(EditableCol, Format(j + 1, "00")) Then
                    If LvItem.index Mod 2 Then
                        LvItem.ListSubItems(j).ForeColor = RGB(0, 128, 128)
                    Else
                        LvItem.ListSubItems(j).ForeColor = RGB(51, 204, 204)
                    End If
                Else
                    LvItem.ListSubItems(j).ForeColor = ForeColor
                End If
            Next
            
        Next
        
    End If
    
    '调整控件位置、窗体大小等
    With Me
        .Width = .LvDetail.Width + 20
        .LbTitle.Left = (.Width - .LbTitle.Width) / 2
        .CkB_ChoseFolder.Left = .Width - .CkB_ChoseFolder.Width - 10
        .CmdOutPut.Left = .CkB_ChoseFolder.Left - .CmdOutPut.Width - 10
        .CmdSearch.Left = .CmdOutPut.Left - .CmdSearch.Width - 10
        .TextBox1.Left = .CmdSearch.Left - .TextBox1.Width - 10
        .Frame3.Left = .LvDetail.Left + .LvDetail.Width - .Frame3.Width
    End With
    
    '对于数据行比较少的表来说，统一的listview控件高度会有很多空行，不太美观，对少于20行的表进行动态调整显示
    n = Me.LvDetail.ListItems.Count
    
    If n < 20 Then
        If n < 6 Then
            Me.LvDetail.Height = 6 * Me.LvDetail.ListItems(n).Height + 20
        Else
            Me.LvDetail.Height = (n + 1) * Me.LvDetail.ListItems(n).Height + 20
        End If
    Else
        Me.LvDetail.Height = (20 + 1) * Me.LvDetail.ListItems(n).Height + 20
    End If
    'Stop
    With FrmHeader          '表头替代字段，防止Listview表头拖动变化。
        .Visible = True
        .Top = Me.Frame1.Top + Me.Frame1.Height
        .Left = Me.LvDetail.Left
        .Width = Me.LvDetail.Width
        .Height = 19
        .Caption = ""
    End With
    With Me
        .LvDetail.Top = FrmHeader.Top + FrmHeader.Height
        .Height = LvDetail.Height + LvDetail.Top + 80
        .Frame3.Top = .Height - .Frame3.Height - 30
        .CmdChangeColWidth.Top = .FrmHeader.Top - .CmdChangeColWidth.Height
        .CmdChangeColWidth.Left = .FrmHeader.Left + .FrmHeader.Width - .CmdChangeColWidth.Width
        .CmdChangeWidth.Top = .CmdChangeColWidth.Top
        .CmdChangeWidth.Left = .CmdChangeColWidth.Left - .CmdChangeWidth.Width - 2
        
    End With
    
    
    Me.Caption = "【模块：" & Me.LbTitle & "】" _
        & "】【用户：" & currUserName & "】"
    
    '单独对凭证的显示按钮进行定义
    Me.Frame3.BackColor = Me.BackColor
    
    '***************************↓使得ListView可编辑相关代码↓*********************************
    preColor = RGB(0, 255, 255)
    InkEdit1.BackColor = preColor
    InkEdit1.Font.size = Me.LvDetail.Font.size
    InkEdit1.Width = 0
    'InkEdit1.MultiLine = False
    InkEdit1.ZOrder 0                            '把InkEdit1移到最上一层，避免被Listview遮住
    
    sngPixelPerPoint = Pixel2PointX
    blnFlag = True                               '指示InkEdit1_Exit事件是否保存修改。按下Escape键时设为False
    
    LvmPreWndProc = GetWindowLong(Me.LvDetail.hwnd, GWL_WNDPROC)
    InkPreWndProc = GetWindowLong(InkEdit1.hwnd, GWL_WNDPROC)
    SetWindowLong LvDetail.hwnd, GWL_WNDPROC, AddressOf WndProc
    SetWindowLong InkEdit1.hwnd, GWL_WNDPROC, AddressOf WndProc
    
    '***************************↑使得ListView可编辑相关代码↑*********************************
End Sub


'***************************↓使得ListView可编辑相关代码↓*********************************
'InkEdit失去焦点时即可发生Exit事件
'InkEdit退出事件。退出时需要指定是否保存修改内容。
Private Sub InkEdit1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    HideInkEdit blnFlag
    blnFlag = True
End Sub


'InkEdit控件的按键处理程序
Private Sub InkEdit1_KeyUp(pKey As Long, ByVal ShiftKey As Integer)
    Dim lngItemIndex As Long
    Dim lngColCount As Long
    Dim lngItemCount As Long
    Dim LvItem As ListItem
    Dim currIntervals As Single
    
    If pKey = 27 Then
        intStrikeTimes = intStrikeTimes + 1
        If intStrikeTimes = 1 Then
            lastEscapeTime = Timer
        ElseIf intStrikeTimes = 2 Then
            currIntervals = Timer - lastEscapeTime
        Else
            intStrikeTimes = 0
        End If
    End If
    
    
    With LvDetail
        lngItemIndex = .SelectedItem.index
        lngColCount = .ColumnHeaders.Count
        lngItemCount = .ListItems.Count
        blnFlag = True    '原来是放到每一个Case分支里的，这里只是有一条分支是False值
        
        Select Case pKey
        Case 13                                  '13=回车键
            .SetFocus
            
            If .ColumnHeaders(intCol) = "贷方金额" Then
                If lngItemIndex < lngItemCount Then
                    Set .SelectedItem = .ListItems(lngItemIndex + 1)
                    intCol = 4   '摘要
                    
                Else
                    Set LvItem = .ListItems.Add
                    LvItem.SubItems(7) = 0: LvItem.SubItems(8) = 0
                    Set .SelectedItem = .ListItems(.ListItems.Count)
                    intCol = 4
                    
                End If
                
            ElseIf intCol = lngColCount Then
                If lngItemIndex < lngItemCount Then
                    Set .SelectedItem = .ListItems(lngItemIndex + 1)
                    intCol = 2
                Else
                    Set LvItem = .ListItems.Add
                    Set .SelectedItem = .ListItems(.ListItems.Count)
                    intCol = 2
                    
                End If
                
            Else
                Set .SelectedItem = .ListItems(lngItemIndex)
                intCol = intCol + 1
            End If
            
            If InStr(EditableCol, Format(intCol, "00")) Then
                .SelectedItem.EnsureVisible
                ShowInkEdit
            End If
 
            
            
        Case 37                                  '37=向左键头
            .SetFocus                            '先触InkEdit1_Exit事件，此后Listview已获焦
            If intCol > 1 Then
                intCol = intCol - 1
                ShowInkEditForLRKey 37
            End If
        Case 38                                  '38=向上键头
            .SetFocus
            If lngItemIndex > 1 Then
                Set .SelectedItem = .ListItems(lngItemIndex - 1)
                .SelectedItem.EnsureVisible
                ShowInkEdit
            End If
        Case 39                                  '39=向右键头
            .SetFocus
            If intCol < lngColCount Then
                intCol = intCol + 1
                ShowInkEditForLRKey 39
            End If
        Case 40                                  '40=向下箭头
            .SetFocus
            If lngItemIndex < lngItemCount Then
                Set .SelectedItem = .ListItems(lngItemIndex + 1)
                .SelectedItem.EnsureVisible
                ShowInkEdit
            End If
        Case 27                                  '27 = Esc键，取消修改
            If intStrikeTimes = 2 Then  '按2次Esc键,并且两次按键时间小于2秒，才退出inkedit,在输入法中会用Esc取消输入
                If currIntervals < 0.8 Then
                    blnFlag = False
                    .SetFocus
                    intStrikeTimes = 0
                End If
            End If
        Case Else
        End Select
    End With
End Sub


'把X方向的像素值转为磅。VBA窗体的度量单位是磅。
'像素和磅的转换跟屏幕密度有关，不同电脑可能不同值。
Private Function Pixel2PointX() As Double
    Dim hDC As Long, DPIx As Long
    hDC = GetDC(0)                               '获取屏幕设备环境句柄
    DPIx = GetDeviceCaps(hDC, LOGPIXELSX)        '获取屏幕X方向像素密度
    ReleaseDC 0, hDC                             '释放屏幕设备环境
    Pixel2PointX = 72 / DPIx
End Function


'鼠标事件主要计算点击的列号。并可在此处鼠标按键条件，比如改为右键点击才计算列号，左键时列号置为零。这样InkEdit的显示程序就不会显示控件
Private Sub LvDetail_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)
    Dim sngDiff As Double                        '单击鼠标，弹起时即可触发事件。可用Button判断点击的是鼠标三键中的哪一个，1=左，2=右，4=中
    Dim sngScrollPos As Double
    Dim sngMousePosX As Double
    With LvDetail
        sngScrollPos = sngPixelPerPoint * GetScrollPos(.hwnd, SB_HORZ)
        sngMousePosX = sngPixelPerPoint * X
        For intCol = 1 To .ColumnHeaders.Count
            sngDiff = .ColumnHeaders(intCol).Left - sngScrollPos
            If sngMousePosX > sngDiff And sngMousePosX < sngDiff + .ColumnHeaders(intCol).Width Then Exit For
        Next
        If intCol > .ColumnHeaders.Count Then intCol = 0 '计算失败时，置为零
    End With
End Sub


'InkEdit控件退出时的处理程序,将修改内容同步到Listview
Private Sub HideInkEdit(Optional ByVal blnSave As Boolean = True)
    Dim OldFullName$, NewFullName$
    Dim myID As Integer                          '当前修改的ID
    On Error Resume Next
    InkEdit1.BackColor = preColor
    With LvDetail
        If .SelectedItem Is Nothing Then Exit Sub '如果InkEdit1未失焦时就关闭窗体，必报错。必须加这一句。
        If strOriginal = InkEdit1.Text Then InkEdit1.Width = 0: Exit Sub 'InkEdit的值有改变时才执行后面语句，否则浪费时间
        If Len(strRequiredCol) Then
            If InStr(strRequiredCol, Format(intCol, "00")) Then
                If Len(InkEdit1.Text) = 0 Then
                    MsgBox "该项为必填项，修改已被取消！", vbCritical
                    InkEdit1.Width = 0: Exit Sub
                End If
            End If
        End If
        
        If blnSave Then
            If intCol > 1 Then
               
               '1用户管理
                If currTable = "tb用户" Then
                    If .ColumnHeaders(intCol) = "用户ID" Then
                        If RecordValue(dataFile, "select count(用户ID)  From tb用户 where 用户ID='" & InkEdit1.Text & "'") > 0 Then
                            MsgBox "已存在【" & InkEdit1.Text & "】用户ID不能重复！"
                            Me.InkEdit1.Text = ""
                            Exit Sub
                        End If
                        If Len(InkEdit1.Text) < 4 Then
                            MsgBox "用户ID不能低于4位"
                            InkEdit1.Text = ""
                            Exit Sub
                        End If
                    ElseIf .ColumnHeaders(intCol) = "姓名" Then
                        If RecordValue(dataFile, "select count(姓名)  From tb用户 where 姓名='" & InkEdit1.Text & "'") > 0 Then
                            MsgBox "已存在【" & InkEdit1.Text & "】姓名不能重复！"
                            Me.InkEdit1.Text = ""
                            Exit Sub
                        End If
                        If Len(InkEdit1.Text) < 2 Then
                            MsgBox "姓名至少2个字符"
                            InkEdit1.Text = ""
                            Exit Sub
                        End If
                        
                    ElseIf .ColumnHeaders(intCol) = "密码" Then
                        If Len(InkEdit1.Text) < 6 Then
                            MsgBox "密码不能低于6位"
                            InkEdit1.Text = ""
                            Exit Sub
                        End If
                    End If
                    .SelectedItem.SubItems(intCol - 1) = InkEdit1.Text
                    If .SelectedItem.Text = "" Then
                        .SelectedItem.SubItems(Pxy(tbTitle, "状态") - 1) = "正常"
                    End If


                Else                             '对应 类似 ElseIf currtable="tb?" Then
                    .SelectedItem.SubItems(intCol - 1) = InkEdit1.Text
                    
                End If
                
            Else                                 '对应 if incol>1
                .SelectedItem.Text = InkEdit1.Text
            End If
            
            If .SelectedItem.Text = "" Then
                .SelectedItem.ListSubItems(intCol - 1).ForeColor = vbBlue '新增的记录标蓝
            Else
                .SelectedItem.ListSubItems(intCol - 1).ForeColor = vbRed '修改的记录标红
                
            End If
            
            ModifyStatus = ModifyStatus + 1
            
            '将生产修改的记录的ID添加到strModifiedID中，两边用/隔开，做到精确匹配
            myID = Val(.SelectedItem.Text)
            If myID > 0 Then
                If InStr(strModifiedID, "/" & myID & "/") = 0 Then
                    strModifiedID = strModifiedID & "/" & myID & "/"
                End If
            End If
            
            '**********将生产涉及修改的其他核算项目记录的ID写入数组保存***********
        End If
    End With
    InkEdit1.Width = 0
End Sub
Private Sub tb报表项目Process()
    
End Sub


'左右方向键处理程序。主要计算是水平滚动条的滚动量，以确保InkEdit可见
Private Sub ShowInkEditForLRKey(ByVal intKey As Integer)
    Dim sngNewInkLeft As Double
    Dim lngScrollAmount As Long
    Dim blnInkLocked As Boolean
    With LvDetail
        If intCol = 0 Then Exit Sub
        If .SelectedItem Is Nothing Then Exit Sub
        If InStr(EditableCol, Format(intCol, "00")) = 0 Then Exit Sub
        
        If intCol > 1 Then
            InkEdit1.Text = .SelectedItem.SubItems(intCol - 1)
        Else
            InkEdit1.Text = .SelectedItem.Text
        End If
        If intKey = 37 Then                      '向左
            sngNewInkLeft = InkEdit1.Left - .ColumnHeaders(intCol).Width
            If sngNewInkLeft < .Left + 1.5 Then
                lngScrollAmount = CLng((sngNewInkLeft - (.Left + 1.5)) / sngPixelPerPoint) '滚动量，单位像素
                SendMessageLong .hwnd, LVM_SCROLL, lngScrollAmount, 0 '拖动Listview水平滚动条，保持InkEdit可见
                InkEdit1.Left = .Left + 1.5
            Else
                InkEdit1.Left = sngNewInkLeft
            End If
        Else                                     '向右
            sngNewInkLeft = InkEdit1.Left + .ColumnHeaders(intCol - 1).Width
            If sngNewInkLeft + .ColumnHeaders(intCol).Width > .Left + .Width Then
                lngScrollAmount = CLng((sngNewInkLeft + .ColumnHeaders(intCol).Width - (.Left + .Width)) / sngPixelPerPoint)
                SendMessageLong .hwnd, LVM_SCROLL, lngScrollAmount, 0
                InkEdit1.Left = .Left + .Width - .ColumnHeaders(intCol).Width
                
            Else
                InkEdit1.Left = sngNewInkLeft
            End If
        End If
        InkEdit1.Top = .Top + .SelectedItem.Top + 1.5
        InkEdit1.Width = .ColumnHeaders(intCol).Width
        InkEdit1.Height = .SelectedItem.Height
        If Len(EditableCol) Then
            blnInkLocked = (InStr(EditableCol, Format(intCol, "00")) = 0)
        Else
            blnInkLocked = False
        End If
        InkEdit1.Locked = blnInkLocked
        InkEdit1.SelStart = 0
        InkEdit1.SelLength = Len(InkEdit1.Text)
        strOriginal = InkEdit1.Text
        InkEdit1.SetFocus
    End With
End Sub


'显示InkEdit控件的处理程序。需要显示InkEdit时调用
Private Sub ShowInkEdit()
    Dim sngScrollPos As Double
    Dim blnInkLocked As Boolean
    Dim iItem As String
    
    
    With LvDetail
        If intCol = 0 Then Exit Sub              '点击的列号未计算成功
        If .SelectedItem Is Nothing Then Exit Sub 'Listview列表为空时退出
        sngScrollPos = sngPixelPerPoint * GetScrollPos(.hwnd, SB_HORZ)
        If intCol > 1 Then
            InkEdit1.Text = .SelectedItem.SubItems(intCol - 1)
            strOriginal = InkEdit1.Text
            intRow = .SelectedItem.index
        Else
            InkEdit1.Text = .SelectedItem.Text
        End If
        
        InkEdit1.Left = .ColumnHeaders(intCol).Left + .Left + 1.5 - sngScrollPos
        InkEdit1.Top = .Top + .SelectedItem.Top + 1.5
        InkEdit1.Width = .ColumnHeaders(intCol).Width
        InkEdit1.Height = .SelectedItem.Height
        If Len(EditableCol) Then
            blnInkLocked = (InStr(EditableCol, Format(intCol, "00")) = 0)
        Else
            blnInkLocked = False
        End If
        InkEdit1.Locked = blnInkLocked
        InkEdit1.SelStart = 0
        InkEdit1.SelLength = Len(InkEdit1.Text)
        'strOriginal = InkEdit1.Text   '移到前面
        InkEdit1.SetFocus
        
    End With
End Sub
'关闭窗体时，还原Listview和InkEdit控件的窗口程序,在退出窗体时调用
Private Sub RestoreAPI()
    SetWindowLong LvDetail.hwnd, GWL_WNDPROC, LvmPreWndProc
    SetWindowLong InkEdit1.hwnd, GWL_WNDPROC, InkPreWndProc


End Sub




'***************************↑使得ListView可编辑相关代码↑*********************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then '检测关闭模式是否为点击窗口右上角的 X
        Cancel = True '取消关闭事件
    End If
End Sub

☆猜你喜欢☆

本文于2023年5月15日首发于本人同名公众号，更多文章案例请关注微信公众号：Excel活学活用！