【原】「代码」独家干货免费分享！VBA综合应用，库存管理系统，出入库管理系统，收发存管理系统

内容提要

• 出入库管理系统|完整代码

1、在工作表“单据录入”里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Option ExplicitDim arr(), arrtemp(), DeliverNumber As StringDim sql As StringDim i As Long, j As Long
Private Sub CmdAddNew_Click()    Call clsRG.clearData    Call updateDeliverNumberEnd Sub
Private Sub CmdDelete_Click()    Dim rng As Range    On Error Resume Next    Set rng = Intersect(Selection.EntireRow, clsRG.数据区域)    On Error GoTo 0    If Not rng Is Nothing Then        If Not wContinue("即将删除：" & rng.Address & "所在单元格记录！") Then Exit Sub        rng.ClearContents    End IfEnd Sub
Private Sub CmdPrint_Click()    Call printWorksheet(clsRG.打印区域)End Sub
Private Sub CmdRefresh_Click()    Call updateDeliverNumberEnd Sub
Private Sub CmdSave_Click()    Dim bookYear As String, currYear As String    If clsDQ.IsDeliverNumberExists(clsRG.单据编号) Then        MsgBox "单据号已存在，请更新单据号后再保存！"        Exit Sub    End If    bookYear = getSetting("当前年度")    currYear = Year(clsRG.单据日期)    If bookYear <> currYear Then        MsgBox "单据日期年度:" & currYear & "应为:" & bookYear & Chr(10) & "请重新修改后保存！"        Exit Sub    End If
    processType = "新增保存"
    Call saveNewEnd Sub
Private Sub CmdSaveAndPrint_Click()    Dim bookYear As String, currYear As String
    If clsDQ.IsDeliverNumberExists(clsRG.单据编号) Then        MsgBox "单据号已存在，请更新单据号后再保存！"        Exit Sub    End If
    bookYear = getSetting("当前年度")    currYear = Year(clsRG.单据日期)    If bookYear <> currYear Then        MsgBox "单据日期年度:" & currYear & "应为:" & bookYear & Chr(10) & "请重新修改后保存！"        Exit Sub    End If
    processType = "新增保存"    Call printWorksheet(clsRG.打印区域)    Call saveNew
End Sub

Private Sub CmdClear_Click()    clsRG.clearDataEnd Sub
Private Sub CmdSwitch_Click()    If Range("A3") = "采购入库单" Then        BillingType = "出库"        Call shBillingFormat        Call updateDeliverNumber        NegativeInventoryRemind = True  '//负库存提醒    Else        BillingType = "入库"        Call shBillingFormat        Call updateDeliverNumber
    End IfEnd Sub
Private Sub CmdUpdate_Click()    If Not clsDQ.IsDeliverNumberExists(clsRG.单据编号) Then        MsgBox "单据号不存在，无法更新！"        Exit Sub    End If    processType = "更新保存"    Call saveNewEnd Sub
Private Sub CmdUpdateAndPrint_Click()    If Not clsDQ.IsDeliverNumberExists(clsRG.单据编号) Then        MsgBox "单据号不存在，无法更新！"        Exit Sub    End If    processType = "更新保存"
    Call printWorksheet(clsRG.打印区域)    Call saveNewEnd SubPrivate Sub Worksheet_Activate()    If dbs = "" Then        dbs = ThisWorkbook.FullName    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)    Dim arr(), rng As Range    Dim DeliverNumber As String    Dim currRow As Integer, currCol As Integer    Dim targetCol As Integer    Dim currBalance As Double    Dim inventoryCode As String    Dim dic As Object   '//控制存货编码不重复    Dim currYear As String, bookYear As String    Dim tm
    Set dic = CreateObject("Scripting.dictionary")

    '//单据日期与单据号，如果是新单据日期，更新单据号；    '//否则根据单据号读取数据    If Target.Address = clsRG.单据日期.MergeArea.Address Then        bookYear = getSetting("当前年度")        tm = Target.Value        currYear = Year(tm(1, 1))        If bookYear <> currYear Then            MsgBox "当前年度应为：" & bookYear'            Target = ""            Exit Sub        End If
        If blnUpdateDeliverNumber Then            Call updateDeliverNumber        Else            blnUpdateDeliverNumber = True        End If    End If    If Target.Address = clsRG.单据编号.Address Then        If shBilling.Range("A3") = "采购入库单" Then            tbl = "[采购入库$]"        Else            tbl = "[销售出库$]"        End If
        DeliverNumber = Target.Value        If clsDQ.IsDeliverNumberExists(DeliverNumber) Then            blnUpdateDeliverNumber = False            NegativeInventoryRemind = False            Set rng = clsRG.数据区域            rng.ClearContents            sql = "select * from " & tbl & " where 单据编号='" & DeliverNumber & "'"            arr = clsDQ.getData(sql)            clsRG.单据日期 = arr(0, 0)            clsRG.客户名称 = arr(2, 0)            clsRG.联系方式 = arr(3, 0)            clsRG.地址 = arr(4, 0)            With rng                For i = 0 To UBound(arr, 2)                    .Cells(i + 1, 1) = i + 1                    For j = 5 To UBound(arr)                        .Cells(i + 1, j - 3) = arr(j, i)                    Next                Next            End With            blnUpdateDeliverNumber = True            NegativeInventoryRemind = True        End If    End If    '//流水号根据序号自动生成,当单据号存在的时候，不自动修改流水号    '//自动填写序号，当物料名称填写之后
    If Not Intersect(Target, clsRG.存货编码) Is Nothing And Target.CountLarge = 1 Then        '//序号        Target.Offset(0, -1) = Target.Row - 6
    End If
    If Not Intersect(Target, clsRG.序号) Is Nothing And Target.CountLarge = 1 Then        If Application.WorksheetFunction.CountIf(clsRG.序号, Target.Value) > 1 Then            MsgBox "序号重复，请重新输入！"            Target.ClearContents            Exit Sub        End If        targetCol = clsRG.流水号.Column - 1        DeliverNumber = clsRG.单据编号        If Not clsDQ.IsDeliverNumberExists(DeliverNumber) Then            If Target.Value > 0 Then                Target.Offset(0, targetCol).Value = clsRG.单据编号 & Format(Target, "00")            Else                Target.Offset(0, targetCol).Value = ""            End If        End If    End If
    '//数量、单价Change，重算金额、合计数    If Not Intersect(Target, clsRG.数量) Is Nothing And Target.CountLarge = 1 Then        '//检查一下        If IsNumeric(Target.Value) = False Then            MsgBox "数量只能输入数字,请重新输入！"            Target.ClearContents            Exit Sub        End If
        '//出库时，检查库存余额        If NegativeInventoryRemind Then            If Range("A3") = "销售出库单" And Target <> 0 Then                inventoryCode = Target.Offset(0, -3)                currBalance = clsDQ.getBalance(inventoryCode)                If currBalance - Target < 0 Then                    If Not wContinue("库存不足，继续吗？") Then                        Intersect(Target.EntireRow, clsRG.数据区域).ClearContents                        Exit Sub                    End If                End If            End If        End If
        '//金额        Target.Offset(0, 2).Value = Target.Value * Target.Offset(0, 1).Value
        clsRG.数量合计 = Application.WorksheetFunction.Sum(clsRG.数量)        clsRG.金额合计 = Application.WorksheetFunction.Sum(clsRG.金额)
    End If
    If Not Intersect(Target, clsRG.单价) Is Nothing And Target.CountLarge = 1 Then        '//检查一下        If IsNumeric(Target.Value) = False Then            MsgBox "单价只能输入数字,请重新输入！"            Target.ClearContents            Exit Sub        End If        Target.Offset(0, 1).Value = Target.Value * Target.Offset(0, -1).Value        clsRG.金额合计 = Application.WorksheetFunction.Sum(clsRG.金额)    End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)    On Error Resume Next    Dim iRow As Integer, iCol As Integer    Dim iWidth As Single    Dim currBalance As Double    Dim inventoryCode As String
    '//客户名称    Dim ws As Worksheet, currRow As Integer, lastRow As Integer    Dim arr(), dic As Object, dkey As String
    Set dic = CreateObject("Scripting.Dictionary")    dbs = ThisWorkbook.FullName    If shBilling.Range("A3") = "采购入库单" Then        tbl = "[采购入库$]"    Else        tbl = "[销售出库$]"    End If
    dkey = Target.Address    currRow = Target.Row
    If Target.Address = clsRG.客户名称.MergeArea.Address Then
        '//客户、供应商合并为客商，有没有必要区分？        If shBilling.Range("A3") = "采购入库单" Then            sql = "select distinct 客商名称,联系方式,地址 from [客商档案$]  where isnull(客商名称)=false"        Else            sql = "select distinct 客商名称,联系方式,地址 from [客商档案$]  where isnull(客商名称)=false"        End If        arr = clsDQ.getData(sql)        iWidth = Range("B3:D3").Width        Call setTextBox(Target, iWidth, 3, arr)    ElseIf Target.Address = clsRG.单据编号.MergeArea.Address Then        sql = "select count(*) from " & tbl        If clsDQ.RecordValue(sql) = 0 Then            Call updateDeliverNumber            Exit Sub        End If
        sql = "select distinct 单据编号 from " & tbl & " where isnull(单据编号)=false order by 单据编号 DESC"        arr = clsDQ.getData(sql)        iWidth = Target.Width        Call setTextBox(Target, iWidth, 1, arr)    ElseIf Not Intersect(Target, clsRG.存货编码) Is Nothing And Target.CountLarge = 1 Then        If Range("A3") = "采购入库单" Then            sql = "select  distinct 存货编码,存货名称,规格型号,0 as 数量,采购单价 from [存货档案$] "        Else            sql = "select  distinct 存货编码,存货名称,规格型号,0 as 数量,销售单价 from [存货档案$] "
        End If        arr = clsDQ.getData(sql)        'iWidth = clsRG.数据区域.Width - clsRG.数据区域.Columns(1).Width        For i = 2 To 7            iWidth = iWidth + Columns(i).Width        Next        Call setTextBox(Target, iWidth, 6, arr)    ElseIf Target.Address = clsRG.单据日期.MergeArea.Address Then
        Me.TextBox1.Visible = False        Me.TextBox1 = ""        Me.ListBox1.Visible = False        Me.ListBox1.Clear

        Usf_DateSelect.Show
    Else        Me.TextBox1.Visible = False        Me.TextBox1 = ""        Me.ListBox1.Visible = False        Me.ListBox1.Clear
    End If

    '//显示余额    With Me.Label1        If Not Intersect(Target, clsRG.数量) Is Nothing And Target.CountLarge = 1 Then            inventoryCode = Target.Offset(0, -3)            If inventoryCode <> "" Then                currBalance = clsDQ.getBalance(inventoryCode)                .Visible = True                .Caption = Format(currBalance, "0.00")                .Top = Target.Top + 10                .Left = Target.Left + Target.Width            Else                .Visible = False                .Caption = ""
            End If        Else            .Visible = False            .Caption = ""
        End If    End With

