露出 porn VBA【代码】送货单、销售单：共享一个功能弘大的纯EXCEL版数据录入、保存、修改、打印模板！

内容纲领露出 porn

送货单|竣工代码

1、在职责表“送货单”里，敕令按钮点击事件，职责表Change事件、Selection Change事件，自界说经由、函数：

素人播播

Dim arr()， arrtemp()， DeliverNumber As StringPrivate Sub CmdAddNew_Click()    Call clsRG.clearData    Call updateDeliverNumberEnd SubPrivate Sub CmdPrint_Click()    Call printWorksheetEnd SubPrivate Sub CmdRefresh_Click()    Call updateDeliverNumberEnd SubPrivate Sub CmdSave_Click()    If clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then        MsgBox "单子号已存在，请更新单子号后再保存！"        Exit Sub    End If    processType = "新增保存"        Call saveNewEnd SubPrivate Sub CmdSaveAndPrint_Click()    If clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then        MsgBox "单子号已存在，请更新单子号后再保存！"        Exit Sub    End If    processType = "新增保存"    Call printWorksheet    Call saveNew    End SubPrivate Sub CmdClear_Click()    clsRG.clearDataEnd SubPrivate Sub CmdUpdate_Click()    If Not clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then        MsgBox "单子号不存在，无法更新！"        Exit Sub    End If    processType = "更新保存"    Call saveNewEnd SubPrivate Sub CmdUpdateAndPrint_Click()    If Not clsDQ.IsDeliverNumberExists(clsRG.送货单号) Then        MsgBox "单子号不存在，无法更新！"        Exit Sub    End If    processType = "更新保存"       Call printWorksheet    Call saveNewEnd SubPrivate Sub Worksheet_Activate()    If dbs = "" Then        dbs = ThisWorkbook.FullName    End IfEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)    Dim arr()， rng As Range    Dim DeliverNumber As String， customer As String    Dim currRow As Integer， currCol As Integer    Dim targetCol As Integer        '//日历与单子号，要是是新日历，更新单子号；    '//不然字据单子号读取数据    If Target.Address = clsRG.日历.MergeArea.Address Then        If blnUpdateDeliverNumber Then            Call updateDeliverNumber        Else            blnUpdateDeliverNumber = True        End If    End If    If Target.Address = clsRG.送货单号.Address Then        tbl = "[数据$]"        DeliverNumber = Target.Value        If clsDQ.IsDeliverNumberExists(DeliverNumber) Then            blnUpdateDeliverNumber = False            Set rng = clsRG.数据区域            rng.ClearContents            sql = "select * from " & tbl & " where 送货单号='" & DeliverNumber & "'"            arr = clsDQ.getData(sql)            customer = arr(2， 0)            clsRG.日历 = arr(1， 0)            clsRG.客户称号 = customer            clsRG.得益地址 = getCustomerAddress(customer)            With rng                For i = 0 To UBound(arr， 2)                    .Cells(i + 1， 1) = i + 1                    For j = 4 To UBound(arr)                        .Cells(i + 1， j - 2) = arr(j， i)                    Next                Next            End With            blnUpdateDeliverNumber = 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        '//金额        Target.Offset(0， 2).Value = Target.Value * Target.Offset(0， 1).Value                '//箱数        q = getPCS(CStr(Target.Offset(0， -4).Value))        If q > 0 Then            Target.Offset(0， 3) = Application.WorksheetFunction.RoundUp(Target.Value / q， 0)        End If                        clsRG.数目盘算推算 = Application.WorksheetFunction.Sum(clsRG.数目)        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 SubPrivate Function getCustomerAddress(customer As String)    Dim arr()    sql = "select 得益地址 from [客户档案$] where 客户称号='" & customer & " '"    On Error Resume Next    arr = clsDQ.getData(sql)    On Error GoTo 0    If Not IsArrEmpty(arr) Then        getCustomerAddress = arr(0， 0)    Else        getCustomerAddress = ""    End IfEnd FunctionPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)    'On Error Resume Next    Dim iRow As Integer， iCol As Integer    Dim iWidth As Single        '//客户称号    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    tbl = "[数据$]"    dkey = Target.Address    currRow = Target.Row        If Target.Address = clsRG.客户称号.MergeArea.Address Then        sql = "select distinct 客户称号，得益地址 from [客户档案$]  where isnull(客户称号)=false"        arr = clsDQ.getData(sql)        iWidth = Range("B3:D3").Width        Call setTextBox(Target， iWidth， 3， arr)    ElseIf Target.Address = clsRG.送货单号.MergeArea.Address Then        sql = "select distinct 送货单号 from [数据$] 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                sql = "select  distinct 物料称号，规格，加工发挥，单元，0 as 数目，单价 from [物料明细$] "        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)            Else        Me.TextBox1.Visible = False        Me.TextBox1 = ""        Me.ListBox1.Visible = False        Me.ListBox1.Clear            End If    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 SubPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)        With ListBox1        If Selection.Address = clsRG.客户称号.MergeArea.Address Then                        clsRG.客户称号 = .List(.ListIndex， 0)            clsRG.得益地址 = .List(.ListIndex， 1)                    ElseIf Selection.Address = clsRG.送货单号.MergeArea.Address Then            clsRG.送货单号 = .List(.ListIndex)        ElseIf Not Intersect(Selection， clsRG.物料称号) Is Nothing Then            For i = 2 To 7                Cells(Selection.Row， i) = .List(.ListIndex， i - 2)            Next        End If    End With    Me.TextBox1.Visible = False    Me.TextBox1 = ""    Me.ListBox1.Visible = False    Me.ListBox1.Clear    'clsRG.数据区域.Cells(1， 2).Select    End SubPrivate Function getPCS(material As String)    '//一箱装若干件    Dim arr()    sql = "select 每箱件数 from [物料明细$] where 物料称号='" & material & "'"    On Error Resume Next    arr = clsDQ.getData(sql)    On Error GoTo 0    If Not IsEmpty(arr) Then        getPCS = arr(0， 0)    Else        getPCS = 0    End IfEnd FunctionPrivate 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 & "%' " _            & "ORDER BY 客户称号 ASC"        arr = clsDQ.getData(sql)        Call setListBox(arr)    ElseIf Selection.Address = clsRG.送货单号.MergeArea.Address Then        sql = "select distinct 送货单号 from [数据$] where 送货单号  LIKE '%" & txbValue & "%' order by 送货单号 DESC"        arr = clsDQ.getData(sql)        Call setListBox(arr)    ElseIf Not Intersect(Target， clsRG.物料称号) Is Nothing And Target.CountLarge = 1 Then                sql = "select  distinct 物料称号，规格，加工发挥，单元，0 as 数目，单价 from [物料明细$] WHERE 物料称号 LIKE '%" & txbValue & "%' " _            & "OR 规格 LIKE '%" & txbValue & "%' " _            & "OR 加工发挥 LIKE '%" & txbValue & "%'  order by 物料称号"        arr = clsDQ.getData(sql)        Call setListBox(arr)    End If            End 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 SubPrivate 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、在用户窗体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    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    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            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    AddLabel_Day Date        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

