VB中如何修改窗体运行顺序（vb立即窗口怎么使用）

本文于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 LongPtrPrivateDeclare PtrSafe Function GetScrollPos Lib "user32" (ByVal hwnd As LongPtr, ByVal nBar As LongPtr) As LongPtrPrivateDeclare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPrivateDeclare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivateDeclare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As LongPtrPrivateConst LVM_FIRST = &H1000PrivateConst LVM_SCROLL = (LVM_FIRST + 20)PrivateConst SB_HORZ = 0PrivateConst LOGPIXELSX = 88PrivateEditableCol As String 窗体初始化时指定可以编辑的列号，如"01/03/10"PrivateEditableField As String 可编辑表头字段，根据它来转化成EditableColPrivatestrRequiredCol As String 必填列，如"01/03/10"，数据库中自动编号不能设置PrivatestrRequiredField As String 必填字段，根据它来转化成strRequiredColPrivatesngPixelPerPoint As Double 每像素的磅数，窗体初始化时计算一次即可PrivateintCol As Integer 记录ListView第几列被点击，Listview标题索引从1开始PrivateblnFlag As Boolean 按下Escape键时，指示InkEdit1_Exit事件不保存修改PrivateblnNewItem As Boolean 新增一行标识符。如果新增行未保存或未删除，该标识为TRUEPrivatestrOriginal As String 记录每次显示InkEdit时的原始值，用于其退出时的比较PrivatearrData As Variant 数据数组，如果连接数据库，请使用ADO的Recordset对象Dimp As LongDimSortType As IntegerDimiTotal As DoubleDimDicMonthDimaData()DimiRowDimiColDimtbTitle(), sTbtitle()DimarrStr() As StringDimItemStr As StringDimModifyStatus As Integer 修改状态，点DimDeleteStatus As Integer 删除状态，记录是否有删除动作DimarrModifyCode() 修改的科目代码DimarrModifyItems()DimarrOldItems(), arrNewItems()DimLvItem As ListItemDimarrWidth()Dimarr(), arrType() Usf_Interm 中组合框数据源DimpreDate As DateDimpreColorDimpreNumber As IntegerDimintRow As Integer selecteditems的行号DimAccCode As String, AccName As StringDimCheckBoxStatus As BooleanDimstrDeletedId As StringDimstrDeletedAccCode As StringDiminitSQL As String listview初始化数据的sql,在保存后再调用重新加载数据DimstrModifiedID As StringDimintStrikeTimes As Integer 记录Esc键的按键次数DimlastEscapeTime As Single 记录第一次按下ESC的时间PrivateSub Cmd_Exit_Click()IfModifyStatus > 0 Or DeleteStatus > 0 ThenIfNot wContinue("所有未保存的操作将丢失！") Then Exit SubEndIfCallRestoreAPIModifyStatus=0DeleteStatus=0UnloadMeEndSubPrivate Sub AddNewItem(Optional ByVal AddPos As String="end")DimIDX As IntegerIfShiftKeyPressed ThenIfAddPos = "before" ThenAddPos="after"ElseIfAddPos = "after" ThenAddPos="before"EndIfEndIfIfMe.LvDetail.ListItems.Count = 0 ThenIDX=1ElseIfAddPos = "end" ThenIDX=Me.LvDetail.ListItems.Count + 1ElseIfAddPos = "top" ThenIDX=1ElseIfAddPos = "before" ThenIfMe.LvDetail.SelectedItem.index = 1 ThenIDX=1ElseIDX=Me.LvDetail.SelectedItem.index - 1EndIfElseIfAddPos = "after" ThenIDX=Me.LvDetail.SelectedItem.index + 1ElseIDX=Me.LvDetail.ListItems.Count + 1EndIfEndIf根据指定字段转化可编辑列、必填列WithMe.LvDetailFori = 1 To .ColumnHeaders.CountIfInStr(EditableField, "All") ThenIf.ColumnHeaders(i) <> "ID" ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfElseIfInStr(EditableField, "Except") ThenIf.ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfElseIfInStr(EditableField, .ColumnHeaders(i)) ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfEndIfNextEndWithStopWithMe.LvDetailSetLvItem = .ListItems.Add(IDX, , "")IfcurrTable = "tb凭证" ThenLvItem.SubItems(7)=0: LvItem.SubItems(8) = 0LvItem.SubItems(3)=.ListItems(.ListItems.Count - 1).SubItems(3)ElseIfcurrTable = "tb期初余额" ThenLvItem.SubItems(1)=CDate(currYear & "/1/1")LvItem.SubItems(2)="期初余额"LvItem.SubItems(7)=0EndIf.ListItems(IDX).EnsureVisibleEndWithModifyStatus=ModifyStatus + 1EndSubPrivateSub CmdAddNew_Click()CallAddNewItem("after")EndSubPrivateSub CmdChangeColWidth_Click()DimlvWidth As DoubleIfMe.CmdChangeColWidth.Caption = "解冻列宽" ThenMe.FrmHeader.Visible=FalseMe.LvDetail.HideColumnHeaders=FalseMe.LvDetail.Top=Me.FrmHeader.TopMe.CmdChangeColWidth.Caption="固定列宽"ElseIfMe.CmdChangeColWidth.Caption = "固定列宽" ThenMe.FrmHeader.Visible=TrueWithMe.LvDetailFori = 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=lvWidthIfcurrTable = "tb凭证" ThenMe.Width=lvWidth + 20 + 20ElseMe.Width=lvWidth + 20EndIfEndWithMe.CmdChangeColWidth.Caption="解冻列宽"Me.CmdChangeColWidth.Left=Me.LvDetail.Left + Me.LvDetail.Width - Me.CmdChangeColWidth.WidthMe.CmdChangeWidth.Left=Me.CmdChangeColWidth.Left - Me.CmdChangeWidth.Width - 2Me.Frame3.Left=Me.LvDetail.Left + Me.LvDetail.Width - Me.Frame3.WidthEndIfEndSubPrivateSub CmdCopyRecord_Click()CallAddNewItem("after")Forj = 1 To LvDetail.ColumnHeaders.Count - 1LvItem.SubItems(j)=Me.LvDetail.SelectedItem.SubItems(j)NextEndSubPrivateSub CmdDateDown_Click()DimtemDateIfMe.TxbDate = "" Then Exit SubpreMonth=Month(CDate(Me.TxbDate))temDate=CDate(Me.TxbDate) - 1IfVoucherProcType = "凭证修改" ThenIfMonth(temDate) <> preMonth ThenMe.TxbDate=temDate + 1ElseMe.TxbDate=temDateEndIfElseIfYear(temDate) < Val(currYear) ThenMe.TxbDate=CDate(currYear & "/1/1")ElseMe.TxbDate=temDateEndIfEndIfEndSubPrivateSub CmdDateUp_Click()DimtemDateIfMe.TxbDate = "" Then Exit SubpreMonth=Month(CDate(Me.TxbDate))temDate=CDate(Me.TxbDate) + 1IfVoucherProcType = "凭证修改" ThenIfMonth(temDate) <> preMonth ThenMe.TxbDate=temDate - 1ElseMe.TxbDate=temDateEndIfElseIfYear(temDate) > Val(currYear) ThenMe.TxbDate=CDate(currYear & "/12/31")ElseMe.TxbDate=temDateEndIfEndIfEndSubPrivateSub CmdDelete_Click()DimAccountCode As StringDimAccTypeCode As StringDimItemName As StringDimItemTypeCode As StringDimUserName As StringDimarr()strDeletedId=""strDeletedAccCode=""WithLvDetailFori = 1 To .ListItems.CountIf.ListItems(i).Checked = True ThenIf.ListItems(i).Text <> "" Then把删除的id记录下来strDeletedId=strDeletedId & Me.LvDetail.ListItems(i).Text & "/"EndIfs=s + 1EndIfNextEndWithIfs = 0 ThenMsgBox"请钩选想要删除的记录！"ExitSubEndIfStopWithMe.LvDetailFori = .ListItems.Count To 1 Step -1If.ListItems(i).Checked = True Then.ListItems.Remove(i)EndIfNextEndWithDeleteStatus=DeleteStatus + 1StopEndSubPrivateSub CmdIncreaseHeight_Click()DimH As IntegerIfShiftKeyPressed ThenMe.CmdIncreaseHeight.Caption="减高"Me.CmdIncreaseHeight.ForeColor=vbBlackH=-20ElseMe.CmdIncreaseHeight.Caption="增高"Me.CmdIncreaseHeight.ForeColor=&HFF00FFH=20EndIfMe.Height=Me.Height + HMe.LvDetail.Height=Me.LvDetail.Height + HMe.Frame3.Top=Me.Frame3.Top + HEndSubPrivateSub CmdNumberDown_Click()IfVoucherProcType = "凭证修改" Then Exit SubMe.TxbNumber=IIf(Me.TxbNumber - 1 > 0, Me.TxbNumber - 1, 1)EndSubPrivateSub CmdNumberUp_Click()IfVoucherProcType = "凭证修改" Then Exit SubMe.TxbNumber=IIf(Me.TxbNumber + 1 < 999, Me.TxbNumber + 1, 999)EndSubPrivateSub CmdOutPut_Click()IfNot wContinue("即将导出！") Then Exit SubOnError Resume NextDimarrT()DimiPath As String, iYear As StringDimiSheet As WorksheetIfMe.CkB_ChoseFolder.Value = True TheniPath=PathSelected & "\"ElseiPath=ThisWorkbook.Path & "\"EndIffName=Me.LbTitle & Format(VBA.Now, "YYYYMMDDhhmmss") & ".xlsx"Application.DisplayAlerts=FalseiRow=Me.LvDetail.ListItems.Count + 1iCol=Me.LvDetail.ColumnHeaders.CountReDimarrT(1 To iRow, 1 To iCol)Fori = 1 To iColarrT(1,i) = Me.LvDetail.ColumnHeaders(i)NextFori = 2 To iRowarrT(i,1) = Me.LvDetail.ListItems(i - 1).TextForj = 2 To iColarrT(i,j) = Me.LvDetail.ListItems(i - 1).SubItems(j - 1)NextNextWorkbooks.AddActiveWorkbook.Sheets(1).Range("A1").Resize(iRow,iCol) = arrTActiveWorkbook.SaveAsFilename:=iPath & fNameActiveWorkbook.CloseMsgBox("成功导出文件" & iPath & fName)UnloadMeApplication.DisplayAlerts=TrueEndSubPrivateSub CmdSave_Click()DimarrTable()DimLvItem As ListItemDimNullCount As IntegerDimarrID() As String 先不确定数据类型，用来存放split(strdeletedid)DimarrAccCode() As StringOnError Resume NextIfCmdChangeColWidth.Caption = "固定列宽" ThenCallCmdChangeColWidth_ClickEndIfIfModifyStatus = 0 And DeleteStatus = 0 ThenMsgBox"数据无任何修改，无需保存！"ExitSubEndIf检查数据完整性、准确性↓↓↓↓↓↓↓↓↓↓↓↓↓↓1、检查必填项是否为空WithMe.LvDetailFori = 1 To .ListItems.CountIf.ListItems(i).Text = "" ThenForj = 2 To .ColumnHeaders.CountIfInStr(strRequiredCol, Format(j, "00")) ThenIf.ListItems(i).SubItems(j - 1) = "" ThenMsgBox"第【" & j & "】列【" & .ColumnHeaders(j) & "】不能为空！"StopExitSubEndIfEndIfNextElseEndIfNextEndWith检查数据完整性、准确性↑↑↑↑↑↑↑↑↑↑↑↑↑↑删除记录IfLen(Replace(strDeletedId, "/", "")) > 0 ThenStopstrDeletedId=Left(strDeletedId, Len(strDeletedId) - 1)arrID=Split(strDeletedId, "/")IfNot wContinue("即将删除以下ID的记录：" & Chr(10) & strDeletedId & Chr(10) & "此操作不可恢复，请谨慎执行！") Then Exit SubSQL="delete * from " & currTable & " where id in (" & Join(arrID, ",") & ")"CallExecuteSQL(dataFile, SQL)EndIf增加、修改记录，建立数据连接Setcnn = CreateObject("ADODB.Connection")Setrs = CreateObject("ADODB.Recordset")passWord="p111111"StrCnn=GetStrCnn(dataFile, passWord)cnn.OpenStrCnnrs.OpencurrTable, cnn, 1, 3WithMe.LvDetailFori = 1 To .ListItems.CountIfLen(Trim(.ListItems(i).Text)) > 0 Then 对id不为空的记录，即可能被修改的记录进行操作IfInStr(strModifiedID, .ListItems(i).Text) Then 判断存放id的数组是否为空值，如果为空，则表明没有修改的记录，不用执行更新rs.movefirstDoUntil rs.EOFIfrs!ID = .ListItems(i).Text Thenrs.EditFork = 1 To .ColumnHeaders.Count - 1数据库中是/否字段值为-1/0，但显示为true/falsers.Fields(k)=IIf(.ListItems(i).SubItems(k) = "true", -1, IIf(.ListItems(i).SubItems(k) = "false", 0, .ListItems(i).SubItems(k)))Nextrs.UpdateEndIfrs.MoveNextLoopEndIfElse对id为空的记录，即新增的记录进行操作，向数据库写入记录rs.AddNewFork = 1 To .ColumnHeaders.Count - 1rs.Fields(k)=IIf(.ListItems(i).SubItems(k) = "true", -1, IIf(.ListItems(i).SubItems(k) = "false", 0, .ListItems(i).SubItems(k)))Nextrs.UpdateEndIfNextEndWithrs.Closecnn.CloseSetrs = NothingSetcnn = NothingIfcurrTable = "tb凭证" ThenIfVoucherProcType = "凭证制单" ThenMsgBox"成功保存凭证【" & Me.TxbNumber & "】号！", , Me.LbTitleElseIfVoucherProcType = "凭证修改" ThenMsgBox"成功修改凭证【" & Me.TxbNumber & "】号！", , Me.LbTitleEndIfElseMsgBox"保存成功！", , Me.LbTitleEndIfModifyStatus=0strDeletedId=""DeleteStatus=0Me.LvDetail.ColumnHeaders.ClearMe.LvDetail.ListItems.ClearCallUserForm_InitializeEndSubPrivateSub CmdSearch_Click()OnError Resume NextMe.LvDetail.ListItems.CleariTotal=0DimsearchStr As StringDimLvItem As ListItemiRow=UBound(aData, 2)iCol=UBound(aData, 1)Fori = 0 To iRowForj = 0 To iColsearchStr=searchStr & "|" & aData(j, i)NextIfInStr(1, searchStr, Me.TextBox1.Value, 1) ThenSetLvItem = Me.LvDetail.ListItems.AddLvItem.Text=aData(0, i)Forj = 1 To iColLvItem.SubItems(j)=aData(j, i)NextEndIfsearchStr=""NextEndSubPrivateSub CmdVoucherCopy_Click()Usf_VoucherList.ShowEndSubPrivateSub CmdVoucherProcess_Click()IfVoucherProcType = "凭证制单" ThenVoucherProcType="凭证修改"ElseVoucherProcType="凭证制单"EndIfUnloadMeUsf_AddAndModify.ShowEndSubPrivateSub InkEdit1_DblClick()DimcurrID As StringOnError Resume NextWithMe.LvDetail共同选项If.ColumnHeaders(intCol) = "使用状态" Or .ColumnHeaders(intCol) = "状态" ThenWithUsf_Interm.Caption="选择【使用状态】"arrType=Array("正常", "封存")WithUsf_Interm.CmbInterm.Clear.List=arrType.Text=Me.InkEdit1.TextEndWith.ShowEndWithEndIfIfcurrTable = "tb基础信息" Then 基础设置ElseIfcurrTable = "tb用户" Then 用户管理If.ColumnHeaders(intCol) = "权限" ThenWithUsf_Interm.Caption="选择【权限】"选择用户权限SQL="select distinct 权限 from tb用户权限"arrType=GetData(dataFile, SQL)WithUsf_Interm.CmbInterm.ClearFori = 0 To UBound(arrType, 2).AddItemarrType(0, i)Next.Text=Me.InkEdit1.TextEndWith.ShowEndWithEndIfEndIfEndWithEndSubPrivateSub LbTopDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)IfMe.TxbDate = "" Then Exit SubpreDate=CDate(Me.TxbDate)Usf_ChangeDate.ShowEndSubPrivateSub LbTopModify_Click()IfMe.TxbDate = "" Then Exit SubUsf_ChangeDate.ShowEndSubPrivateSub TxbDate_Change()IfVoucherProcType = "凭证修改" Then Exit SubiMonth=Format(Me.TxbDate, "YYYYMM")IfFormat(preDate, "YYYYMM") = iMonth Then Exit SubSQL="select count(*) from tb凭证 where 月份=" & iMonth & ""n=RecordValue(dataFile, SQL)Ifn > 0 ThenSQL="select top 1 凭证号 from tb凭证 where 月份=" & iMonth & " order by 分录号 DESC"preNumber=RecordValue(dataFile, SQL)Me.TxbNumber=preNumber + 1ElseMe.TxbNumber=1EndIfStopEndSubPrivateSub LvDetail_Click()IfcurrTable = "tb用户" ThenEditableField="All"EndIfEditableCol=""WithMe.LvDetailFori = 1 To .ColumnHeaders.CountIfInStr(EditableField, "All") ThenIf.ColumnHeaders(i) <> "ID" ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfElseIfInStr(EditableField, "Except") ThenIf.ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfElseIfInStr(EditableField, .ColumnHeaders(i)) ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfEndIfNextEndWithIfInStr(EditableCol, Format(intCol, "00")) ThenCallShowInkEditEndIfEndSubPrivateSub TxbNumber_Change()IfVoucherProcType = "凭证修改" Then Exit SubMe.TxbNumber=Left(Me.TxbNumber, 3)Me.TxbNumber=IIf(Val(Me.TxbNumber) = 0, 1, Val(Me.TxbNumber))EndSubPrivateSub CmdChangeWidth_Click()WithMe.LvDetailFori = 1 To .ColumnHeaders.CountW=W + .ColumnHeaders(i).WidthNext.Width=WIfcurrTable = "tb凭证" ThenMe.Width=.Width + 20 + 15ElseMe.Width=.Width + 20EndIfW=0EndWithMe.CmdChangeColWidth.Left=Me.LvDetail.Left + Me.LvDetail.Width - Me.CmdChangeColWidth.WidthMe.CmdChangeWidth.Left=Me.CmdChangeColWidth.Left - Me.CmdChangeWidth.Width - 2Me.Frame3.Left=Me.LvDetail.Left + Me.LvDetail.Width - Me.Frame3.WidthMe.LbTitle.Left=Me.Width / 2 - Me.LbTitle.Width / 2EndSubPrivateSub UserForm_Initialize()dataFile=ThisWorkbook.Path & "\收费管理系统数据库.accdb"currTable="tb用户"DimItemTypeCode As StringDimlbCtrl As ControlIfdataFile = "" ThenMsgBox"数据库文件路径异常，请重新登录！"ExitSubEndIfStopOnError Resume NextSQL语句,列宽，指定可编辑列，必填列的字段名称,标题IfcurrTable = "tb用户" ThenStopinitSQL="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"ElseinitSQL="select * from " & currTablearrWidth=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"EndIfStop删除动态添加的标签ForEach lbCtrl In Me.FrmHeader.ControlsIflbCtrl.Name Like "topLb_*" Then Controls.Remove lbCtrl.NameNextStop添加表头字段，以及标签遮盖层Me.Frame1.Top=Me.LbTitle.Top + Me.LbTitle.Height + 5tbTitle=GetFields(dataFile, initSQL)Fori = 0 To UBound(tbTitle, 1)WithMe.LvDetailIfi = 0 Then.ColumnHeaders.Add, , tbTitle(i), arrWidth(i)ElseIfInStr(tbTitle(i), "金额") Or InStr(tbTitle(i), "余额") Then.ColumnHeaders.Add, , tbTitle(i), arrWidth(i), lvwColumnRightElse.ColumnHeaders.Add, , tbTitle(i), arrWidth(i)EndIfEndWithSetlbCtrl = Me.FrmHeader.Controls.Add("Forms.Label.1", "topLb_" & i, True)Ifi = 0 Theniwidth=0Elseiwidth=iwidth + arrWidth(i - 1)EndIfWithlbCtrl.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)EndWithNextlistview控件的显示外观WithMe.LvDetail.View=lvwReport.Gridlines=True.Sorted=True.CheckBoxes=True.LabelEdit=lvwManual.FullRowSelect=True.ForeColor=vbBlue设置窗体、listview的宽度Fori = 1 To .ColumnHeaders.CountW=W + .ColumnHeaders(i).WidthNext.Width=WEndWithStop根据指定字段转化可编辑列、必填列WithMe.LvDetailFori = 1 To .ColumnHeaders.CountIfInStr(EditableField, "All") ThenIf.ColumnHeaders(i) <> "ID" ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfElseIfInStr(EditableField, "Except") ThenIf.ColumnHeaders(i) <> "ID" And InStr(EditableField, .ColumnHeaders(i)) = 0 ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfElseIfInStr(EditableField, .ColumnHeaders(i)) ThenEditableCol=EditableCol & Format(i, "00") & "/"EndIfEndIfIfInStr(strRequiredField, "All") Then 如果是所有列都必填，第一列ID也是不需要且不能编辑的If.ColumnHeaders(i) <> "ID" ThenstrRequiredCol=strRequiredCol & Format(i, "00") & "/"EndIfElseIfInStr(strRequiredField, "Except") ThenIf.ColumnHeaders(i) <> "ID" And InStr(strRequiredField, .ColumnHeaders(i)) = 0 ThenstrRequiredCol=strRequiredCol & Format(i, "00") & "/"EndIfElseIfInStr(strRequiredField, .ColumnHeaders(i)) ThenstrRequiredCol=strRequiredCol & Format(i, "00") & "/"EndIfEndIfNextEndWithStopIfcurrTable = "tb凭证" ThenReDimaData(0 To UBound(tbTitle, 1) - 1, 0 To 5)把金额预填0Fori = 0 To UBound(aData, 2)aData(Pxy(tbTitle,"借方金额") - 1, i) = Format(0, "Standard")aData(Pxy(tbTitle,"贷方金额") - 1, i) = Format(0, "Standard")NextElseIfRecordValue(dataFile, "select count(*) from " & currTable) > 0 ThenaData=GetData(dataFile, initSQL)EndIfEndIfStop添加明细数据到listviewIfNot IsArrEmpty(aData) TheniRow=UBound(aData, 2)iCol=UBound(aData, 1)Me.LvDetail.ListItems.ClearFori = 0 To iRowSetLvItem = Me.LvDetail.ListItems.AddLvItem.Text=aData(0, i)ForeColor=IIf(LvItem.index Mod 2, vbBlack, RGB(102, 102, 153))LvItem.ForeColor=ForeColorForj = 1 To iColLvItem.SubItems(j)=aData(j, i)IfInStr(EditableCol, Format(j + 1, "00")) ThenIfLvItem.index Mod 2 ThenLvItem.ListSubItems(j).ForeColor=RGB(0, 128, 128)ElseLvItem.ListSubItems(j).ForeColor=RGB(51, 204, 204)EndIfElseLvItem.ListSubItems(j).ForeColor=ForeColorEndIfNextNextEndIf调整控件位置、窗体大小等WithMe.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.WidthEndWith对于数据行比较少的表来说，统一的listview控件高度会有很多空行，不太美观，对少于20行的表进行动态调整显示n=Me.LvDetail.ListItems.CountIfn < 20 ThenIfn < 6 ThenMe.LvDetail.Height=6 * Me.LvDetail.ListItems(n).Height + 20ElseMe.LvDetail.Height=(n + 1) * Me.LvDetail.ListItems(n).Height + 20EndIfElseMe.LvDetail.Height=(20 + 1) * Me.LvDetail.ListItems(n).Height + 20EndIfStopWithFrmHeader 表头替代字段，防止Listview表头拖动变化。.Visible=True.Top=Me.Frame1.Top + Me.Frame1.Height.Left=Me.LvDetail.Left.Width=Me.LvDetail.Width.Height=19.Caption=""EndWithWithMe.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 - 2EndWithMe.Caption="【模块：" & Me.LbTitle & "】" _&"】【用户：" & currUserName & "】"单独对凭证的显示按钮进行定义Me.Frame3.BackColor=Me.BackColor***************************↓使得ListView可编辑相关代码↓*********************************preColor=RGB(0, 255, 255)InkEdit1.BackColor=preColorInkEdit1.Font.size=Me.LvDetail.Font.sizeInkEdit1.Width=0InkEdit1.MultiLine=FalseInkEdit1.ZOrder0 把InkEdit1移到最上一层，避免被Listview遮住sngPixelPerPoint=Pixel2PointXblnFlag=True 指示InkEdit1_Exit事件是否保存修改。按下Escape键时设为FalseLvmPreWndProc=GetWindowLong(Me.LvDetail.hwnd, GWL_WNDPROC)InkPreWndProc=GetWindowLong(InkEdit1.hwnd, GWL_WNDPROC)SetWindowLongLvDetail.hwnd, GWL_WNDPROC, AddressOf WndProcSetWindowLongInkEdit1.hwnd, GWL_WNDPROC, AddressOf WndProc***************************↑使得ListView可编辑相关代码↑*********************************EndSub***************************↓使得ListView可编辑相关代码↓*********************************InkEdit失去焦点时即可发生Exit事件InkEdit退出事件。退出时需要指定是否保存修改内容。PrivateSub InkEdit1_Exit(ByVal Cancel As MSForms.ReturnBoolean)HideInkEditblnFlagblnFlag=TrueEndSubInkEdit控件的按键处理程序PrivateSub InkEdit1_KeyUp(pKey As Long, ByVal ShiftKey As Integer)DimlngItemIndex As LongDimlngColCount As LongDimlngItemCount As LongDimLvItem As ListItemDimcurrIntervals As SingleIfpKey = 27 ThenintStrikeTimes=intStrikeTimes + 1IfintStrikeTimes = 1 ThenlastEscapeTime=TimerElseIfintStrikeTimes = 2 ThencurrIntervals=Timer - lastEscapeTimeElseintStrikeTimes=0EndIfEndIfWithLvDetaillngItemIndex=.SelectedItem.indexlngColCount=.ColumnHeaders.CountlngItemCount=.ListItems.CountblnFlag=True 原来是放到每一个Case分支里的，这里只是有一条分支是False值SelectCase pKeyCase13 13=回车键.SetFocusIf.ColumnHeaders(intCol) = "贷方金额" ThenIflngItemIndex < lngItemCount ThenSet.SelectedItem = .ListItems(lngItemIndex + 1)intCol=4 摘要ElseSetLvItem = .ListItems.AddLvItem.SubItems(7)=0: LvItem.SubItems(8) = 0Set.SelectedItem = .ListItems(.ListItems.Count)intCol=4EndIfElseIfintCol = lngColCount ThenIflngItemIndex < lngItemCount ThenSet.SelectedItem = .ListItems(lngItemIndex + 1)intCol=2ElseSetLvItem = .ListItems.AddSet.SelectedItem = .ListItems(.ListItems.Count)intCol=2EndIfElseSet.SelectedItem = .ListItems(lngItemIndex)intCol=intCol + 1EndIfIfInStr(EditableCol, Format(intCol, "00")) Then.SelectedItem.EnsureVisibleShowInkEditEndIfCase37 37=向左键头.SetFocus先触InkEdit1_Exit事件，此后Listview已获焦IfintCol > 1 ThenintCol=intCol - 1ShowInkEditForLRKey37EndIfCase38 38=向上键头.SetFocusIflngItemIndex > 1 ThenSet.SelectedItem = .ListItems(lngItemIndex - 1).SelectedItem.EnsureVisibleShowInkEditEndIfCase39 39=向右键头.SetFocusIfintCol < lngColCount ThenintCol=intCol + 1ShowInkEditForLRKey39EndIfCase40 40=向下箭头.SetFocusIflngItemIndex < lngItemCount ThenSet.SelectedItem = .ListItems(lngItemIndex + 1).SelectedItem.EnsureVisibleShowInkEditEndIfCase27 27 = Esc键，取消修改IfintStrikeTimes = 2 Then 按2次Esc键,并且两次按键时间小于2秒，才退出inkedit,在输入法中会用Esc取消输入IfcurrIntervals < 0.8 ThenblnFlag=False.SetFocusintStrikeTimes=0EndIfEndIfCaseElseEndSelectEndWithEndSub把X方向的像素值转为磅。VBA窗体的度量单位是磅。像素和磅的转换跟屏幕密度有关，不同电脑可能不同值。PrivateFunction Pixel2PointX() As DoubleDimhDC As Long, DPIx As LonghDC=GetDC(0) 获取屏幕设备环境句柄DPIx=GetDeviceCaps(hDC, LOGPIXELSX) 获取屏幕X方向像素密度ReleaseDC0, hDC 释放屏幕设备环境Pixel2PointX=72 / DPIxEndFunction鼠标事件主要计算点击的列号。并可在此处鼠标按键条件，比如改为右键点击才计算列号，左键时列号置为零。这样InkEdit的显示程序就不会显示控件PrivateSub LvDetail_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)DimsngDiff As Double 单击鼠标，弹起时即可触发事件。可用Button判断点击的是鼠标三键中的哪一个，1=左，2=右，4=中DimsngScrollPos As DoubleDimsngMousePosX As DoubleWithLvDetailsngScrollPos=sngPixelPerPoint * GetScrollPos(.hwnd, SB_HORZ)sngMousePosX=sngPixelPerPoint * XForintCol = 1 To .ColumnHeaders.CountsngDiff=.ColumnHeaders(intCol).Left - sngScrollPosIfsngMousePosX > sngDiff And sngMousePosX < sngDiff + .ColumnHeaders(intCol).Width Then Exit ForNextIfintCol > .ColumnHeaders.Count Then intCol = 0 计算失败时，置为零EndWithEndSubInkEdit控件退出时的处理程序,将修改内容同步到ListviewPrivateSub HideInkEdit(Optional ByVal blnSave As Boolean = True)DimOldFullName$, NewFullName$DimmyID As Integer 当前修改的IDOnError Resume NextInkEdit1.BackColor=preColorWithLvDetailIf.SelectedItem Is Nothing Then Exit Sub 如果InkEdit1未失焦时就关闭窗体，必报错。必须加这一句。IfstrOriginal = InkEdit1.Text Then InkEdit1.Width = 0: Exit Sub InkEdit的值有改变时才执行后面语句，否则浪费时间IfLen(strRequiredCol) ThenIfInStr(strRequiredCol, Format(intCol, "00")) ThenIfLen(InkEdit1.Text) = 0 ThenMsgBox"该项为必填项，修改已被取消！", vbCriticalInkEdit1.Width=0: Exit SubEndIfEndIfEndIfIfblnSave ThenIfintCol > 1 Then1用户管理IfcurrTable = "tb用户" ThenIf.ColumnHeaders(intCol) = "用户ID" ThenIfRecordValue(dataFile, "select count(用户ID) From tb用户 where 用户ID=" & InkEdit1.Text & "") > 0 ThenMsgBox"已存在【" & InkEdit1.Text & "】用户ID不能重复！"Me.InkEdit1.Text=""ExitSubEndIfIfLen(InkEdit1.Text) < 4 ThenMsgBox"用户ID不能低于4位"InkEdit1.Text=""ExitSubEndIfElseIf.ColumnHeaders(intCol) = "姓名" ThenIfRecordValue(dataFile, "select count(姓名) From tb用户 where 姓名=" & InkEdit1.Text & "") > 0 ThenMsgBox"已存在【" & InkEdit1.Text & "】姓名不能重复！"Me.InkEdit1.Text=""ExitSubEndIfIfLen(InkEdit1.Text) < 2 ThenMsgBox"姓名至少2个字符"InkEdit1.Text=""ExitSubEndIfElseIf.ColumnHeaders(intCol) = "密码" ThenIfLen(InkEdit1.Text) < 6 ThenMsgBox"密码不能低于6位"InkEdit1.Text=""ExitSubEndIfEndIf.SelectedItem.SubItems(intCol- 1) = InkEdit1.TextIf.SelectedItem.Text = "" Then.SelectedItem.SubItems(Pxy(tbTitle,"状态") - 1) = "正常"EndIfElse对应 类似 ElseIf currtable="tb?" Then.SelectedItem.SubItems(intCol- 1) = InkEdit1.TextEndIfElse对应 if incol>1.SelectedItem.Text=InkEdit1.TextEndIfIf.SelectedItem.Text = "" Then.SelectedItem.ListSubItems(intCol- 1).ForeColor = vbBlue 新增的记录标蓝Else.SelectedItem.ListSubItems(intCol- 1).ForeColor = vbRed 修改的记录标红EndIfModifyStatus=ModifyStatus + 1将生产修改的记录的ID添加到strModifiedID中，两边用/隔开，做到精确匹配myID=Val(.SelectedItem.Text)IfmyID > 0 ThenIfInStr(strModifiedID, "/" & myID & "/") = 0 ThenstrModifiedID=strModifiedID & "/" & myID & "/"EndIfEndIf**********将生产涉及修改的其他核算项目记录的ID写入数组保存***********EndIfEndWithInkEdit1.Width=0EndSubPrivateSub tb报表项目Process()EndSub左右方向键处理程序。主要计算是水平滚动条的滚动量，以确保InkEdit可见PrivateSub ShowInkEditForLRKey(ByVal intKey As Integer)DimsngNewInkLeft As DoubleDimlngScrollAmount As LongDimblnInkLocked As BooleanWithLvDetailIfintCol = 0 Then Exit SubIf.SelectedItem Is Nothing Then Exit SubIfInStr(EditableCol, Format(intCol, "00")) = 0 Then Exit SubIfintCol > 1 ThenInkEdit1.Text=.SelectedItem.SubItems(intCol - 1)ElseInkEdit1.Text=.SelectedItem.TextEndIfIfintKey = 37 Then 向左sngNewInkLeft=InkEdit1.Left - .ColumnHeaders(intCol).WidthIfsngNewInkLeft < .Left + 1.5 ThenlngScrollAmount=CLng((sngNewInkLeft - (.Left + 1.5)) / sngPixelPerPoint) 滚动量，单位像素SendMessageLong.hwnd, LVM_SCROLL, lngScrollAmount, 0 拖动Listview水平滚动条，保持InkEdit可见InkEdit1.Left=.Left + 1.5ElseInkEdit1.Left=sngNewInkLeftEndIfElse向右sngNewInkLeft=InkEdit1.Left + .ColumnHeaders(intCol - 1).WidthIfsngNewInkLeft + .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).WidthElseInkEdit1.Left=sngNewInkLeftEndIfEndIfInkEdit1.Top=.Top + .SelectedItem.Top + 1.5InkEdit1.Width=.ColumnHeaders(intCol).WidthInkEdit1.Height=.SelectedItem.HeightIfLen(EditableCol) ThenblnInkLocked=(InStr(EditableCol, Format(intCol, "00")) = 0)ElseblnInkLocked=FalseEndIfInkEdit1.Locked=blnInkLockedInkEdit1.SelStart=0InkEdit1.SelLength=Len(InkEdit1.Text)strOriginal=InkEdit1.TextInkEdit1.SetFocusEndWithEndSub显示InkEdit控件的处理程序。需要显示InkEdit时调用PrivateSub ShowInkEdit()DimsngScrollPos As DoubleDimblnInkLocked As BooleanDimiItem As StringWithLvDetailIfintCol = 0 Then Exit Sub 点击的列号未计算成功If.SelectedItem Is Nothing Then Exit Sub Listview列表为空时退出sngScrollPos=sngPixelPerPoint * GetScrollPos(.hwnd, SB_HORZ)IfintCol > 1 ThenInkEdit1.Text=.SelectedItem.SubItems(intCol - 1)strOriginal=InkEdit1.TextintRow=.SelectedItem.indexElseInkEdit1.Text=.SelectedItem.TextEndIfInkEdit1.Left=.ColumnHeaders(intCol).Left + .Left + 1.5 - sngScrollPosInkEdit1.Top=.Top + .SelectedItem.Top + 1.5InkEdit1.Width=.ColumnHeaders(intCol).WidthInkEdit1.Height=.SelectedItem.HeightIfLen(EditableCol) ThenblnInkLocked=(InStr(EditableCol, Format(intCol, "00")) = 0)ElseblnInkLocked=FalseEndIfInkEdit1.Locked=blnInkLockedInkEdit1.SelStart=0InkEdit1.SelLength=Len(InkEdit1.Text)strOriginal=InkEdit1.Text 移到前面InkEdit1.SetFocusEndWithEndSub关闭窗体时，还原Listview和InkEdit控件的窗口程序,在退出窗体时调用PrivateSub RestoreAPI()SetWindowLongLvDetail.hwnd, GWL_WNDPROC, LvmPreWndProcSetWindowLongInkEdit1.hwnd, GWL_WNDPROC, InkPreWndProcEndSub***************************↑使得ListView可编辑相关代码↑*********************************PrivateSub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)IfCloseMode = vbFormControlMenu Then 检测关闭模式是否为点击窗口右上角的 XCancel=True 取消关闭事件EndIfEndSub

☆猜你喜欢☆

Excel VBA 这样酷炫的日期控件，你不想要吗？

Excel 公式函数/数据透视表/固定资产折旧计提表！

Excel VBA 自定义函数/数组字段定位/数组字段排序

Excel 功能/公式函数/VBA/多种姿势处理重复值

Excel VBA 最简单的收发存登记系统

Excel 公式函数/查找函数之LOOKUP

Excel VBA 文件批量改名

Excel 公式函数/数据验证/动态下拉列表

Excel VBA 输入逐步提示/TextBox+ListBox

Excel 基础功能【数据验证】，你会怎么用？

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