End SubPrivate Sub setTextBox(Target As Range, iWidth As Single, iCols As Integer, arr())    Dim iRow As Integer, iCol As Integer
    On Error Resume Next    iRow = UBound(arr)    iCol = UBound(arr, 2)    On Error GoTo 0
    If iCol = 0 Then        arrtemp = Application.WorksheetFunction.Transpose(arr)    Else        ReDim arrtemp(0 To iCol, 0 To iRow)        For i = 0 To iCol            For j = 0 To iRow                arrtemp(i, j) = arr(j, i)            Next        Next    End If    With Me.TextBox1        .Visible = True        .Top = Target.Top + Target.Height        .Left = Target.Left        .Width = Target.Width        .Height = Target.Height        With Me.ListBox1            .Visible = True            .Top = Me.TextBox1.Top + Me.TextBox1.Height            .Left = Me.TextBox1.Left            .Width = iWidth            .ColumnCount = iCols            .List = arrtemp'            .Height = 30 + (.ListCount - 1) * 12'            If .Height > 100 Then'                .Height = 100'            End If        End With    End With
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)    Dim dic As Object    Dim inventoryCode   As String    Set dic = CreateObject("Scripting.Dictionary")
    With ListBox1        If Selection.Address = clsRG.客户名称.MergeArea.Address Then
            clsRG.客户名称 = .List(.ListIndex, 0)            clsRG.联系方式 = .List(.ListIndex, 1)
            clsRG.地址 = .List(.ListIndex, 2)
        ElseIf Selection.Address = clsRG.单据编号.MergeArea.Address Then            clsRG.单据编号 = .List(.ListIndex)        ElseIf Not Intersect(Selection, clsRG.存货编码) Is Nothing Then
            For i = 7 To 16                inventoryCode = Cells(i, 2)                If inventoryCode <> "" And i <> Selection.Row Then                    dic(inventoryCode) = dic(inventoryCode) + 1                End If            Next
            inventoryCode = .List(.ListIndex, 0)            If dic(inventoryCode) > 0 Then                MsgBox "已有存货编码！"                Intersect(Selection.EntireRow, clsRG.数据区域).ClearContents                Exit Sub            End If
            For i = 2 To 6                Cells(Selection.Row, i) = .List(.ListIndex, i - 2)            Next            Cells(Selection.Row, 5).Select        End If    End With    Me.TextBox1.Visible = False    Me.TextBox1 = ""    Me.ListBox1.Visible = False    Me.ListBox1.Clear    'clsRG.数据区域.Cells(1, 2).Select
End Sub
Private Sub TextBox1_Change()    Dim arr(), arrtemp(), sql As String    Dim currRow As Integer    Dim txbValue As String
    'On Error Resume Next    currRow = ActiveCell.Row    txbValue = Me.TextBox1
    If Selection.Address = clsRG.客户名称.MergeArea.Address Then
        sql = "SELECT 客商名称,联系方式,地址 FROM [客商档案$] WHERE 客商名称 LIKE '%" & txbValue & "%' " _            & "OR 联系方式 LIKE '%" & txbValue & "%' " _            & "OR 地址 LIKE '%" & txbValue & "%' " _            & "ORDER BY 客商名称 ASC"
        arr = clsDQ.getData(sql)        Call setListBox(arr)    ElseIf Selection.Address = clsRG.单据编号.MergeArea.Address Then        If shBilling.Range("A3") = "采购入库单" Then            sql = "select distinct 单据编号 from [采购入库$] where 单据编号  LIKE '%" & txbValue & "%' order by 单据编号 DESC"        Else            sql = "select distinct 单据编号 from [销售出库$] where 单据编号  LIKE '%" & txbValue & "%' order by 单据编号 DESC"        End If        arr = clsDQ.getData(sql)        Call setListBox(arr)    ElseIf Not Intersect(Selection, clsRG.存货编码) Is Nothing And Selection.CountLarge = 1 Then        If shBilling.Range("A3") = "采购入库单" Then            sql = "select  distinct 存货编码,存货名称,规格型号,0 as 数量,采购单价 from [存货档案$] WHERE 存货编码 LIKE '%" & txbValue & "%' " _                & "OR 存货名称 LIKE '%" & txbValue & "%' " _                & "OR 规格型号 LIKE '%" & txbValue & "%' order by 存货名称"        Else            sql = "select  distinct 存货编码,存货名称,规格型号,0 as 数量,销售单价 from [存货档案$] WHERE 存货编码 LIKE '%" & txbValue & "%' " _                & "OR 存货名称 LIKE '%" & txbValue & "%' " _                & "OR 规格型号 LIKE '%" & txbValue & "%' order by 存货名称"        End If        arr = clsDQ.getData(sql)        Call setListBox(arr)    End IfEnd SubPrivate Sub setListBox(arr())    Dim iRow As Integer, iCol As Integer, t As Integer    On Error GoTo Er    iRow = UBound(arr)    iCol = UBound(arr, 2)    GoTo PrEr:    t = 1Pr:    If t = 1 Then        arrtemp = Application.WorksheetFunction.Transpose(arr)    Else        ReDim arrtemp(0 To iCol, 0 To iRow)        For i = 0 To iCol            For j = 0 To iRow                arrtemp(i, j) = arr(j, i)            Next        Next    End If    With ListBox1        .Clear        .List = arrtemp'        .Height = 30 + (.ListCount - 1) * 12'        If .Height > 100 Then'            .Height = 100'        End If    End WithEnd Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)    '//检查是否按下了 ESC 键,在textBox中输入时，如果习惯按Esc取消输入法编码，代码会中断    If KeyCode = 27 Then        KeyCode = 0    End IfEnd Sub 

