Excel VBA 用户管理/Usf_AddAndModify窗体代码

　　Excel VBA 用户管理/Usf_AddAndModify窗体代码

　　作者：2023-08-21 10:04·Excel活学活用

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

　　

　　☆本期内容概要☆

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

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

PrivateDeclarePtrSafeFunctionSendMessageLongLib"user32"Alias"SendMessageA"(ByValhwndAsLongPtr,ByValwMsgAsLongPtr,ByValwParamAsLongPtr,ByVallParamAsLongPtr)AsLongPtrPrivate Declare PtrSafe Function GetScrollPos Lib "user32" (ByVal hwnd As LongPtr, ByVal nBar As LongPtr) As LongPtrPrivate Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPrivate Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As LongPtrPrivate Const LVM_FIRST = &H1000Private Const LVM_SCROLL = (LVM_FIRST + 20)Private Const SB_HORZ = 0Private Const LOGPIXELSX = 88Private EditableCol As String '窗体初始化时指定可以编辑的列号，如"01/03/10"Private EditableField As String '可编辑表头字段，根据它来转化成EditableColPrivate strRequiredCol As String '必填列，如"01/03/10"，数据库中自动编号不能设置Private strRequiredField As String '必填字段，根据它来转化成strRequiredColPrivate sngPixelPerPoint As Double '每像素的磅数，窗体初始化时计算一次即可Private intCol As Integer '记录ListView第几列被点击，Listview标题索引从1开始Private blnFlag As Boolean '按下Escape键时，指示InkEdit1_Exit事件不保存修改'Private blnNewItem As Boolean '新增一行标识符。如果新增行未保存或未删除，该标识为TRUEPrivate strOriginal As String '记录每次显示InkEdit时的原始值，用于其退出时的比较Private arrData As Variant '数据数组，如果连接数据库，请使用ADO的Recordset对象Dim p As LongDim SortType As IntegerDim iTotal As DoubleDim DicMonthDim aData()Dim iRowDim iColDim tbTitle(), sTbtitle()Dim arrStr() As StringDim ItemStr As StringDim ModifyStatus As Integer '修改状态，点Dim DeleteStatus As Integer '删除状态，记录是否有删除动作Dim arrModifyCode() '修改的科目代码Dim arrModifyItems()Dim arrOldItems(), arrNewItems()Dim LvItem As ListItemDim arrWidth()Dim arr(), arrType() 'Usf_Interm 中组合框数据源Dim preDate As DateDim preColorDim preNumber As IntegerDim intRow As Integer 'selecteditems的行号'Dim AccCode As String, AccName As StringDim CheckBoxStatus As BooleanDim strDeletedId As StringDim strDeletedAccCode As StringDim initSQL As String 'listview初始化数据的sql,在保存后再调用重新加载数据Dim strModifiedID As StringDim 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 MeEnd SubPrivateSubAddNewItem(OptionalByValAddPosAsString="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 ThenIDX = 1 ElseIDX = 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") ThenIf .ColumnHeaders(i) <> "ID" Then EditableCol = EditableCol & Format(i, "00") & "/"End If ElseIf InStr(EditableField, "Except") ThenIf .ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 Then EditableCol = EditableCol & Format(i, "00") & "/"End If ElseIf 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 + 1End SubPrivate Sub CmdAddNew_Click() Call AddNewItem("after")End SubPrivate 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凭证" ThenMe.Width = lvWidth + 20 + 20 ElseMe.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 SubPrivate Sub CmdCopyRecord_Click() Call AddNewItem("after") For j = 1 To LvDetail.ColumnHeaders.Count - 1 LvItem.SubItems(j) = Me.LvDetail.SelectedItem.SubItems(j) NextEnd SubPrivate 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 SubPrivate 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 IfEnd SubPrivate 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 ThenIf .ListItems(i).Text <> "" Then '把删除的id记录下来 strDeletedId = strDeletedId & Me.LvDetail.ListItems(i).Text & "/"End Ifs = 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 SubPrivate 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 + HEnd SubPrivate Sub CmdNumberDown_Click() If VoucherProcType = "凭证修改" Then Exit Sub Me.TxbNumber = IIf(Me.TxbNumber - 1 > 0, Me.TxbNumber - 1, 1) End SubPrivate Sub CmdNumberUp_Click()If VoucherProcType = "凭证修改" Then Exit Sub Me.TxbNumber = IIf(Me.TxbNumber + 1 < 999, Me.TxbNumber + 1, 999)End SubPrivate 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 = TrueEnd SubPrivate 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 = "" ThenFor 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 IfNext 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 = "凭证制单" ThenMsgBox "成功保存凭证【" & Me.TxbNumber & "】号！", , Me.LbTitle ElseIf VoucherProcType = "凭证修改" ThenMsgBox "成功修改凭证【" & 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_InitializeEnd SubPrivate 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 iColLvItem.SubItems(j) = aData(j, i) Next End If searchStr = "" NextEnd SubPrivate Sub CmdVoucherCopy_Click() Usf_VoucherList.ShowEnd SubPrivate Sub CmdVoucherProcess_Click() If VoucherProcType = "凭证制单" Then VoucherProcType = "凭证修改" Else VoucherProcType = "凭证制单" End If Unload Me Usf_AddAndModify.Show End SubPrivate 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.TextEnd With.Show End With End If If currTable = "tb基础信息" Then '基础设置 ElseIf currTable = "tb用户" Then '用户管理 If .ColumnHeaders(intCol) = "权限" ThenWith 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 .ShowEnd With End If End If End WithEnd SubPrivate Sub LbTopDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Me.TxbDate = "" Then Exit Sub preDate = CDate(Me.TxbDate) Usf_ChangeDate.Show End SubPrivate Sub LbTopModify_Click()If Me.TxbDate = "" Then Exit SubUsf_ChangeDate.ShowEnd SubPrivate 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 'StopEnd SubPrivate 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") ThenIf .ColumnHeaders(i) <> "ID" Then EditableCol = EditableCol & Format(i, "00") & "/"End If ElseIf InStr(EditableField, "Except") ThenIf .ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 Then EditableCol = EditableCol & Format(i, "00") & "/"End If ElseIf 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 IfEnd SubPrivate 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 SubPrivate 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 / 2End SubPrivate 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") ThenIf .ColumnHeaders(i) <> "ID" Then EditableCol = EditableCol & Format(i, "00") & "/"End If ElseIf InStr(EditableField, "Except") ThenIf .ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 Then EditableCol = EditableCol & Format(i, "00") & "/"End If ElseIf 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") ThenIf .ColumnHeaders(i) <> "ID" And InStr(strRequiredField, .ColumnHeaders(i)) = 0 Then strRequiredCol = strRequiredCol & Format(i, "00") & "/"End If ElseIf 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 iColLvItem.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 IfElse LvItem.ListSubItems(j).ForeColor = ForeColorEnd 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 = TrueEnd 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) = "贷方金额" ThenIf 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 ThenIf lngItemIndex < lngItemCount Then Set .SelectedItem = .ListItems(lngItemIndex + 1) intCol = 2Else Set LvItem = .ListItems.Add Set .SelectedItem = .ListItems(.ListItems.Count) intCol = 2 End If ElseSet .SelectedItem = .ListItems(lngItemIndex)intCol = intCol + 1 End If If InStr(EditableCol, Format(intCol, "00")) Then.SelectedItem.EnsureVisibleShowInkEdit End If

