内容纲目sites like 91porn

送货单|完好意思代码

1、在职责表“送货单”里，号召按钮点击事件，职责表Change事件、Selection Change事件，自界说历程、函数：

巨屌x

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~~~~~~ 本站仅提供存储处事，系数内容均由用户发布，如发现存害或侵权内容，请点击举报。