2、在Thisworkbook里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Option Explicit#If VBA7 Then    '64-bit version    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _        ByVal lpWindowName As String) As Long    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long    Private Declare PtrSafe Function MoveWindow Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal x As Long, _        ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long    Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As LongPtr#Else    '32-bit version    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _        ByVal lpWindowName As String) 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 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 Long    Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long#End IfPublic preDate As Date
Private Sub Workbook_BeforeClose(Cancel As Boolean)    Call BackToMain    ThisWorkbook.SaveEnd Sub
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    Dim tm, currValue
    On Error Resume Next    '全选工作表会报错

    If Target.Address = clsRG.单据日期.MergeArea.Address Then        If clsDC.IsFormActive("Usf_DateSelect") Then            Unload Usf_DateSelect
        End If        IsSheetDate = True        With Usf_DateSelect
            tm = currValue            currValue = tm(1, 1)            If currValue <> "" Then                If IsDate(currValue) Then                    .Caption = currValue                    .Controls("CmbYear") = Year(Selection)                    .Controls("CmbMonth") = Month(Selection)                    preDate = currValue                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
    Target.Activate    'IsSheetDate = FalseEnd Sub
Private Sub Workbook_Open()    '//如果有不案例警告，可启用下列代码后重新打开工作表，然后再注释掉    Dim ctrlRegStatus As Integer    Dim ws As Worksheet    ctrlRegStatus = getSetting("控件注册状态")    If ctrlRegStatus <> 1 Then        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 = Nothing        SettingValueRange("控件注册状态").Value = 1    End If    NegativeInventoryRemind = True  '//负库存提醒
    '//删除所有工作表的空白行    For Each ws In ThisWorkbook.Sheets        If ws.Name <> shBilling.Name Then            Call deleteEmptyRows(ws)        End If    NextEnd Sub
Public Sub InventorySetting(ByRef control As Office.IRibbonControl)    Call BackToMain    tableType = "存货档案"    UserForm1.ShowEnd Sub
Public Sub CustomerSetting(ByRef control As Office.IRibbonControl)    Call BackToMain    tableType = "客商档案"    UserForm1.ShowEnd Sub
Public Sub OpeningBalance(ByRef control As Office.IRibbonControl)    Call BackToMain    tableType = "期初库存"    UserForm1.ShowEnd SubPublic Sub InOrder(ByRef control As Office.IRibbonControl)    BillingType = "入库"    shBilling.Visible = xlSheetVisible    shBilling.Activate    shBillingFormat    clsRG.单据日期 = clsDQ.getMaxDate("采购入库")    Call HideOther    Call updateDeliverNumberEnd SubPublic Sub OutOrder(ByRef control As Office.IRibbonControl)    BillingType = "出库"    shBilling.Visible = xlSheetVisible    shBilling.Activate    shBillingFormat    clsRG.单据日期 = clsDQ.getMaxDate("销售出库")    Call HideOther    Call updateDeliverNumber    NegativeInventoryRemind = True  '//负库存提醒End SubPublic Sub InQuery(ByRef control As Office.IRibbonControl)    Call BackToMain    tableType = "采购入库"    UserForm1.ShowEnd SubPublic Sub OutQuery(ByRef control As Office.IRibbonControl)    Call BackToMain    tableType = "销售出库"    UserForm1.ShowEnd SubPublic Sub InventoryQuery(ByRef control As Office.IRibbonControl)    Call BackToMain    UsfQuery.ShowEnd Sub
Public Sub ShowAllTables(ByRef control As Office.IRibbonControl)    Call ShowAllEnd Sub
Public Sub HideOtherTables(ByRef control As Office.IRibbonControl)    Call HideOtherEnd Sub
Public Sub BackToMainSheet(ByRef control As Office.IRibbonControl)    Call BackToMainEnd Sub
Public Sub setItems(ByRef control As Office.IRibbonControl)    Call BackToMain    tableType = "Settings"    UserForm1.ShowEnd Sub 

3、在用户窗体UserForm1里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

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.Enabled = True        Me.CmdAddNew.Enabled = True
    Else        shSettings.Cells(2, 3).Value = "Off"        Me.CmdDelete.Enabled = False        Me.CmdAddNew.Enabled = False
    End IfEnd Sub
Private Sub CmdAddNew_Click()    Dim lastNo As String    Dim lastCol As Integer    Dim currNo As String    Dim Prefix As String    With Me.LvDetail        If .ListItems.count = 0 Then
            If tableType = "存货档案" Then                Prefix = "CH"            ElseIf tableType = "客商档案" Then                Prefix = "KS"            ElseIf tableType = "Settings" Then                Prefix = "ST"            End If            currNo = Prefix & "000000"        Else            currNo = .ListItems(.ListItems.count).Text        End If        lastNo = Left(currNo, 2) & Format(Right(currNo, Len(currNo) - 2) + 1, "000000")        lastCol = .ColumnHeaders.count
        Set lvItem = .ListItems.Add
        With lvItem            .Text = lastNo            wsData.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                wsData.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
    On Error Resume Next    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.Enabled = True        Me.CmdAddNew.Enabled = True    Else        Me.CheckBox1.Value = False        Me.CmdDelete.Enabled = False        Me.CmdAddNew.Enabled = False    End If
    Me.CmdSelectAll.ForeColor = vbRed
    Call LoadData

    '//设置ListView
    With Me.LvDetail
        '//ListView的基本设置        .View = lvwReport        .Gridlines = True        .Sorted = False        .CheckBoxes = True        .LabelEdit = lvwManual        .FullRowSelect = True
        '//添加表头        'shQuery.Rows(2).Clear        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
            ''//查询结果表表头            'With shQuery            '.Cells(2, i) = arrData(1, i)            '.Cells(2, i).Borders.LineStyle = 1            'End With        Next
        '//添加数据        For i = 2 To UBound(arrData)            If arrData(i, 1) <> "" Then                If tableType = "采购入库" Or tableType = "销售出库" Or tableType = "期初库存" Then                    total = total + arrData(i, totalCol)                End If                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            End If        Next    End With    With Me.LbSum        If tableType = "采购入库" Or tableType = "销售出库" Or tableType = "期初库存" Then            .Caption = "金额合计：" & Format(total, "Standard")            '.Left = Me.LvDetail.ColumnHeaders(totalCol).Left - .Width + Me.LvDetail.ColumnHeaders(totalCol).Width        Else            .Visible = False        End If
    End With
    Me.Caption = tableType    If InStr("客商档案/存货档案/Settings/期初库存", tableType) > 0 Then        Me.LbName.Caption = "关键字："        Me.CmbMonth.Visible = False        Me.CmbName.Visible = False        Me.LbMonth.Visible = False        With Me.TxbKeyWords            .Visible = True            .Left = Me.LbName.Left + Me.LbName.Width + 10            .Width = 150            Me.CmdQuery.Left = .Left + .Width + 20        End With
    End If
    '根据指定字段转化可编辑列、必填列    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                'wsdata.Cells(getRow(.SelectedItem.Text), colIndex) = currValue   '这是根据第一列序号来确定工作表的行号
                '//加载数据到数组arrData时，多增加一列，写入行号，据以更新数据                wsData.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    Dim keyWords As String    Dim strWhole As String    currName = Me.CmbName    currMonth = Me.CmbMonth    total = 0    keyWords = Me.TxbKeyWords    With Me.LvDetail        .ListItems.Clear        If InStr("客商档案/存货档案/Settings/期初库存", tableType) > 0 Then            For i = 2 To UBound(arrData)
                strWhole = ""                For j = 1 To UBound(arrData, 2)                    strWhole = strWhole & arrData(i, j) & "|"                Next                If InStr(strWhole, keyWords) > 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                End If
            Next        Else            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 If

    End With    Me.LbSum = "金额合计：" & Format(total, "Standard")