3、在ThisWorkbook里，日历控件相关代码，职责簿Open事件：

Option ExplicitPrivate Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String， _    ByVal lpWindowName As String) As LongPrivate Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long， ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long， ByVal x As Long， _    ByVal y As Long， ByVal nWidth As Long， ByVal nHeight As Long， ByVal bRepaint As Long) As LongPrivate Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As LongPrivate Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr， ByVal hDC As LongPtr) As LongPtrPublic preDate As DatePrivate Sub Workbook_Open()    dbs = ThisWorkbook.FullName    blnUpdateDeliverNumber = TrueEnd SubPrivate Sub Workbook_SheetSelectionChange(ByVal Sh As Object， ByVal Target As Range)    Dim lHwnd As Long    Dim lDC As Long    Dim lCaps As Long    Dim lngLeft As Long    Dim lngTop As Long    Dim sngPiexlToPiont As Single    Dim lngTitleBarHeight As Long    Dim clsDC As New DateControl    On Error Resume Next        If Target.Address = clsRG.日历.MergeArea.Address Then                  If clsDC.IsFormActive("Usf_DateSelect") Then                Unload Usf_DateSelect                            End If            With Usf_DateSelect                                            If Selection.Value <> "" Then                    If IsDate(Selection.Value) Then                        .Caption = Selection.Value                        .Controls("CmbYear") = Year(Selection)                        .Controls("CmbMonth") = Month(Selection)                        preDate = Selection.Value                    Else                        .Caption = Date                        .Controls("CmbYear") = Year(Date)                        .Controls("CmbMonth") = Month(Date)                        preDate = Date                    End If                Else                    If Target.Offset(-1， 0).Value <> "" Then                        If IsDate(Target.Offset(-1， 0)) Then                            .Caption = Target.Offset(-1， 0).Value                            .Controls("CmbYear") = Year(Target.Offset(-1， 0).Value)                            .Controls("CmbMonth") = Month(Target.Offset(-1， 0).Value)                            preDate = Target.Offset(-1， 0).Value                        Else                            .Caption = Date                            .Controls("CmbYear") = Year(Date)                            .Controls("CmbMonth") = Month(Date)                            preDate = Date                        End If                    Else                        .Caption = Date                        .Controls("CmbYear") = Year(Date)                        .Controls("CmbMonth") = Month(Date)                        preDate = Date                    End If                End If                If Format(.Caption， "YYYYMM") < Format(Date， "YYYYMM") Then                    .BackColor = RGB(139， 69， 19)                ElseIf Format(.Caption， "YYYYMM") > Format(Date， "YYYYMM") Then                    .BackColor = RGB(144， 238， 144)                Else                    .BackColor = RGB(147， 112， 219)                End If                .Show                                Const lLogPixelsX = 88                lDC = GetDC(0)                lCaps = GetDeviceCaps(lDC， lLogPixelsX)                lngTitleBarHeight = GetSystemMetrics(4) ' 4 对应的是 SM_CYCAPTION                sngPiexlToPiont = 72 / lCaps * (100 / Application.ActiveWindow.Zoom)                lngLeft = CLng(ActiveWindow.PointsToScreenPixelsX(0) + ((Target.Offset(1， 0).Left + Target.Width) / sngPiexlToPiont))                lngTop = CLng(ActiveWindow.PointsToScreenPixelsY(0) + ((Target.Offset(1， 0).Top - lngTitleBarHeight + Target.Height) / sngPiexlToPiont))                Usf_DateSelect.StartUpPosition = 0                   lHwnd = FindWindow(vbNullString， Usf_DateSelect.Caption)                MoveWindow lHwnd， lngLeft， lngTop， .Width / (72 / lCaps) * 1.09， .Height / (72 / lCaps) * 1.01， True                Usf_DateSelect.Show 0            End With                  Else        Unload Usf_DateSelect    End If    Target.ActivateEnd Sub

