|
☆本期内容概要☆
由于是从别的应用中复制过来的用户窗体，有部分代码没有删除干净，待后续调整，目前仅有限测试通过。 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 |
|
|