End Sub
Private Sub CmdOutput_Click()
    Call outPutListView(Me.LvDetail, shQuery)End 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    Dim ws As Worksheet    Set dicName = CreateObject("Scripting.Dictionary")    Set dicMonth = CreateObject("Scripting.Dictionary")
    keyWord = "序号"    If tableType = "采购入库" Then        Set wsData = shInOrder        With Me.CheckBox1            .Value = False            .Enabled = False        End With        Me.CmdAddNew.Enabled = False
    ElseIf tableType = "销售出库" Then        Set wsData = shOutOrder        With Me.CheckBox1            .Value = False            .Enabled = False        End With
        Me.CmdAddNew.Enabled = False
    ElseIf tableType = "客商档案" Then        Set wsData = shCusSup    ElseIf tableType = "存货档案" Then        Set wsData = shInventory    ElseIf tableType = "Settings" Then        Set wsData = shSettings    ElseIf tableType = "期初库存" Then        Set wsData = shOpening        With Me.CheckBox1            .Value = False            .Enabled = False        End With        Me.CmdAddNew.Enabled = False    End If

    With wsData        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) = "客户名称" Or 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)) = ""    NextEnd Sub 

4、在用户窗体UserForm2里（这个窗体暂时没有用到，但在InkEdit控件的事件中有启动此窗体的代码，所以暂时保留，以后也许有用）：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

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    On Error Resume Next
    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 

5、在用户窗体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 preDate    Me.Caption = preDate    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 

6、在用户窗体UsfQuery里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Option ExplicitDim clsDQ As New DataQueryDim i As Long, j As Long, k As LongDim lvItem As ListItemDim lastRow As Long, lastCol As Long
Private Sub CmbBeginMonth_Change()    If Me.CmbBeginMonth.Text > Me.CmbEndMonth Then        Me.CmbEndMonth = Me.CmbBeginMonth    End IfEnd Sub
Private Sub CmbEndMonth_Change()    If Me.CmbEndMonth < Me.CmbBeginMonth Then        Me.CmbBeginMonth = Me.CmbEndMonth    End IfEnd Sub
Private Sub CmdExit_Click()    Unload MeEnd Sub
Private Sub CmdOutput_Click()
    Call outPutListView(Me.LvDetail, shQuery)
End Sub
Private Sub CmdQuery_Click()    Dim sql As String, sqlA As String, sqlB As String, sqlC As String, sqlD As String    Dim beginMonth As String, endMonth As String    Dim bookYear As String    Dim arrData(), temp    bookYear = getSetting("当前年度")    beginMonth = Me.CmbBeginMonth    endMonth = Me.CmbEndMonth
    If beginMonth = "" Then        beginMonth = bookYear & "01"    End If    If endMonth = "" Then        endMonth = bookYear & "12"    End If    '//期初    sqlA = "select 存货编码,存货名称,规格型号, " _        & "sum(数量) as 期初数量, sum(金额) as 期初金额, " _        & "0 as 收入数量,0 as 收入金额, " _        & "0 as 发出数量,0 as 发出金额, " _        & "sum(数量) as 结存数量, 0 as 结存金额 " _        & "from [期初库存$] group by 存货编码,存货名称,规格型号 order by 存货编码"
    '//收入    sqlB = "SELECT 存货编码, 存货名称, 规格型号, " & _        "0 AS 期初数量, " & _        "0 AS 期初金额, " & _        "SUM(IIF(FORMAT(单据日期, 'yyyymm') < " & beginMonth & ", 数量, 0)) AS 收入数量, " & _        "SUM(IIF(FORMAT(单据日期, 'yyyymm') < " & beginMonth & ", 金额, 0)) AS 收入金额, " & _        "0 AS 发出数量, 0 AS 发出金额, " & _        "SUM(IIF(FORMAT(单据日期, 'yyyymm') < " & beginMonth & ", 数量, 0)) AS 结存数量, " & _        "0 AS 结存金额 " & _        "FROM [采购入库$] " & _        "GROUP BY 存货编码, 存货名称, 规格型号 " & _        "ORDER BY 存货编码"    'temp = clsDQ.getData(sqlB)    '//发出    sqlC = "select 存货编码,存货名称,规格型号, " _        & "0 as 期初数量, 0 as 期初金额, " _        & "0 as 收入数量,0 as 收入金额, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') < " & beginMonth & ", 数量, 0)) AS 发出数量, " _        & "0 as 发出金额, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') < " & beginMonth & ", 数量, 0))*(-1) as 结存数量, 0 as 结存金额 " _        & "from [销售出库$] group by 存货编码,存货名称,规格型号 order by 存货编码"
    sql = sqlA & " UNION ALL " & sqlB & " UNION ALL " & sqlC    'temp = clsDQ.getData(sql)    sql = "Select 存货编码,存货名称,规格型号," _        & "sum(期初数量) as 期初数量, " _        & "sum(期初金额) as 期初金额, " _        & "sum(收入数量) as 收入数量, " _        & "sum(收入金额) as 收入金额, " _        & "sum(发出数量) as 发出数量, " _        & "iif(sum(期初数量)+sum(收入数量)=0,0,round(sum(发出数量)*(sum(期初金额)+sum(收入金额))/(sum(期初数量)+sum(收入数量)),2)) as 发出金额, " _        & "sum(期初数量)+sum(收入数量)-sum(发出数量) as 结存数量, " _        & "iif(sum(期初数量)+sum(收入数量)=0,0,round((sum(期初数量)+sum(收入数量)-sum(发出数量))*(sum(期初金额)+sum(收入金额))/(sum(期初数量)+sum(收入数量)),2)) as 结存金额 " _        & "from (" & sql & ") as a where isNull(存货编码)=FALSE group by 存货编码,存货名称,规格型号 order by 存货编码"
'    temp = clsDQ.getData(sql)

    '//新的期初'    Dim SQL1 As String, SQL2 As String, SQL3 As String, SQL4 As String    sqlA = "select 存货编码,存货名称,规格型号, " _        & "结存数量 as 期初数量, 结存金额 as 期初金额, " _        & "0 as 收入数量,0 as 收入金额, " _        & "0 as 发出数量,0 as 发出金额, " _        & "结存数量 , 结存金额 " _        & "from (" & sql & ") as b "
'    temp = clsDQ.getData(SQL1)
    '//新收入    sqlB = "select 存货编码,存货名称,规格型号, " _        & "0 as 期初数量, 0 as 期初金额, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') >= " & beginMonth & " AND FORMAT(单据日期, 'yyyymm') <= " & endMonth & ", 数量, 0)) AS 收入数量, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') >= " & beginMonth & " AND FORMAT(单据日期, 'yyyymm') <= " & endMonth & ", 金额, 0)) AS 收入金额, " _        & "0 as 发出数量,0 as 发出金额, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') >= " & beginMonth & " AND FORMAT(单据日期, 'yyyymm') <= " & endMonth & ", 数量, 0)) AS 结存数量, " _        & "0 as 结存金额 " _        & "from [采购入库$] group by 存货编码,存货名称,规格型号 "