4、在模块myModule里，自界说函数、经由：

Public clsDQ As New DataQueryPublic clsRG As New clsRangesPublic dbs As StringPublic blnUpdateDeliverNumber As BooleanPublic processType As StringFunction GetExtn(iName)    '//取得文献推广名    GetExtn = Right(iName， Len(iName) - InStrRev(iName， ".") + 1)End FunctionSub 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)        prefix = "CK" & strDate        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 SubSub 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， t As Integer    dbs = ThisWorkbook.FullName    tbl = "[数据$]"    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 clsRG.日历 = 0 Then        MsgBox "日历为空！"        Exit Sub    ElseIf clsRG.客户称号 = "" Then        MsgBox "客户为空！"        Exit Sub    ElseIf clsRG.送货单号 = "" Then        MsgBox "得益单号为空！"        Exit Sub            End If        '//检查单子号与日历是否一致    prefix = "CK" & Format(clsRG.日历， "yyyymmdd")    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        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.送货单号                    .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    ElseIf processType = "更新保存" Then        For i = 1 To rng.Rows.Count            If rng.Cells(i， 1) > 0 Then                serialNumber = clsRG.活水号.Cells(i， 1)                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) & "'， " & _                    "箱数 = '" & rng.Cells(i， 9) & "'， " & _                    "备注 = '" & rng.Cells(i， 10) & "' " & _                    "WHERE 活水号 = '" & serialNumber & "'"                clsDQ.ExecuteSQL (sql)            End If        Next    End If    ThisWorkbook.Save        Call clsRG.clearData    Call updateDeliverNumber    MsgBox "保存得手！"End SubSub printWorksheet()    Dim ws As Worksheet， lastRow As Integer， lastCol As Integer    Dim rng As Range    If Not Application.Dialogs(xlDialogPrinterSetup).Show Then Exit Sub    Set ws = ThisWorkbook.Sheets("送货单")    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 SubFunction IsArrEmpty(ByVal sArray As Variant) As Boolean    '//判断数组是否为空    Dim i As Long    IsArrEmpty = False    On Error GoTo lerr:    i = UBound(sArray)    Exit Functionlerr:    IsArrEmpty = TrueEnd FunctionFunction wContinue(Msg) As Boolean    '说明络续函数    Dim Config As Long    Dim a As Long    Config = vbYesNo + vbQuestion + vbDefaultButton2    Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)络续?" & Chr(10) & Chr(10) & "否(N)退出！"， Config)    wContinue = Ans = vbYesEnd Function

5、在类模块clsRanges里，界说单元格区域：