　　来源公众号： Case 37 '37=向左键头 .SetFocus '先触InkEdit1_Exit事件，此后Listview已获焦 If intCol > 1 ThenintCol = intCol - 1ShowInkEditForLRKey 37 End If Case 38 '38=向上键头 .SetFocus If lngItemIndex > 1 ThenSet .SelectedItem = .ListItems(lngItemIndex - 1).SelectedItem.EnsureVisibleShowInkEdit End If Case 39 '39=向右键头 .SetFocus If intCol < lngColCount ThenintCol = intCol + 1ShowInkEditForLRKey 39 End If Case 40 '40=向下箭头 .SetFocus If lngItemIndex < lngItemCount ThenSet .SelectedItem = .ListItems(lngItemIndex + 1).SelectedItem.EnsureVisibleShowInkEdit End If Case 27 '27 = Esc键，取消修改 If intStrikeTimes = 2 Then '按2次Esc键,并且两次按键时间小于2秒，才退出inkedit,在输入法中会用Esc取消输入If currIntervals < 0.8 Then blnFlag = False .SetFocus intStrikeTimes = 0End If End If Case Else End Select End WithEnd 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 / DPIxEnd 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 WithEnd Sub'InkEdit控件退出时的处理程序,将修改内容同步到ListviewPrivate 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")) ThenIf Len(InkEdit1.Text) = 0 Then MsgBox "该项为必填项，修改已被取消！", vbCritical InkEdit1.Width = 0: Exit SubEnd 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 IfElse '对应 类似 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 ThenIf InStr(strModifiedID, "/" & myID & "/") = 0 Then strModifiedID = strModifiedID & "/" & myID & "/"End If End If '**********将生产涉及修改的其他核算项目记录的ID写入数组保存*********** End If End With InkEdit1.Width = 0End SubPrivate 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 ThenlngScrollAmount = CLng((sngNewInkLeft - (.Left + 1.5)) / sngPixelPerPoint) '滚动量，单位像素SendMessageLong .hwnd, LVM_SCROLL, lngScrollAmount, 0 '拖动Listview水平滚动条，保持InkEdit可见InkEdit1.Left = .Left + 1.5 ElseInkEdit1.Left = sngNewInkLeft End If Else '向右 sngNewInkLeft = InkEdit1.Left + .ColumnHeaders(intCol - 1).Width If sngNewInkLeft + .ColumnHeaders(intCol).Width > .Left + .Width ThenlngScrollAmount = CLng((sngNewInkLeft + .ColumnHeaders(intCol).Width - (.Left + .Width)) / sngPixelPerPoint)SendMessageLong .hwnd, LVM_SCROLL, lngScrollAmount, 0InkEdit1.Left = .Left + .Width - .ColumnHeaders(intCol).Width ElseInkEdit1.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 WithEnd 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 WithEnd Sub'关闭窗体时，还原Listview和InkEdit控件的窗口程序,在退出窗体时调用Private Sub RestoreAPI() SetWindowLong LvDetail.hwnd, GWL_WNDPROC, LvmPreWndProc SetWindowLong InkEdit1.hwnd, GWL_WNDPROC, InkPreWndProcEnd Sub'***************************↑使得ListView可编辑相关代码↑*********************************Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then '检测关闭模式是否为点击窗口右上角的 X Cancel = True '取消关闭事件 End IfEnd Sub

　　

　　☆猜你喜欢☆

Excel VBA 这样酷炫的日期控件，你不想要吗？	Excel 公式函数/数据透视表/固定资产折旧计提表！
Excel VBA 自定义函数/数组字段定位/数组字段排序	Excel 功能/公式函数/VBA/多种姿势处理重复值
Excel VBA 最简单的收发存登记系统	Excel 公式函数/查找函数之LOOKUP
Excel VBA 文件批量改名	Excel 公式函数/数据验证/动态下拉列表
Excel VBA 输入逐步提示/TextBox+ListBox	Excel 基础功能【数据验证】，你会怎么用？

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