'    temp = clsDQ.getData(SQL2)
    '//新发出    sqlC = "select 存货编码,存货名称,规格型号, " _        & "0 as 期初数量, 0 as 期初金额, " _        & "0 as 收入数量,0 as 收入金额, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') >= " & beginMonth & " AND FORMAT(单据日期, 'yyyymm') <= " & endMonth & ", 数量, 0)) AS 发出数量, " _        & "0 as 发出金额, " _        & "SUM(IIF(FORMAT(单据日期, 'yyyymm') >= " & beginMonth & " AND FORMAT(单据日期, 'yyyymm') <= " & endMonth & ", 数量, 0))*(-1) as 结存数量, 0 as 结存金额 " _        & "from [销售出库$] group by 存货编码,存货名称,规格型号 "
'    temp = clsDQ.getData(SQL3)
    sql = sqlA & " UNION ALL " & sqlB & " UNION ALL " & sqlC

    sql = "Select 存货编码,存货名称,规格型号," _        & "sum(期初数量) as 期初数量, " _        & "sum(期初金额) as 期初金额, " _        & "sum(收入数量) as 收入数量, " _        & "sum(收入金额) as 收入金额, " _        & "sum(发出数量) as 发出数量, " _        & "round(sum(发出数量)*(sum(期初金额)+sum(收入金额))/(sum(期初数量)+sum(收入数量)),2) as 发出金额, " _        & "sum(期初数量)+sum(收入数量)-sum(发出数量) as 结存数量, " _        & "round((sum(期初数量)+sum(收入数量)-sum(发出数量))*(sum(期初金额)+sum(收入金额))/(sum(期初数量)+sum(收入数量)),2) as 结存金额 " _        & "from (" & sql & ") as c where isNull(存货编码)=FALSE group by 存货编码,存货名称,规格型号 order by 存货编码"

'    temp = clsDQ.getData(sql)
    'Debug.Print sql    With Me.LvDetail        .ListItems.Clear        ''//添加数据        temp = clsDQ.getData("Select count(*) from (" & sql & ")")        If temp(0, 0) > 0 Then            arrData = clsDQ.getData(sql)        Else            Exit Sub
        End If
        For i = 0 To UBound(arrData, 2)            Set lvItem = .ListItems.Add            With lvItem                .Text = arrData(0, i)                For j = 1 To UBound(arrData)                    .SubItems(j) = IIf(IsNull(arrData(j, i)), 0, Format(arrData(j, i), "0.00"))                Next            End With        Next        Call addSumLine(Me.LvDetail)    End With
End Sub
Private Sub UserForm_Initialize()    Dim sql As String, sqlA As String, sqlB As String, sqlC As String, sqlD As String    Dim arrData(), tbTitle(), arrWidth, temp()    Dim sqlCount As String    Dim currYear As String    Dim maxMonth As Integer, maxDate As Date'    On Error Resume Next
    tbTitle = Array("存货编码", "存货名称", "规格型号", "期初数量", "期初金额", "收入数量", "收入金额", "发出数量", "发出金额", "结存数量", "结存金额")    arrWidth = Array(60, 100, 80, 60, 80, 60, 80, 60, 80, 60, 80)

    '//期初    sqlA = "select 存货编码,存货名称,规格型号, " _        & "sum(数量) as 期初数量, sum(金额) as 期初金额, " _        & "0 as 收入数量,0 as 收入金额, " _        & "0 as 发出数量,0 as 发出金额, " _        & "sum(数量) as 结存数量, 0 as 结存金额 " _        & "from [期初库存$] group by 存货编码,存货名称,规格型号 order by 存货编码"
    '//收入    sqlB = "select 存货编码,存货名称,规格型号, " _        & "0 as 期初数量, 0 as 期初金额, " _        & "sum(数量) as 收入数量,sum(金额) as 收入金额, " _        & "0 as 发出数量,0 as 发出金额, " _        & "sum(数量) as 结存数量, 0 as 结存金额 " _        & "from [采购入库$] group by 存货编码,存货名称,规格型号 order by 存货编码"
    '//发出    sqlC = "select 存货编码,存货名称,规格型号, " _        & "0 as 期初数量, 0 as 期初金额, " _        & "0 as 收入数量,0 as 收入金额, " _        & "sum(数量) as 发出数量,0 as 发出金额, " _        & "sum(数量)*(-1) as 结存数量, 0 as 结存金额 " _        & "from [销售出库$] group by 存货编码,存货名称,规格型号 order by 存货编码"
    sql = sqlA & " UNION ALL " & sqlB & " UNION ALL " & sqlC
    sql = "Select 存货编码,存货名称,规格型号," _        & "sum(期初数量) as 期初数量, " _        & "sum(期初金额) as 期初金额, " _        & "sum(收入数量) as 收入数量, " _        & "sum(收入金额) as 收入金额, " _        & "sum(发出数量) as 发出数量, " _        & "round(sum(发出数量)*(sum(期初金额)+sum(收入金额))/(sum(期初数量)+sum(收入数量)),2) as 发出金额, " _        & "sum(期初数量)+sum(收入数量)-sum(发出数量) as 结存数量, " _        & "round((sum(期初数量)+sum(收入数量)-sum(发出数量))*(sum(期初金额)+sum(收入金额))/(sum(期初数量)+sum(收入数量)),2) as 结存金额 " _        & "from (" & sql & ") where isNull(存货编码)=FALSE group by 存货编码,存货名称,规格型号 order by 存货编码"    'lastCol = UBound(tbTitle) - LBound(tbTitle) + 1
    With Me.LvDetail
        '//ListView的基本设置        .View = lvwReport        .Gridlines = True        .Sorted = False        .CheckBoxes = True        .LabelEdit = lvwManual        .FullRowSelect = True
        '//添加表头
        For i = LBound(tbTitle) To UBound(tbTitle)            If InStr(tbTitle(i), "数量") > 0 Or InStr(tbTitle(i), "金额") > 0 Then                .ColumnHeaders.Add , , tbTitle(i), arrWidth(i), lvwColumnRight            Else                .ColumnHeaders.Add , , tbTitle(i), arrWidth(i)            End If            '        Next
        ''//添加数据        If clsDQ.getData("Select count(*) from (" & sql & ")")(0, 0) > 0 Then            arrData = clsDQ.getData(sql)        Else            Exit Sub
        End If
        For i = 0 To UBound(arrData, 2)            Set lvItem = .ListItems.Add            With lvItem                .Text = arrData(0, i)                For j = 1 To UBound(arrData)                    .SubItems(j) = IIf(IsNull(arrData(j, i)), 0, Format(arrData(j, i), "0.00"))                Next            End With        Next        Call addSumLine(Me.LvDetail)    End With
    currYear = getSetting("当前年度")    maxDate = Application.Max(clsDQ.getMaxDate("采购入库"), clsDQ.getMaxDate("销售出库"))    maxMonth = Month(maxDate)    ReDim temp(1 To maxMonth)    For i = 1 To maxMonth        temp(i) = currYear & Format(i, "00")    Next    Me.CmbBeginMonth.List = temp    Me.CmbEndMonth.List = temp
End Sub
Private Sub addSumLine(lv As ListView, Optional colHeaders As String = "数量/金额/余额")    If lv.ListItems.count = 0 Then Exit Sub    Dim lvItem As ListItem, currCol As Integer    Dim temp, currSum As Double    Dim m As Long    temp = Split(colHeaders, "/")    Set lvItem = lv.ListItems.Add    lvItem.Text = "合计"    lvItem.ForeColor = vbRed    For i = 1 To lv.ColumnHeaders.count        For j = 0 To UBound(temp)            If InStr(lv.ColumnHeaders(i), temp(j)) > 0 Then                currSum = 0                For m = 1 To lv.ListItems.count                    currSum = currSum + Val(lv.ListItems(m).SubItems(i - 1))                Next                lvItem.SubItems(i - 1) = Format(currSum, "0.00")                lvItem.ListSubItems(i - 1).ForeColor = vbRed            End If        Next    NextEnd Sub 