Private ws As WorksheetPrivate Sub Class_Initialize()    Set ws = ThisWorkbook.Worksheets("送货单")End SubPublic Property Get 日历() As Range    Set 日历 = ws.Range("I5")End PropertyPublic Property Get 送货单号() As Range    Set 送货单号 = ws.Range("I4")End PropertyPublic Property Get 客户称号() As Range    Set 客户称号 = ws.Range("B4")End PropertyPublic Property Get 得益地址() As Range    Set 得益地址 = ws.Range("B5")End PropertyPublic Property Get 数目() As Range    Set 数目 = ws.Range("F7:F16")End PropertyPublic Property Get 单价() As Range    Set 单价 = ws.Range("G7:G16")End PropertyPublic Property Get 数目盘算推算() As Range    Set 数目盘算推算 = ws.Range("F17")End PropertyPublic Property Get 金额() As Range    Set 金额 = ws.Range("H7:H16")End PropertyPublic Property Get 金额盘算推算() As Range    Set 金额盘算推算 = ws.Range("H17")End PropertyPublic Property Get 箱数() As Range    Set 箱数 = ws.Range("I7:I16")End PropertyPublic Property Get 箱数盘算推算() As Range    Set 箱数盘算推算 = ws.Range("I17")End PropertyPublic Property Get 数据区域() As Range    Set 数据区域 = ws.Range("A7:K16")End PropertyPublic Property Get 物料称号() As Range    Set 物料称号 = ws.Range("B7:B16")End PropertyPublic Property Get 序号() As Range    Set 序号 = ws.Range("A7:A16")End PropertyPublic Property Get 活水号() As Range    Set 活水号 = ws.Range("K7:K16")End PropertyPublic Property Get 表头() As Range    Set 表头 = ws.Range("A6:K6")End PropertyPublic Sub clearData()    客户称号 = ""    得益地址 = ""    数据区域.ClearContents    数目盘算推算 = 0    金额盘算推算 = 0    箱数盘算推算 = 0    End Sub

6、在类模块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 FunctionSub 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 SubFunction 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 FunctionFunction getData(sql)    '//取得查询恶果，存到数组'    On Error Resume Next    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 FunctionFunction IsDeliverNumberExists(DeliverNumber As String) As Boolean    '//判糟跶货单号是否存在于“数据”    Dim tbl As String， sql As String    Dim arr()    tbl = "[数据$]"    sql = "select count(*) from " & tbl & " where 送货单号='" & DeliverNumber & "'"        arr = getData(sql)    If arr(0， 0) > 0 Then        IsDeliverNumberExists = True    Else        IsDeliverNumberExists = False    End IfEnd FunctionFunction getMaxDeliverNumber(strDate As String) As String    '//取恰面前日历最大的付款单号    On Error Resume Next    Dim tbl As String， sql As String    Dim arr()    tbl = "[数据$]"    sql = "select top 1 送货单号  from " & tbl & " where format(日历 ，'yyyymmdd') ='" & strDate & "' order by 送货单号 DESC"    arr = getData(sql)    getMaxDeliverNumber = arr(0， 0)End FunctionFunction IsSerialNumberExists(serialNumber As String) As Boolean '//判断活水号是否存在于“数据”    Dim tbl As String， sql As String    Dim arr()    tbl = "[数据$]"    sql = "select count(*) from " & tbl & " where 活水号='" & serialNumber & "'"        arr = getData(sql)    If arr(0， 0) > 0 Then        IsSerialNumberExists = True    Else        IsSerialNumberExists = False    End IfEnd Function

7、在类模块DateControl    里，日历控件相关代码：

Private WithEvents clsLabel As MSForms.LabelPrivate WithEvents clsComboBox As MSForms.ComboBoxPrivate WithEvents clsCommandButton As MSForms.CommandButtonProperty Get myDate() As Date    With Usf_DateSelect        myDate = CDate(.Caption)    End WithEnd PropertyPublic Sub ReceiveLabel(ByVal reLabel As MSForms.Label)    Set clsLabel = reLabelEnd SubPublic Sub ReceiveComboBox(ByVal reComboBox As MSForms.ComboBox)    Set clsComboBox = reComboBoxEnd SubPublic Sub ReceiveCommandButton(ByVal reCommandButton As MSForms.CommandButton)    Set clsCommandButton = reCommandButtonEnd SubPrivate Sub clsComboBox_Change()    With Usf_DateSelect        .AddLabel_Day DateSerial(.Controls("CmbYear")， .Controls("CmbMonth")， Day(.Caption))    End WithEnd SubPrivate 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 SubPrivate Sub clsLabel_Click()        Selection = Replace(clsLabel.Name， "LbDay"， "")    Selection.NumberFormatLocal = "yyyy/m/d"        Unload Usf_DateSelectEnd SubPrivate 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 SubFunction 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

。~~~~~~End~~~~~~ 本站仅提供存储处事，悉数内容均由用户发布，如发现存害或侵权内容，请点击举报。