|
1、在工作表“查询”中，两个命令按钮点击事件，分别显示用户窗体或清除已有数据： Private Sub CmdQuery_Click() '//如果shData表没有数据，则退出 With shData If .UsedRange.Rows.Count = 1 Or .UsedRange.Columns.Count = 1 Then MsgBox "没有数据！" Exit Sub End If End With
UserForm1.ShowEnd Sub
Private Sub CmdClear_Click() Dim lastRow As Long lastRow = Cells(Rows.Count, 1).End(xlUp).Row If lastRow >= 3 Then Range(Cells(3, 1), Cells(lastRow, UsedRange.Columns.Count)).Clear End IfEnd Sub
2、在模块myModule中，Window窗口过程函数，确认继续函数： Option Explicit
'API 声明#If VBA7 Then Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr Public Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As LongPtr, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr#Else Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As long, ByVal nIndex As long) As long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As long, ByVal nIndex As long, ByVal dwNewLong As long) As long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As long, ByVal hwnd As long, ByVal Msg As long, _ ByVal wParam As long, ByVal lParam As long) As long
#End If
'常量定义Public Const WM_HSCROLL = &H114Public Const WM_VSCROLL = &H115Public Const WM_MOUSEWHEEL = &H20APublic Const GWL_WNDPROC = (-4)
'全局变量#If VBA7 Then Public LvmPreWndProc As LongPtr Public InkPreWndProc As LongPtr#Else Public LvmPreWndProc As Long Public InkPreWndProc As Long
#End IfPublic colIndex As Integer '当前列号Public tempValuePublic IsSheetDate As BooleanPublic inputType As StringPublic lastEmptyRow As Long '//shData表的最后第一个空白行，用于更新
'窗口过程函数#If VBA7 Then Public Function WndProc(ByVal hwnd As LongPtr, ByVal Msg As LongPtr, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr#Else Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long#End If With UserForm1 Select Case hwnd Case .LvDetail.hwnd If Msg = WM_VSCROLL Or Msg = WM_HSCROLL Then .LvDetail.SetFocus WndProc = CallWindowProc(LvmPreWndProc, hwnd, Msg, wParam, lParam) Case .InkEdit1.hwnd If Msg = WM_MOUSEWHEEL Then .LvDetail.SetFocus WndProc = CallWindowProc(InkPreWndProc, hwnd, Msg, wParam, lParam) End Select End WithEnd Function
Function wContinue(Msg As String) As Boolean '//确认继续函数 Dim Config As VbMsgBoxStyle Dim answer As VbMsgBoxResult Config = vbYesNo + vbQuestion + vbDefaultButton2 answer = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config) wContinue = (answer = vbYes)End Function
3、在用户窗体UserForm1中，实现Listview可编辑代码，以及各命令按钮点击事件代码等：Option Explicit#If VBA7 Then 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 Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hwnd As LongPtr) As LongPtr#Else Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As long, ByVal wMsg As long, ByVal wParam As long, ByVal lParam As long) As long Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As long, ByVal nBar As long) As long Private Declare Function GetDC Lib "user32" (ByVal hwnd As long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As long, ByVal hDC As long) As long Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwnd As Long) As Long#End If
Private Const LVM_FIRST = &H1000Private Const LVM_SCROLL = (LVM_FIRST + 20)Private Const SB_HORZ = 0Private Const LOGPIXELSX = 88
Private 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 blnSave As Boolean '是否将InkEdit更新到ListView，按下Esc键时，不更新，取消修改Private strOriginal As String '记录每次显示InkEdit时的原始值，用于其退出时的比较Dim preColor As Double '颜色值
Dim nameCol As Integer, monthCol As IntegerDim totalCol As IntegerDim keyWord As StringDim arrData(), arrWidth(), temp()Dim LvItem As ListItemDim total As DoubleDim dicName As Object, dicMonth As ObjectDim firstRow As IntegerDim lastRow As Long, lastCol As LongDim i As Long, j As Long
Dim StrikeTimes As Integer '记录Esc键的按键次数Dim lastEscapeTime As Single '记录第一次按下ESC的时间
Dim dicType As Object, dicState As Object, dicNameList As Object '//用于检查数据
Private Sub CheckBox1_Change() If Me.CheckBox1 Then shSettings.Cells(2, 3).Value = "On" Me.CmdDelete.Visible = True Else shSettings.Cells(2, 3).Value = "Off" Me.CmdDelete.Visible = False End IfEnd Sub
Private Sub CmdAddNew_Click() Dim lastNo As Long Dim lastCol As Integer With Me.LvDetail lastNo = .ListItems(.ListItems.Count).Text + 1 lastCol = .ColumnHeaders.Count
Set LvItem = .ListItems.Add
With LvItem .Text = lastNo shData.Cells(lastEmptyRow, 1) = lastNo .SubItems(lastCol - 1) = lastEmptyRow lastEmptyRow = lastEmptyRow + 1 .EnsureVisible End With End WithEnd Sub
Private Sub CmdDelete_Click() Dim k As Long Dim i As Long Dim RowIndex As Long Dim endCol As Long Dim totalRows As Long With Me.LvDetail endCol = .ColumnHeaders.Count totalRows = .ListItems.Count For i = totalRows To 1 Step -1 If .ListItems(i).Checked Then k = k + 1 If k = 1 Then If Not wContinue("即将删除勾选记录！") Then Exit Sub End If RowIndex = .ListItems(i).SubItems(endCol - 1) .ListItems.Remove i shData.Rows(RowIndex).Delete End If Next
'//如果不是全部删除，则重新加载数据 If k < totalRows Then Call LoadData Call ReNew End If End With Me.CmdSelectAll.Caption = "全选" If k > 0 Then MsgBox "成功删除" & k & "条记录！" End IfEnd Sub
Private Sub CmdSelectAll_Click() With Me.LvDetail If Me.CmdSelectAll.Caption = "全选" Then For i = 1 To .ListItems.Count .ListItems(i).Checked = True Next Me.CmdSelectAll.Caption = "全消" 'Me.CmdSelectAll.BackColor = RGB(176, 224, 230) Me.CmdSelectAll.ForeColor = vbBlue Else For i = 1 To .ListItems.Count .ListItems(i).Checked = False Next Me.CmdSelectAll.Caption = "全选" 'Me.CmdSelectAll.BackColor = RGB(143, 188, 143) Me.CmdSelectAll.ForeColor = vbRed End If End WithEnd Sub
Private Sub InkEdit1_DblClick()
'//显示输入选项（日期窗体、下拉列表窗体等） If InStr(Me.LvDetail.ColumnHeaders(colIndex), "日期") > 0 Or Me.LvDetail.ColumnHeaders(colIndex) = "交货期" Then Usf_DateSelect.Show 1 With Usf_DateSelect .StartUpPosition = 0 .Left = UserForm1.Left + Me.InkEdit1.Left + Me.InkEdit1.Width .Top = UserForm1.Top + Me.InkEdit1.Top + Me.InkEdit1.Height + 20 End With Me.InkEdit1 = tempValue ElseIf Me.LvDetail.ColumnHeaders(colIndex) = "姓名" Then inputType = "姓名" UserForm2.Show Me.InkEdit1 = tempValue ElseIf Me.LvDetail.ColumnHeaders(colIndex) = "性质" Then inputType = "性质" UserForm2.Show Me.InkEdit1 = tempValue ElseIf Me.LvDetail.ColumnHeaders(colIndex) = "状态" Then inputType = "状态" UserForm2.Show Me.InkEdit1 = tempValue End IfEnd Sub
Private Sub UserForm_Initialize() Dim currMonth As String Dim strList As String, temp Application.ScreenUpdating = False IsSheetDate = False '//日期控件变量
Call getDic
EditableField = "Except/序号/RwIdx" strRequiredField = "Except/备注" If shSettings.Cells(2, 3) = "On" Then Me.CheckBox1.Value = True Me.CmdDelete.Visible = True Else Me.CheckBox1.Value = False Me.CmdDelete.Visible = False End If
Me.CmdSelectAll.ForeColor = vbRed
Call LoadData
'//设置ListView
With Me.LvDetail LockWindowUpdate .hwnd .Visible = False
'//ListView的基本设置 .View = lvwReport .Gridlines = True .Sorted = False .CheckBoxes = True .LabelEdit = lvwManual .FullRowSelect = True
'//添加表头 For i = 1 To lastCol If InStr(arrData(1, i), "金额") > 0 Then .ColumnHeaders.Add , , arrData(1, i), arrWidth(i) * 5, lvwColumnRight Else .ColumnHeaders.Add , , arrData(1, i), arrWidth(i) * 5 End If Next
'//添加数据 For i = 2 To UBound(arrData) total = total + arrData(i, totalCol) Set LvItem = .ListItems.Add With LvItem .Text = arrData(i, 1) For j = 2 To lastCol .SubItems(j - 1) = IIf(IsNull(arrData(i, j)), "", arrData(i, j)) Next End With Next LockWindowUpdate 0 .Visible = True End With With Me.LbSum .Caption = "金额合计：" & Format(total, "Standard") .Left = Me.LvDetail.ColumnHeaders(totalCol).Left - .Width + Me.LvDetail.ColumnHeaders(totalCol).Width
End With
'根据指定字段转化可编辑列、必填列 With Me.LvDetail For i = 1 To .ColumnHeaders.Count If InStr(EditableField, "All") Then If .ColumnHeaders(i) <> "ID" Then '//如果是数据库，ID字段不能修改 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
preColor = RGB(72, 201, 176) With InkEdit1 .BackColor = preColor .Font.Size = Me.LvDetail.Font.Size .Width = 0 .Text = "" '.MultiLine = False '在控件属性中设置 .ZOrder 0 '把InkEdit1移到最上一层，避免被Listview遮住 End With sngPixelPerPoint = Pixel2PointX blnSave = 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 Application.ScreenUpdating = TrueEnd Sub
'***************************↓使得ListView可编辑相关代码↓*********************************'InkEdit失去焦点时即可发生Exit事件'InkEdit退出事件。退出时需要指定是否保存修改内容。Private Sub InkEdit1_Exit(ByVal Cancel As MSForms.ReturnBoolean) writeData blnSave blnSave = TrueEnd Sub
Private Sub InkEdit1_KeyUp(pKey As Long, ByVal ShiftKey As Integer) '//InkEdit控件的按键处理程序 Dim ItemIndex As Long Dim ColCount As Long Dim ItemCount As Long Dim LvItem As ListItem Dim currIntervals As Single
If pKey = 27 Then StrikeTimes = StrikeTimes + 1 If StrikeTimes = 1 Then lastEscapeTime = Timer ElseIf StrikeTimes = 2 Then currIntervals = Timer - lastEscapeTime Else StrikeTimes = 0 End If End If
With LvDetail ItemIndex = .SelectedItem.Index ColCount = .ColumnHeaders.Count ItemCount = .ListItems.Count blnSave = True
Select Case pKey Case 13 '13=回车键 .SetFocus If colIndex = ColCount Then If ItemIndex < ItemCount Then Set .SelectedItem = .ListItems(ItemIndex + 1) colIndex = 2 Else Set LvItem = .ListItems.Add Set .SelectedItem = .ListItems(.ListItems.Count) colIndex = 2 End If Else Set .SelectedItem = .ListItems(ItemIndex) colIndex = colIndex + 1 End If
If InStr(EditableCol, Format(colIndex, "00")) Then .SelectedItem.EnsureVisible ShowInkEdit End If Case 37 '37=向左键头 .SetFocus '先触InkEdit1_Exit事件，此后Listview已获焦 If colIndex > 1 Then colIndex = colIndex - 1 ShowInkEditForLRKey 37 End If Case 38 '38=向上键头 .SetFocus If ItemIndex > 1 Then Set .SelectedItem = .ListItems(ItemIndex - 1) .SelectedItem.EnsureVisible ShowInkEdit End If Case 39 '39=向右键头 .SetFocus If colIndex < ColCount Then colIndex = colIndex + 1 ShowInkEditForLRKey 39 End If Case 40 '40=向下箭头 .SetFocus If ItemIndex < ItemCount Then Set .SelectedItem = .ListItems(ItemIndex + 1) .SelectedItem.EnsureVisible ShowInkEdit End If Case 27 '27 = Esc键，取消修改 If StrikeTimes = 2 Then '按2次Esc键,并且两次按键时间小于2秒，才退出inkedit,在输入法中会用Esc取消输入 If currIntervals < 0.8 Then blnSave = False .SetFocus StrikeTimes = 0 End If End If
End Select End WithEnd Sub
Private Function Pixel2PointX() As Double
'//把X方向的像素值转为磅。VBA窗体的度量单位是磅。 '//像素和磅的转换跟屏幕密度有关，不同电脑可能不同值。 Dim hDC As Long, DPIx As Long hDC = GetDC(0) '获取屏幕设备环境句柄 DPIx = GetDeviceCaps(hDC, LOGPIXELSX) '获取屏幕X方向像素密度 ReleaseDC 0, hDC '释放屏幕设备环境 Pixel2PointX = 72 / DPIxEnd Function
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 Dim ScrollPos As Double Dim sngMousePosX As Double With LvDetail ScrollPos = sngPixelPerPoint * GetScrollPos(.hwnd, SB_HORZ) sngMousePosX = sngPixelPerPoint * x For colIndex = 1 To .ColumnHeaders.Count sngDiff = .ColumnHeaders(colIndex).Left - ScrollPos If sngMousePosX > sngDiff And sngMousePosX < sngDiff + .ColumnHeaders(colIndex).Width Then Exit For Next If colIndex > .ColumnHeaders.Count Then colIndex = 0 '计算失败时，置为零 End WithEnd Sub
Private Sub writeData(Optional ByVal blnSave As Boolean = True)
'//InkEdit控件退出时的处理程序,将修改内容同步到Listview,同时更新到工作表 Dim currValue As String On Error Resume Next With LvDetail If .SelectedItem Is Nothing Then Exit Sub
If strOriginal = InkEdit1.Text Then '//InkEdit的值有改变时才执行后面语句 InkEdit1.Width = 0 Exit Sub End If
If InStr(strRequiredCol, Format(colIndex, "00")) Then If Len(InkEdit1.Text) = 0 Then MsgBox "该项为必填项，修改已被取消！", vbCritical InkEdit1.Width = 0 Exit Sub End If End If
currValue = Trim(InkEdit1.Text) Call checkDic If Not IsDataValid(currValue, colIndex) Then MsgBox "输入的值不符合要求，请重新输入！" Exit Sub End If
If blnSave Then If colIndex > 1 Then currValue = Trim(InkEdit1.Text) .SelectedItem.SubItems(colIndex - 1) = currValue 'shData.Cells(getRow(.SelectedItem.Text), colIndex) = currValue '这是根据第一列序号来确定工作表的行号
'//加载数据到数组arrData时，多增加一列，写入行号，据以更新数据 shData.Cells(.SelectedItem.SubItems(.ColumnHeaders.Count - 1), colIndex) = currValue End If Else .SelectedItem.Text = InkEdit1.Text '第一列基本上更新不到 End If .SelectedItem.ListSubItems(colIndex - 1).ForeColor = vbRed '修改的记录标红
'修改后重新加载数据 Call LoadData If .ColumnHeaders(colIndex) = "合同金额" Then Call ReNew End If End With
InkEdit1.Width = 0 InkEdit1.Text = "" tempValue = ""End Sub
Private Function getRow(ItemText As String) '//定位到当前序号，暂时未用 Dim i As Long For i = 2 To UBound(arrData) If CStr(arrData(i, 1)) = ItemText Then getRow = i Exit For End If NextEnd Function
Private Sub LvDetail_Click()
'//点击ListView的Item，如果是否修改为TRUE，且点击的列设定为可编辑 If Me.CheckBox1 Then If InStr(EditableCol, Format(colIndex, "00")) Then Call ShowInkEdit End If End IfEnd Sub
Private Sub ShowInkEditForLRKey(ByVal intKey As Integer)
'//左右方向键处理程序。主要计算是水平滚动条的滚动量，以确保InkEdit可见 Dim NewInkLeft As Double Dim ScrollAmount As Long Dim InkLocked As Boolean With LvDetail If colIndex = 0 Then Exit Sub If .SelectedItem Is Nothing Then Exit Sub If InStr(EditableCol, Format(colIndex, "00")) = 0 Then Exit Sub
If colIndex > 1 Then InkEdit1.Text = .SelectedItem.SubItems(colIndex - 1) Else InkEdit1.Text = .SelectedItem.Text End If If intKey = 37 Then '向左 NewInkLeft = InkEdit1.Left - .ColumnHeaders(colIndex).Width If NewInkLeft < .Left + 1.5 Then ScrollAmount = CLng((NewInkLeft - (.Left + 1.5)) / sngPixelPerPoint) '滚动量，单位像素 SendMessageLong .hwnd, LVM_SCROLL, ScrollAmount, 0 '拖动Listview水平滚动条，保持InkEdit可见 InkEdit1.Left = .Left + 1.5 Else InkEdit1.Left = NewInkLeft End If Else '向右 NewInkLeft = InkEdit1.Left + .ColumnHeaders(colIndex - 1).Width If NewInkLeft + .ColumnHeaders(colIndex).Width > .Left + .Width Then ScrollAmount = CLng((NewInkLeft + .ColumnHeaders(colIndex).Width - (.Left + .Width)) / sngPixelPerPoint) SendMessageLong .hwnd, LVM_SCROLL, ScrollAmount, 0 InkEdit1.Left = .Left + .Width - .ColumnHeaders(colIndex).Width
Else InkEdit1.Left = NewInkLeft End If End If InkEdit1.Top = .Top + .SelectedItem.Top + 1.5 InkEdit1.Width = .ColumnHeaders(colIndex).Width InkEdit1.Height = .SelectedItem.Height
If InStr(EditableCol, Format(colIndex, "00")) = 0 Then InkLocked = True Else InkLocked = False End If InkEdit1.Locked = InkLocked InkEdit1.SelStart = 0 InkEdit1.SelLength = Len(InkEdit1.Text) strOriginal = InkEdit1.Text InkEdit1.SetFocus End WithEnd Sub
Private Sub ShowInkEdit() '//显示InkEdit控件的处理程序。需要显示InkEdit时调用
Dim ScrollPos As Double Dim InkLocked As Boolean Dim iItem As String Dim RowIndex As Long
With LvDetail If colIndex = 0 Then Exit Sub '点击的列号未计算成功 If .SelectedItem Is Nothing Then Exit Sub 'Listview列表为空时退出 ScrollPos = sngPixelPerPoint * GetScrollPos(.hwnd, SB_HORZ) If colIndex > 1 Then InkEdit1.Text = .SelectedItem.SubItems(colIndex - 1) strOriginal = InkEdit1.Text RowIndex = .SelectedItem.Index Else InkEdit1.Text = .SelectedItem.Text End If
InkEdit1.Left = .ColumnHeaders(colIndex).Left + .Left + 1.5 - ScrollPos InkEdit1.Top = .Top + .SelectedItem.Top + 1.5 InkEdit1.Width = .ColumnHeaders(colIndex).Width InkEdit1.Height = .SelectedItem.Height If InStr(EditableCol, Format(colIndex, "00")) = 0 Then InkLocked = True Else InkLocked = False End If InkEdit1.Locked = InkLocked InkEdit1.SelStart = 0 InkEdit1.SelLength = Len(InkEdit1.Text) InkEdit1.SetFocus
End WithEnd Sub'关闭窗体时，还原Listview和InkEdit控件的窗口程序,在退出窗体时调用Private Sub RestoreAPI() SetWindowLong LvDetail.hwnd, GWL_WNDPROC, LvmPreWndProc SetWindowLong InkEdit1.hwnd, GWL_WNDPROC, InkPreWndProc
End Sub
Private Sub CmdQuery_Click() Dim currName As String, currMonth As String currName = Me.CmbName currMonth = Me.CmbMonth total = 0 With Me.LvDetail .ListItems.Clear For i = 2 To UBound(arrData) If InStr(arrData(i, nameCol), currName) > 0 And InStr(Format(arrData(i, monthCol), "yyyymm"), currMonth) > 0 Then Set LvItem = .ListItems.Add With LvItem .Text = arrData(i, 1) For j = 2 To lastCol .SubItems(j - 1) = arrData(i, j) Next End With total = total + arrData(i, totalCol) End If Next
End With Me.LbSum = "金额合计：" & Format(total, "Standard")
End Sub
Private Sub CmdOutput_Click() Dim wsData As Worksheet Dim lastRow As Long Dim temp() Dim rowsCount As Long Dim colsCount As Long Dim rng As Range With Me.LvDetail rowsCount = .ListItems.Count If rowsCount > 0 Then colsCount = .ColumnHeaders.Count - 1 ReDim temp(1 To rowsCount, 1 To colsCount) For i = 1 To rowsCount temp(i, 1) = .ListItems(i).Text For j = 2 To colsCount temp(i, j) = .ListItems(i).SubItems(j - 1) Next Next Set wsData = ThisWorkbook.Sheets("查询") With wsData lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If lastRow >= 3 Then .Range(.Cells(3, 1), .Cells(lastRow, .UsedRange.Columns.Count)).Clear End If Set rng = .Cells(3, 1).Resize(rowsCount, colsCount) With rng .Value = temp .Borders.LineStyle = 1 .HorizontalAlignment = xlCenter .Rows.RowHeight = 18
End With
End With Unload Me End If End WithEnd Sub
Private Sub CmdShowAll_Click() total = 0 With Me.LvDetail .ListItems.Clear For i = 2 To UBound(arrData) Set LvItem = .ListItems.Add With LvItem .Text = arrData(i, 1) For j = 2 To lastCol .SubItems(j - 1) = arrData(i, j) Next total = total + arrData(i, totalCol) End With Next
End With Me.LbSum = "金额合计：" & Format(total, "Standard") Me.CmbMonth = "" Me.CmbName = ""
End Sub
Private Sub CmdExit_Click() Unload MeEnd Sub
Private Sub LoadData() '//加载数据 Dim currMonth As String Set dicName = CreateObject("Scripting.Dictionary") Set dicMonth = CreateObject("Scripting.Dictionary")
keyWord = "序号"
With shData On Error Resume Next firstRow = .Cells.Find(keyWord).Row On Error Resume Next If firstRow = 0 Then firstRow = 1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row lastCol = .Rows(firstRow).Cells.Find(what:="*", _ lookat:=xlPart, _ LookIn:=xlFormulas, _ searchorder:=xlByColumns, _ searchdirection:=xlPrevious).Column arrData = .Range(.Cells(firstRow, 1), .Cells(lastRow, lastCol)).Value
lastRow = UBound(arrData, 1) lastCol = UBound(arrData, 2) + 1
ReDim Preserve arrData(1 To lastRow, 1 To lastCol) arrData(1, lastCol) = "RwIdx" '工作表对应行号"
ReDim arrWidth(1 To lastCol) For i = 1 To lastCol - 1 arrWidth(i) = .Columns(i).ColumnWidth Next End With
total = 0
For i = 1 To lastCol If arrData(1, i) = "姓名" Then nameCol = i End If If arrData(1, i) = "合同金额" Then totalCol = i End If If arrData(1, i) = "日期" Then monthCol = i End If Next
For i = 2 To UBound(arrData) arrData(i, lastCol) = i - firstRow + 1 'total = total + arrData(i, totalCol) dicName(arrData(i, nameCol)) = "" currMonth = Format(arrData(i, monthCol), "yyyymm") dicMonth(currMonth) = "" Next lastEmptyRow = UBound(arrData) - (firstRow - 1) + 1 Me.CmbName.List = dicName.keys Me.CmbMonth.List = dicMonth.keysEnd Sub
Sub ReNew() '//修改金额后，更新合计数 total = 0 With Me.LvDetail If .ListItems.Count = 0 Then Me.LbSum = "金额合计：0.00" Else For i = 1 To .ListItems.Count total = total + .ListItems(i).SubItems(totalCol - 1) Next Me.LbSum = "金额合计：" & Format(total, "Standard") End If End WithEnd Sub
Private Function IsDataValid(currData As Variant, currCol As Integer) As Boolean
'//检查数据有效性
With Me.LvDetail If InStr(.ColumnHeaders(currCol), "日期") > 0 Or .ColumnHeaders(currCol) = "交货期" Then If IsDate(currData) Then IsDataValid = True
ElseIf InStr(.ColumnHeaders(currCol), "数量") > 0 Or InStr(.ColumnHeaders(currCol), "单价") > 0 Or InStr(.ColumnHeaders(currCol), "金额") > 0 Then If IsNumeric(currData) Then IsDataValid = True
ElseIf .ColumnHeaders(currCol) = "姓名" Then If dicNameList.exists(currData) Then IsDataValid = True
ElseIf .ColumnHeaders(currCol) = "性质" Then If dicType.exists(currData) Then IsDataValid = True
ElseIf .ColumnHeaders(currCol) = "状态" Then If dicState.exists(currData) Then IsDataValid = True
Else IsDataValid = True End If End With
End FunctionPrivate Sub checkDic() If dicNameList.Count = 0 Or dicType.Count = 0 Or dicState.Count = 0 Then Call getDic End IfEnd Sub
Private Sub getDic() Dim temp, strList As String Set dicNameList = CreateObject("Scripting.dictionary") Set dicType = CreateObject("Scripting.dictionary") Set dicState = CreateObject("Scripting.dictionary")
'// "性质" strList = shSettings.Cells(3, 3) temp = Split(strList, ",") For i = 0 To UBound(temp) dicType(temp(i)) = "" Next
'// "状态" strList = shSettings.Cells(4, 3) temp = Split(strList, ",") For i = 0 To UBound(temp) dicState(temp(i)) = "" Next
'// "姓名" With shName temp = .Cells(2, 2).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row - 1, 1) End With
For i = 1 To UBound(temp) dicNameList(temp(i, 1)) = "" NextEnd Sub
4、在Thisworkbook中，日期控件相关代码，备用代码：Option ExplicitPrivate Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongPrivate Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, _ ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As LongPrivate Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As LongPtrPublic preDate As Date
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim lHwnd As Long Dim lDC As Long Dim lCaps As Long Dim lngLeft As Long Dim lngTop As Long Dim sngPiexlToPiont As Single Dim lngTitleBarHeight As Long Dim clsDC As New DateControl
On Error Resume Next '全选工作表会报错
If Selection.CountLarge = 1 Then If Target.Row > 1 And InStr(Cells(1, Target.Column), "日期") Then If clsDC.IsFormActive("Usf_DateSelect") Then Unload Usf_DateSelect
End If IsSheetDate = True With Usf_DateSelect
If Selection.Value <> "" Then If IsDate(Selection.Value) Then .Caption = Selection.Value .Controls("CmbYear") = Year(Selection) .Controls("CmbMonth") = Month(Selection) preDate = Selection.Value Else .Caption = Date .Controls("CmbYear") = Year(Date) .Controls("CmbMonth") = Month(Date) preDate = Date End If Else If Target.Offset(-1, 0).Value <> "" Then If IsDate(Target.Offset(-1, 0)) Then .Caption = Target.Offset(-1, 0).Value .Controls("CmbYear") = Year(Target.Offset(-1, 0).Value) .Controls("CmbMonth") = Month(Target.Offset(-1, 0).Value) preDate = Target.Offset(-1, 0).Value Else .Caption = Date .Controls("CmbYear") = Year(Date) .Controls("CmbMonth") = Month(Date) preDate = Date End If Else .Caption = Date .Controls("CmbYear") = Year(Date) .Controls("CmbMonth") = Month(Date) preDate = Date End If End If If Format(.Caption, "YYYYMM") < Format(Date, "YYYYMM") Then .BackColor = RGB(139, 69, 19) ElseIf Format(.Caption, "YYYYMM") > Format(Date, "YYYYMM") Then .BackColor = RGB(144, 238, 144) Else .BackColor = RGB(147, 112, 219) End If .Show
Const lLogPixelsX = 88 lDC = GetDC(0) lCaps = GetDeviceCaps(lDC, lLogPixelsX) lngTitleBarHeight = GetSystemMetrics(4) ' 4 对应的是 SM_CYCAPTION sngPiexlToPiont = 72 / lCaps * (100 / Application.ActiveWindow.Zoom) lngLeft = CLng(ActiveWindow.PointsToScreenPixelsX(0) + ((Target.Offset(1, 0).Left + Target.Width) / sngPiexlToPiont)) lngTop = CLng(ActiveWindow.PointsToScreenPixelsY(0) + ((Target.Offset(1, 0).Top - lngTitleBarHeight + Target.Height) / sngPiexlToPiont)) Usf_DateSelect.StartUpPosition = 0
lHwnd = FindWindow(vbNullString, Usf_DateSelect.Caption) MoveWindow lHwnd, lngLeft, lngTop, .Width / (72 / lCaps), .Height / (72 / lCaps) * 1.01, True
Usf_DateSelect.Show End With Else Unload Usf_DateSelect End If Else Unload Usf_DateSelect End If Target.Activate' IsSheetDate = FalseEnd Sub
Private Sub Workbook_Open()' '//如果有不案例警告，可启用下列代码后重新打开工作表，然后再注释掉' On Error Resume Next' Dim WShell As Object' Set WShell = CreateObject("Wscript.Shell")' WShell.RegWrite "HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms", 1, "REG_DWORD"' Set WShell = NothingEnd Sub
Option Explicit
Private Sub CmdConfirm_Click() tempValue = Me.ComboBox1 Unload MeEnd Sub
Private Sub UserForm_Activate() Dim dic As Object Dim arr Dim strList As String If inputType = "性质" Then strList = shSettings.Cells(3, 3) arr = Split(strList, ",") ElseIf inputType = "状态" Then strList = shSettings.Cells(4, 3) arr = Split(strList, ",") ElseIf inputType = "姓名" Then With shName arr = .Cells(2, 2).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row - 1, 1) End With End If Me.ComboBox1.List = arr Me.Caption = inputType
End Sub
6、在Usf_DateSelect用户窗体中，日期控件相关代码：Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As LongPrivate clsDC As New DateControlPrivate co As New Collection'Public sLabelName As String'Dim myDate As DateDim arrWeek As Variant '星期几Dim arrForeColor As Variant '前景色(文本颜色)
'窗体加载Private Sub UserForm_Initialize() Dim clsCommandButton As MSForms.CommandButton Dim clsComboBox As MSForms.ComboBox Dim wholeWidth As Double Me.BackColor = RGB(147, 112, 219)
'添加 年列表 左按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "YearDecrease") With clsCommandButton .Width = 15 .Height = 15 .Caption = ChrW(&H25C0) .Font.Size = 7 .ForeColor = vbBlue .BackStyle = 0
End With
clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing
'添加 年列表 Set clsComboBox = Me.Controls.Add("Forms.ComboBox.1", "CmbYear") With clsComboBox For i = 1900 To 2999 .AddItem i Next .Left = Me.Controls("YearDecrease").Left + Me.Controls("YearDecrease").Width .Width = 45 .Height = 15 .Value = Year(myDate) .Font.Size = 11 .ListWidth = 50 '.ColumnWidths = 18 '.Style = fmStyleDropDownList .TextAlign = fmTextAlignLeft .Text = Year(Date) End With clsDC.ReceiveComboBox clsComboBox co.Add clsDC Set clsDC = Nothing
'添加 年列表 右按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "YearIncrease") With clsCommandButton .Left = Me.Controls("CmbYear").Left + Me.Controls("CmbYear").Width .Width = 15 .Height = 15 .Caption = ChrW(&H25B6) .Font.Size = 7 .ForeColor = vbBlue .BackStyle = 0 End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing
'添加 月列表 左按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "MonthDecrease") With clsCommandButton .Left = Me.Controls("YearIncrease").Left + Me.Controls("YearIncrease").Width + 2 .Width = 15 .Height = 15 .Caption = ChrW(&H25C0) .Font.Size = 7 .ForeColor = RGB(100, 149, 237) .BackStyle = 0
End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing
'添加 月列表 Set clsComboBox = Me.Controls.Add("Forms.ComboBox.1", "CmbMonth") With clsComboBox For i = 1 To 12 .AddItem i Next .Left = Me.Controls("MonthDecrease").Left + Me.Controls("MonthDecrease").Width .Width = 35 .Height = 15 .Value = Month(myDate) .Font.Size = 11 .ListWidth = 35 '.ColumnWidths = 18 .Text = Month(Date) End With clsDC.ReceiveComboBox clsComboBox co.Add clsDC Set clsDC = Nothing
'添加 月列表 右按钮 Set clsCommandButton = Me.Controls.Add("Forms.CommandButton.1", "MonthIncrease") With clsCommandButton .Left = Me.Controls("CmbMonth").Left + Me.Controls("CmbMonth").Width .Width = 15 .Height = 15 .Caption = ChrW(&H25B6) .Font.Size = 7 .ForeColor = RGB(100, 149, 237) .BackStyle = 0
End With clsDC.ReceiveCommandButton clsCommandButton co.Add clsDC Set clsDC = Nothing
Me.Width = Me.Controls("MonthIncrease").Left + Me.Controls("MonthIncrease").Width
arrWeek = Array("日", "一", "二", "三", "四", "五", "六") '初始化 星期几 数组 '初始化 Label 前景色 arrForeColor = Array(vbRed, 0, 0, 0, 0, 0, vbRed)
'添加星期标签 For i = LBound(arrWeek) To UBound(arrWeek) With Me.Controls.Add("Forms.Label.1", arrWeek(i)) .Top = 17 .Left = i * 20 + 1.5 .Width = 20 .Height = 11 .Caption = arrWeek(i) .TextAlign = fmTextAlignCenter .BackColor = RGB(176, 196, 222) .ForeColor = arrForeColor(i)' .BorderStyle = fmBorderStyleSingle End With Next wholeWidth = 20 * 7 + 1.5 * 6 + 5 AddLabel_Day Date Me.Caption = Date Me.Width = wholeWidth
End Sub
'添加日期标签Public Sub AddLabel_Day(ByVal myDate As Date) Dim iCol As Integer '列标 Dim iRow As Integer '行标 Dim arrForeColor As Variant '前景色(文本颜色) Dim datStartDay As Date '开始日期 Dim datLastDay As Date '结尾日期 Dim clsLabel As control
'删除原有的日期标签 For Each clsLabel In Controls If clsLabel.Name Like "LbDay*" Then Controls.Remove clsLabel.Name Next
arrForeColor = Array(vbRed, 0, 0, 0, 0, 0, vbRed) '初始化 Label 前景色 datStartDay = DateSerial(Year(myDate), Month(myDate), 1) datStartDay = datStartDay - WeekDay(datStartDay) + 1 '取得开始日期
datLastDay = DateSerial(Year(myDate), Month(myDate) + 1, 0) datLastDay = datLastDay + 7 - WeekDay(datLastDay) '取得结尾日期
For i = datStartDay To datLastDay iCol = (i - datStartDay) Mod 7 iRow = Int((i - datStartDay) / 7) Set clsLabel = Me.Controls.Add("Forms.Label.1", "LbDay" & i) With clsLabel .Top = iRow * 13 + 30 .Left = iCol * 20 + 1.5 .Width = 20 .Height = 13 .Caption = Day(i) .Font.Size = 11 .Font.Name = "Georgia" .TextAlign = fmTextAlignCenter' .BorderStyle = fmBorderStyleSingle If Month(i) = Month(myDate) Then '设置前景色，如果日期不在本月的，设成灰色 .ForeColor = arrForeColor(iCol) Else .ForeColor = RGB(150, 150, 150) End If If i = Date Then '设置当前日期标签的背景色，今天标色，当前日期标色 .BackColor = RGB(0, 250, 154) ElseIf i = myDate Then .BackColor = RGB(100, 149, 237) Else .BackColor = RGB(255, 250, 205) End If End With clsDC.ReceiveLabel clsLabel co.Add clsDC Set clsDC = Nothing Next lngTitleBarHeight = GetSystemMetrics(4) Me.Height = Controls("LbDay" & datLastDay).Top + Controls("LbDay" & datLastDay).Height + lngTitleBarHeight + 1.5
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '//强制点击日期 Dim i As Integer Dim usfCount As Integer For i = 0 To UserForms.Count - 1 usfCount = usfCount + 1 Next If CloseMode = vbFormControlMenu Then '如果是通过控制按钮（X）关闭 If usfCount > 1 Then
Cancel = True '取消关闭操作 End If End IfEnd Sub
7、类模块DateControl，日期控件相关代码：Private WithEvents clsLabel As MSForms.LabelPrivate WithEvents clsComboBox As MSForms.ComboBoxPrivate WithEvents clsCommandButton As MSForms.CommandButtonProperty Get myDate() As Date With Usf_DateSelect myDate = CDate(Usf_DateSelect.Caption) End WithEnd Property
Public Sub ReceiveLabel(ByVal reLabel As MSForms.Label) Set clsLabel = reLabelEnd Sub
Public Sub ReceiveComboBox(ByVal reComboBox As MSForms.ComboBox) Set clsComboBox = reComboBoxEnd Sub
Public Sub ReceiveCommandButton(ByVal reCommandButton As MSForms.CommandButton) Set clsCommandButton = reCommandButtonEnd Sub
Private Sub clsComboBox_Change() With Usf_DateSelect .AddLabel_Day DateSerial(.Controls("CmbYear"), .Controls("CmbMonth"), Day(.Caption)) End WithEnd Sub
Private Sub clsCommandButton_Click() Dim currValue As Integer Dim currMonth As String Dim currFirstDay As Date
With Usf_DateSelect Select Case clsCommandButton.Name Case "YearDecrease" currValue = .Controls("CmbYear").Value If currValue <> 1900 Then .Controls("CmbYear").Value = currValue - 1 Case "YearIncrease" currValue = .Controls("CmbYear").Value If currValue <> 2999 Then .Controls("CmbYear").Value = currValue + 1 Case "MonthDecrease" currValue = .Controls("CmbMonth").Value .Controls("CmbMonth").Value = IIf(currValue - 1 Mod 12, currValue - 1, 12) Case "MonthIncrease" currValue = .Controls("CmbMonth").Value .Controls("CmbMonth").Value = IIf(currValue Mod 12, currValue + 1, 1) End Select currMonth = .Controls("CmbYear").Value & Format(.Controls("Cmbmonth").Value, "00") currFirstDay = CDate(.Controls("CmbYear").Value & "/" & .Controls("Cmbmonth").Value & "/1") If currMonth <> Format(.Caption, "YYYYMM") Then .AddLabel_Day currFirstDay End If
If currMonth < Format(Date, "YYYYMM") Then .BackColor = RGB(139, 69, 19) ElseIf currMonth > Format(Date, "YYYYMM") Then .BackColor = RGB(144, 238, 144) Else .BackColor = RGB(147, 112, 219)
End If
End WithEnd Sub
Private Sub clsLabel_Click() If IsSheetDate Then Selection = Replace(clsLabel.Name, "LbDay", "") Selection.NumberFormatLocal = "yyyy/m/d" 'tempValue = myDate Else tempValue = Replace(clsLabel.Name, "LbDay", "") End If Unload Usf_DateSelectEnd Sub
Private Sub clsLabel_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) clsLabel.BorderStyle = 0 clsLabel.BackColor = RGB(135, 206, 250)
End Sub
Function IsFormActive(UsfName As String) As Boolean Dim i As Integer For i = 0 To UserForms.Count - 1 IsFormActive = UserForms(i).Name = UsfName If IsFormActive Then Exit Function NextEnd Function
|