7、在myModule1里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

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   '//wsdata表的最后第一个空白行，用于更新Public BillingType  '//出入库类型-“出库”或“入库”Public tableType   '//表格类型Public wsData As Worksheet   '//Listview处理的数据表格Public NegativeInventoryRemind As Boolean   '//负库存提醒

'窗口过程函数#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
Sub shBillingFormat()    With shBilling        If BillingType = "入库" Then            .Range("A3") = "采购入库单"            .Range("A4") = "供应商名称:"            .Range("A5") = "发货地址:"            .Range("J6") = "白（存根）红（客户）蓝（财务）黄（采购）"            .Range("A6:I6").Interior.Color = RGB(255, 165, 0)            .Range("A17:I17").Interior.Color = RGB(255, 165, 0)            .CmdSwitch.BackColor = RGB(255, 165, 0)        ElseIf BillingType = "出库" Then            .Range("A3") = "销售出库单"            .Range("A4") = "客户名称:"            .Range("A5") = "收货地址:"            .Range("J6") = "白（存根）红（供应商）蓝（财务）黄（销售）"            .Range("A6:I6").Interior.Color = RGB(15, 158, 213)            .Range("A17:I17").Interior.Color = RGB(15, 158, 213)            .CmdSwitch.BackColor = RGB(15, 158, 213)        End If    End WithEnd Sub 

8、在myModule2里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Option ExplicitPublic clsDQ As New DataQueryPublic clsRG As New clsRangesPublic dbs As String, tbl As StringPublic blnUpdateDeliverNumber As BooleanPublic processType As StringDim sql As String
Function GetExtn(iName)    '//取得文件扩展名    GetExtn = Right(iName, Len(iName) - InStrRev(iName, ".") + 1)End Function
Sub updateDeliverNumber()    Dim ws As Worksheet    Dim DeliverNumber As String    Dim strDate As String    Dim Prefix As String    Set ws = ThisWorkbook.Sheets("单据录入")    With ws        strDate = Format(clsRG.单据日期, "yyyymmdd")        DeliverNumber = clsDQ.getMaxDeliverNumber(strDate)        If shBilling.Range("A3") = "采购入库单" Then             Prefix = "RK" & strDate        Else            Prefix = "CK" & strDate        End If
        If InStr(DeliverNumber, Prefix) > 0 Then            DeliverNumber = Prefix & Format(Val(Right(DeliverNumber, 2)) + 1, "00")        Else            DeliverNumber = Prefix & "01"        End If        clsRG.单据编号 = DeliverNumber    End WithEnd Sub
Sub saveNew()    Dim DeliverNumber As String    Dim strCnn As String    Dim cnn As Object, rs As Object    Dim arr(), ws As Worksheet, lastRow As Integer, lastCol As Integer    Dim supplier As String, category As String, employee As String    Dim warehouse As String, currDate As Date    Dim serialNumber As String    Dim rng As Range, cell As Range    Dim Prefix As String    Dim i As Long, j As Long, t As Integer    Dim strZero As String    dbs = ThisWorkbook.FullName    If shBilling.Range("A3") = "采购入库单" Then        tbl = "[采购入库$]"    Else        tbl = "[销售出库$]"    End If    Set ws = ThisWorkbook.Sheets("单据录入")    With ws        DeliverNumber = clsRG.单据编号        '//检查单据号是否存在，如果存在则提示、退出        '//如果数据无误，可修改单号后保存（这种情况一般不会出现）        If processType = "新增保存" Then            If clsDQ.IsDeliverNumberExists(DeliverNumber) Then                MsgBox "已存在单据号！请检查！"                Exit Sub            End If        End If    End With    '//数据完整性检查，表头字段不为空    If Not IsDate(clsRG.单据日期) Then        MsgBox "单据日期错误！"        Exit Sub    ElseIf clsRG.客户名称 = "" Then        MsgBox "客户为空！"        Exit Sub    ElseIf clsRG.单据编号 = "" Then        MsgBox "单据编号为空！"        Exit Sub
    End If
    '//检查单据号与单据日期是否一致    If shBilling.Range("A3") = "采购入库单" Then        Prefix = "RK" & Format(clsRG.单据日期, "yyyymmdd")
    Else        Prefix = "CK" & Format(clsRG.单据日期, "yyyymmdd")
    End If    If InStr(DeliverNumber, Prefix) = 0 Then        MsgBox "单据号有误，请更新单据号后再保存！"        Exit Sub    End If
    '//检查流水号    For i = 1 To clsRG.序号.Rows.count        If clsRG.序号.Cells(i, 1) > 0 Then            serialNumber = clsRG.单据编号 & Format(clsRG.序号.Cells(i, 1), "00")            If clsRG.流水号.Cells(i, 1) <> serialNumber Then                If Not wContinue("流水号有误，自动更新？") Then Exit Sub                t = 1                Exit For            End If        End If    Next    '//根据单据编号与序号重写流水号    If t = 1 Then        For i = 1 To clsRG.序号.Rows.count            If clsRG.序号.Cells(i, 1) > 0 Then                clsRG.流水号.Cells(i, 1) = clsRG.单据编号 & Format(clsRG.序号.Cells(i, 1), "00")            End If        Next    End If
    For i = 1 To clsRG.数量.Rows.count        If clsRG.数量.Cells(i, 1) = 0 Then            If clsRG.存货编码.Cells(i, 1) <> "" Then                strZero = strZero & i & "/"            End If        End If    Next    t = Len(strZero)    If t > 0 Then        strZero = Left(strZero, t - 1)        If Not wContinue("以下数据行数量为0,继续保存吗？" & Chr(10) & strZero) Then Exit Sub    End If
    Set rng = clsRG.数据区域    If processType = "新增保存" Then        Set cnn = CreateObject("ADODB.Connection")        Set rs = CreateObject("ADODB.Recordset")        strCnn = clsDQ.GetStrCnn(dbs)        cnn.Open strCnn        With rs            .Open tbl, cnn, 1, 3            For i = 1 To rng.Rows.count                If rng.Cells(i, 1) > 0 Then                    .addNew                    .Fields("单据日期") = clsRG.单据日期                    .Fields("单据编号") = clsRG.单据编号                    If shBilling.Range("A3") = "采购入库单" Then                        .Fields("供应商名称") = clsRG.客户名称                    Else                        .Fields("客户名称") = clsRG.客户名称                    End If                    .Fields("联系方式") = clsRG.联系方式                    .Fields("地址") = clsRG.地址                    For j = 2 To rng.Columns.count                        .Fields(CStr(clsRG.表头.Cells(1, j).Value)) = rng.Cells(i, j)                    Next                    .Update                End If            Next        End With        cnn.Close        Set cnn = Nothing        Set rs = Nothing    ElseIf processType = "更新保存" Then        For i = 1 To rng.Rows.count            If rng.Cells(i, 1) > 0 Then                serialNumber = clsRG.流水号.Cells(i, 1)                If shBilling.Range("A3") = "采购入库单" Then                    sql = "UPDATE [采购入库$] " & _                        "SET 供应商名称 = '" & clsRG.客户名称 & "', " & _                        "联系方式 = '" & clsRG.联系方式 & "', " & _                        "地址 = '" & clsRG.地址 & "', " & _                        "存货编码 = '" & rng.Cells(i, 2) & "', " & _                        "存货名称 = '" & rng.Cells(i, 3) & "', " & _                        "规格型号     = '" & rng.Cells(i, 4) & "', " & _                        "数量 = '" & rng.Cells(i, 5) & "', " & _                        "单价 = '" & rng.Cells(i, 6) & "', " & _                        "金额 = '" & rng.Cells(i, 7) & "', " & _                        "备注 = '" & rng.Cells(i, 8) & "' " & _                        "WHERE 流水号 = '" & serialNumber & "'"                Else                    sql = "UPDATE [销售出库$] " & _                        "SET 客户名称 = '" & clsRG.客户名称 & "', " & _                        "联系方式 = '" & clsRG.联系方式 & "', " & _                        "地址 = '" & clsRG.地址 & "', " & _                        "存货编码 = '" & rng.Cells(i, 2) & "', " & _                        "存货名称 = '" & rng.Cells(i, 3) & "', " & _                        "规格型号     = '" & rng.Cells(i, 4) & "', " & _                        "数量 = '" & rng.Cells(i, 5) & "', " & _                        "单价 = '" & rng.Cells(i, 6) & "', " & _                        "金额 = '" & rng.Cells(i, 7) & "', " & _                        "备注 = '" & rng.Cells(i, 8) & "' " & _                        "WHERE 流水号 = '" & serialNumber & "'"                End If                clsDQ.ExecuteSQL (sql)            End If        Next    End If    ThisWorkbook.Save
    Call clsRG.clearData    Call updateDeliverNumber    MsgBox "保存成功！"End Sub
Sub printWorksheet(rng As Range)    Dim ws As Worksheet, lastRow As Integer, lastCol As Integer    If Not Application.Dialogs(xlDialogPrinterSetup).Show Then Exit Sub    Set ws = rng.Parent    With ws'        lastRow = 20'        lastCol = 12'        Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))        With .PageSetup            .PrintArea = rng.Address            .PaperSize = xlPaperA4            .Orientation = xlPortrait            .FitToPagesWide = 1            .FitToPagesTall = 1        End With        .PrintOut copies:=1    End WithEnd Sub
Function IsArrEmpty(ByVal sArray As Variant) As Boolean    '//判断数组是否为空    Dim i As Long    IsArrEmpty = False    On Error GoTo lerr:    i = UBound(sArray)    Exit Functionlerr:    IsArrEmpty = TrueEnd Function

Sub BackToMain()    '//显示“Main”，隐藏其他工作表    Dim ws As Worksheet    On Error Resume Next    shMain.Visible = xlSheetVisible    shMain.Activate    For Each ws In Excel.ThisWorkbook.Worksheets        If ws.Name <> shMain.Name Then            ws.Visible = xlSheetVeryHidden        End If    NextEnd Sub
Sub ShowAll()    '//显示所有工作表    Dim ws As Worksheet    For Each ws In ThisWorkbook.Sheets        ws.Visible = xlSheetVisible    Next    shMain.ActivateEnd Sub
Sub HideOther()    '//隐藏其他工作表    Dim ws As Worksheet    For Each ws In ThisWorkbook.Sheets        If ws.Name <> ActiveSheet.Name Then            ws.Visible = xlSheetVeryHidden        End If    NextEnd Sub
Function getSetting(settingItem As String)    '//查找值    Dim temp    temp = Application.VLookup(settingItem, shSettings.Range("B:C"), 2, 0)    getSetting = IIf(IsError(temp), "", temp)End Function
Function SettingValueRange(settingItem As String) As Range    '//取得对应项目的值所在单元格    Dim rng As Range, cell As Range    Set rng = shSettings.UsedRange    For Each cell In rng.Columns(2).Cells        If CStr(cell.Value) = settingItem Then            Set SettingValueRange = cell.Offset(0, 1)            Exit Function        End If    NextEnd FunctionSub outPutListView(lv As ListView, ws As Worksheet)    Dim lastRow As Long, lastCol As Long    Dim arr(), i As Long, j As Long    Dim rng As Range    With lv        If .ListItems.count = 0 Then Exit Sub        lastRow = .ListItems.count        lastCol = .ColumnHeaders.count        ReDim arr(1 To lastRow + 1, 1 To lastCol)        For i = 1 To lastCol            arr(1, i) = .ColumnHeaders(i)        Next        For i = 1 To lastRow            arr(i + 1, 1) = .ListItems(i).Text            For j = 2 To lastCol                arr(i + 1, j) = .ListItems(i).SubItems(j - 1)            Next        Next    End With    With ws        lastRow = .UsedRange.Rows.count        lastCol = .UsedRange.Columns.count        If lastRow > 1 Then            .Range(.Cells(2, 1), .Cells(lastRow, lastCol)).Clear        End If        Set rng = .Cells(2, 1).Resize(UBound(arr), UBound(arr, 2))        With rng            .Value = arr            .Borders.LineStyle = 1            Call setNumFormats(rng)        End With        .Visible = xlSheetVisible        .Activate        .Cells(1, 1) = Replace(lv.Parent.Caption, "查询", "") & "查询结果"        Call HideOther    End With    Unload lv.Parent
End Sub
Sub setNumFormats(rng As Range)    Dim i As Long, j As Long    With rng        For i = 1 To .Columns.count            If InStr(.Cells(1, i), "数量") > 0 Or InStr(.Cells(1, i), "单价") > 0 Or InStr(.Cells(1, i), "金额") > 0 Then                .Cells(2, i).Resize(.Rows.count - 1, 1).NumberFormat = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ "            End If        Next    End With
End SubSub deleteEmptyRows(ws As Worksheet)    Dim lastRow As Long, endRow As Long    Dim lastCol As Long    Dim i As Long, j As Long    Dim emptyCells As Integer    With ws        lastRow = .Cells(.Rows.count, 1).End(xlUp).Row        endRow = .UsedRange.Rows.count        lastRow = Application.Max(lastRow, endRow)        lastCol = .Cells(1, .Columns.count).End(xlToLeft).Column        If lastRow > 1 And lastCol > 1 Then            For i = lastRow To 2 Step -1                emptyCells = 0                For j = 1 To lastCol                    If .Cells(i, j) = "" Then                        emptyCells = emptyCells + 1                    End If                Next
                '//空白单元格超过一半，认定为空白行                If emptyCells / lastCol > 0.5 Then                    .Rows(i).Delete                End If            Next        End If    End WithEnd Sub 

9、在类模块clsRanges里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Private ws As WorksheetPrivate Sub Class_Initialize()    Set ws = ThisWorkbook.Worksheets("单据录入")End Sub
Public Property Get 单据日期() As Range    Set 单据日期 = ws.Range("H5")End PropertyPublic Property Get 单据编号() As Range    Set 单据编号 = ws.Range("H4")End Property
Public Property Get 客户名称() As Range    Set 客户名称 = ws.Range("B4")End Property
Public Property Get 联系方式() As Range    Set 联系方式 = ws.Range("E5")End Property
Public Property Get 地址() As Range    Set 地址 = ws.Range("B5")End PropertyPublic Property Get 数量() As Range    Set 数量 = ws.Range("E7:E16")End Property
Public Property Get 单价() As Range    Set 单价 = ws.Range("F7:F16")End Property
Public Property Get 数量合计() As Range    Set 数量合计 = ws.Range("E17")End Property
Public Property Get 金额() As Range    Set 金额 = ws.Range("G7:G16")End PropertyPublic Property Get 金额合计() As Range    Set 金额合计 = ws.Range("G17")End Property
Public Property Get 数据区域() As Range    Set 数据区域 = ws.Range("A7:I16")End Property
Public Property Get 存货编码() As Range    Set 存货编码 = ws.Range("B7:B16")End PropertyPublic Property Get 序号() As Range    Set 序号 = ws.Range("A7:A16")End Property
Public Property Get 流水号() As Range    Set 流水号 = ws.Range("I7:I16")End Property
Public Property Get 表头() As Range    Set 表头 = ws.Range("A6:I6")End Property
Public Property Get 打印区域() As Range    Set 打印区域 = ws.Range("A1:J20")End Property
Public Sub clearData()    客户名称 = ""    地址 = ""    联系方式 = ""    数据区域.ClearContents    数量合计 = 0    金额合计 = 0End Sub 

10、在类模块DataQuery里：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

Dim strCnn As StringDim cnn As Object                '数据库连接Dim rs As Object  '临时数据表纪录Function GetStrCnn(ByVal DbFile As String, Optional ByVal Psw As String = "")    '//获取数据库连接字符串    Dim sType$    sType = GetExtn(DbFile)    If InStr(sType, "accdb") Then        Select Case Application.Version * 1      '设置连接字符串,根据版本创建连接        Case Is <= 11            GetStrCnn = "Provider=Microsoft.Jet.Oledb.4.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile        Case Is >= 12            GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile        End Select    ElseIf InStr(sType, "xl") Then        GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & DbFile    End IfEnd Function
Sub ExecuteSQL(sql As String)    '//执行SQL语句'    On Error Resume Next    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    dbs = ThisWorkbook.FullName    strCnn = GetStrCnn(dbs, Psw)    cnn.Open strCnn    '打开数据库链接    cnn.Execute (sql)    cnn.Close    Set cnn = NothingEnd Sub
Function RecordValue(sql)    '函数名的含义为“记录值”，实际为取到的第一行第一列的值    '通常用来 select count() 来取值，这样，函数的值或为0,或大于0,如果值为0,则表示没有记录    '可以用来判断一个表有没有记录，或者有没有指定字段符合一定条件的记录    On Error Resume Next    Dim arr()    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    On Error Resume Next    dbs = ThisWorkbook.FullName    strCnn = GetStrCnn(dbs, Psw)    cnn.Open strCnn                              '打开数据库链接    Set rs = cnn.Execute(sql)                    '执行查询，并将结果输出到记录集对象    arr = rs.getrows    RecordValue = arr(0, 0)    rs.Close    Set rs = Nothing    cnn.Close    Set cnn = NothingEnd Function
Function getData(sql)    '//获取查询结果，存到数组
    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    On Error Resume Next    dbs = ThisWorkbook.FullName    strCnn = GetStrCnn(dbs, Psw)    cnn.Open strCnn    '打开数据库链接    Set rs = cnn.Execute(sql)  '执行查询，并将结果输出到记录集对象    getData = rs.getrows    rs.Close    Set rs = Nothing    cnn.Close    Set cnn = NothingEnd Function
Function IsDeliverNumberExists(DeliverNumber As String) As Boolean    '//判断单据编号是否存在于“数据”    Dim tbl As String, sql As String    Dim arr()    If shBilling.Range("A3") = "采购入库单" Then        tbl = "[采购入库$]"    Else        tbl = "[销售出库$]"    End If
    sql = "select count(*) from " & tbl & " where 单据编号='" & DeliverNumber & "'"
    arr = getData(sql)    If arr(0, 0) > 0 Then        IsDeliverNumberExists = True    Else        IsDeliverNumberExists = False    End IfEnd Function
Function getMaxDeliverNumber(strDate As String) As String    '//取得当前单据日期最大的付款单号    On Error Resume Next    Dim tbl As String, sql As String    Dim arr()    If shBilling.Range("A3") = "采购入库单" Then        tbl = "[采购入库$]"    Else        tbl = "[销售出库$]"    End If    sql = "select top 1 单据编号  from " & tbl & " where format(单据日期 ,'yyyymmdd') ='" & strDate & "' order by 单据编号 DESC"    arr = getData(sql)    getMaxDeliverNumber = arr(0, 0)End Function
Function IsSerialNumberExists(serialNumber As String) As Boolean
    '//判断流水号是否存在于“数据”    Dim tbl As String, sql As String    Dim arr()    If shBilling.Range("A3") = "采购入库单" Then        tbl = "[采购入库$]"    Else        tbl = "[销售出库$]"    End If
    sql = "select count(*) from " & tbl & " where 流水号='" & serialNumber & "'"
    arr = getData(sql)    If arr(0, 0) > 0 Then        IsSerialNumberExists = True    Else        IsSerialNumberExists = False    End IfEnd Function
Function getBalance(inventoryCode As String) As Double    Dim OpeningBalance As Double    Dim inBalance As Double    Dim outBalance As Double    Dim arr()
    '//期初库存    sql = "select sum(数量) from [期初库存$] Where 存货编码='" & inventoryCode & " '"    arr = getData(sql)    OpeningBalance = IIf(IsNull(arr(0, 0)), 0, arr(0, 0))
    '//本期入库    sql = "select sum(数量) from [采购入库$] Where 存货编码='" & inventoryCode & " '"    arr = getData(sql)    inBalance = IIf(IsNull(arr(0, 0)), 0, arr(0, 0))
    '//本期出库    sql = "select sum(数量) from [销售出库$] Where 存货编码='" & inventoryCode & " '"    arr = getData(sql)    outBalance = IIf(IsNull(arr(0, 0)), 0, arr(0, 0))
    getBalance = OpeningBalance + inBalance - outBalanceEnd Function
Function IsCusSupExists(CusSupName As String) As Boolean    Dim arr(), numCount As Integer    sql = "Select count(*) From [客商档案$] Where 客商名称='" & CusSupName & "'"    arr = getData(sql)    numCount = arr(0, 0)    If numCount > 0 Then        IsCusSupExists = True    Else        IsCusSupExists = False    End IfEnd Function
Function getMaxDate(Optional processType As String = "采购入库") As Date    Dim arr(), tempDate    Dim bookYear As String    bookYear = getSetting("当前年度")
    If processType = "采购入库" Then        sql = "select max(单据日期) from [采购入库$]"    Else        sql = "select max(单据日期) from [销售出库$]"    End If    arr = getData(sql)    tempDate = arr(0, 0)    If IsNull(tempDate) Then        getMaxDate = CDate(bookYear & "-1-1")    ElseIf tempDate = Date Then        getMaxDate = Date    ElseIf tempDate < CDate(bookYear & "-12-31") Then        getMaxDate = CDate(tempDate) + 1    Else        getMaxDate = CDate(bookYear & "-12-31")    End If
End Function 

10、在类模块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 

11、自定义功能菜单XML文件代码：

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

• 
  

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">    <ribbon>        <tabs>            <!-- 保留默认功能区选项卡 -->            <tab idMso="TabHome" />
            <!-- 自定义选项卡 -->            <tab id="customTab" label="库存管理">                <group id="customGroup1" label="基础设置">                    <button id="customButton1"  imageMso="AddInCommandsMenu" size="large"                            label="商品编码"                             onAction="Thisworkbook.InventorySetting" />                    <button id="customButton2" imageMso="AccountSettings" size="large"                            label="客商编码"                             onAction="Thisworkbook.CustomerSetting" />                    <button id="customButton3"  imageMso="GroupContTypeManage" size="large"                            label="Settings"                             onAction="Thisworkbook.SetItems" />                      <button id="customButton4"  imageMso="CheckEntities" size="large"                            label="期初库存"                             onAction="Thisworkbook.OpeningBalance" />                 </group>                <group id="customGroup2" label="入库管理">                    <button id="customButtonG2-1"  imageMso="FilesToolAddFiles" size="large"                            label="入库录入"                             onAction="Thisworkbook.InOrder" />
                </group>                <group id="customGroup3" label="出库管理">                    <button id="customButtonG3-1"  imageMso="InsertRowAbove" size="large"                            label="出库录入"                             onAction="Thisworkbook.OutOrder" />
                </group>                <group id="customGroup4" label="查询管理">                    <button id="customButtonG4-1"  imageMso="CalendarViewFormatBarStyles" size="large"                            label="入库查询"                             onAction="Thisworkbook.InQuery" />                    <button id="customButtonG4-2" imageMso="CalendarViewGallery" size="large"                            label="出库查询"                             onAction="Thisworkbook.OutQuery" />                    <button id="customButtonG4-3" imageMso="CostTrackingForm" size="large"                            label="库存查询"                             onAction="Thisworkbook.InventoryQuery" />                             </group>                <group id="customGroup5" label="工作表管理">                    <button id="customButtonG5-1"  imageMso="VisibilityVisible" size="large"                            label="显示所有工作表"                             onAction="Thisworkbook.ShowAllTables" />                     <button id="customButtonG5-2" imageMso="CondolatoryEvent" size="large"                            label="隐藏其他工作表"                             onAction="Thisworkbook.HideOtherTables" />                                           </group>    
            </tab>        </tabs>    </ribbon></customUI> 

~~~~~~End~~~~~~