ACCESS数据库优化操作项

Foresttu

已于 2022-02-23 17:03:47 修改

阅读量786

点赞数

分类专栏：笔记文章标签：数据仓库

于 2022-02-23 17:00:10 首次发布

本文链接：https://blog.csdn.net/Foresttu/article/details/123090378

版权

自动化采购单号系统优化入库验证用户体验

关键词由CSDN通过智能技术生成

笔记专栏收录该内容

19 篇文章 1 订阅

订阅专栏

今日份折腾计划
折腾的原因调取采购单号时需要输入“MaintPr-2022-XXXX”，这么一长串字符，观测这几日同事们的操作，发现很多人都会写错，而且因为不清楚目标采购单的“XXXX”号码，需要先到别的页面查询。这部分操作方法非常不友好。
折腾思路

双击采购单号输入框，让系统自动把系统内最新那一个采购单号显示到文本框内，并自动把子窗体切换成采购单显示列表，显示最新这个采购单中的所有记录。
增加一个上翻按钮。单击这个按钮，当采购单号文本框内显示的内容，不是“请在此处输入采购单号”，而是真正的采购单号，就自动把采购单号“XXXX”四位数字减一，并且自动把子窗体内显示内容更新成对应采购单的内容。
当上翻采购单号到0001号后，再次按上翻按钮，系统提示已经到底不能上翻。
为了防止采购单中内容被重复执行入库，每次入库后把当前记录条“是否已经入库”字段置成True。执行采购单号备件入库的方法时，每执行一条记录入库前，都自动查询该条记录是否已经入库，若已经入库，则弹出提示，取消该条记录的入库过程。

Public blFromPR As Boolean  '这个是在类模块里定义的全局变量
Public LastPR As Boolean    '这个是在窗体模块里定义的模块变量
Public LastPRNum As String  '这个是在窗体模块里定义的模块变量
Private Sub CmdForwardPR_Click()
On Error GoTo Err_CmdForwardPR_Click
Dim PRNumb As Variant
Dim PRTitle As String
Dim PRYear As String

If Left(Me.TxtPRtitle, 7) = "MaintPR" Then
    PRNumb = Right(Me.TxtPRtitle, 4)
    PRTitle = Left(Me.TxtPRtitle, 8)
    PRYear = Format(Date, "yyyy") & "-"
    If LastPR = True Then
        MsgBox "已经下翻到本年度最新的采购单，无法再下翻。", vbInformation, "温馨提醒："
        Exit Sub
    Else
        PRNumb = PRNumb + 1
    End If
    Select Case (PRNumb)
    Case 1 To 99
        Me.TxtPRtitle = PRTitle & PRYear & "00" & PRNumb
    Case 100 To 999
        Me.TxtPRtitle = PRTitle & PRYear & "0" & PRNumb
    Case Else
        Me.TxtPRtitle = PRTitle & PRYear & PRNumb
    End Select
    Call TxtPRtitle_Change
    '不加上面这行代码，文本框内容系统自动更新后，不会执行“文本框变更过程”，会导致翻到最新采购单后仍然可以继续下翻不存在的采购单号
 Else
    Exit Sub
 End If
 Call CmdCallPR_Click
Exit_CmdForwardPR_Click:
    Exit Sub
Err_CmdForwardPR_Click:
    MsgBox Err.Description
    Resume Exit_CmdForwardPR_Click
End Sub

Private Sub CmdPreviousPR_Click()
On Error GoTo Err_CmdPreviousPR_Click
Dim PRNumb As Variant
Dim PRTitle As String
Dim PRYear As String

If Left(Me.TxtPRtitle, 7) = "MaintPR" Then
    PRNumb = Right(Me.TxtPRtitle, 4)
    PRTitle = Left(Me.TxtPRtitle, 8)
    PRYear = Format(Date, "yyyy") & "-"
    If PRNumb = "0001" Then
        MsgBox "已经上翻到本年度第一个采购单，无法再上翻。", vbInformation, "温馨提醒："
        Exit Sub
    Else
        PRNumb = PRNumb - 1
    End If
    Select Case (PRNumb)
    Case 1 To 99
        Me.TxtPRtitle = PRTitle & PRYear & "00" & PRNumb
    Case 100 To 999
        Me.TxtPRtitle = PRTitle & PRYear & "0" & PRNumb
    Case Else
        Me.TxtPRtitle = PRTitle & PRYear & PRNumb
    End Select
    Call TxtPRtitle_Change
 Else
    Exit Sub
 End If
 Call CmdCallPR_Click
 
Exit_CmdPreviousPR_Click:
    Exit Sub
Err_CmdPreviousPR_Click:
    MsgBox Err.Description
    Resume Exit_CmdPreviousPR_Click
End Sub
Private Sub Form_Load()
On Error GoTo Err_Form_Load

    DoCmd.Maximize '最大化
    LastPR = False
    blFromPR = False
    Me.TxtPRtitle = "请在此输入采购单号"
    
'获取最新的采购单号码，下面10行是新增内容
    LastPR = False
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    Dim strTemp As String
    strTemp = "Select * From K_采购单汇总表"
    rs.Open strTemp, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    rs.MoveLast
    LastPRNum = rs("采购单号")
    rs.Close
    Set rs = Nothing
    
    Me.职务ID = DLookup("[当前登录用户职务ID]", "F_数据库设置", "[引索]='1'")

    If Me.职务ID = 3 Then
        Me.CmdQuitSYS.Enabled = True
        Me.CmdQuitSYS.Visible = True
        Me.Command225.Visible = False
    End If
Exit_Form_Load:
    Exit Sub
Err_Form_Load:
    MsgBox Err.Description
    Resume Exit_Form_Load
End Sub
Private Sub TxtPRtitle_Change()
If Me.TxtPRtitle = LastPRNum Then
    LastPR = True
Else
    LastPR = False
End If
End Sub

Private Sub TxtPRtitle_DblClick(Cancel As Integer)
On Error GoTo Err_TxtPRtitle_DblClick


'双击文本框显示Last采购单号
    TxtPRtitle = LastPRNum
    LastPR = True    '当前页面显示了最新的采购单编号
    
'自动调出采购单号对应的采购项目记录
    Call CmdCallPR_Click

Exit_TxtPRtitle_DblClick:
    Exit Sub
Err_TxtPRtitle_DblClick:
    MsgBox Err.Description
    Resume Exit_TxtPRtitle_DblClick
End Sub

Private Sub TxtPRtitle_LostFocus()
If Me.TxtPRtitle = LastPRNum Then
    LastPR = True
Else
    LastPR = False
End If
End Sub
Private Sub CmdRuku_Click()
On erro GoTo Err_CmdRuku_Click
  Dim Rs1 As ADODB.Recordset
  Dim Rs2 As ADODB.Recordset
  Set Rs1 = New ADODB.Recordset
  Set Rs2 = New ADODB.Recordset
  Dim strTemp As String
  Dim rsCnt As Integer
 
  If Me.品名 = "" Then
        MsgBox "执行入库前，请在品名文本框输入内容"
        Me.品名.SetFocus
        Exit Sub
  End If
  If Me.用途 = "" Then
        MsgBox "执行入库前，请在用途文本框输入内容"
        Me.用途.SetFocus
        Exit Sub
  End If
  If Me.数量 = "" Then
        MsgBox "执行入库前，请在数量文本框输入内容"
        Me.数量.SetFocus
        Exit Sub
  End If
  If Me.费用中心 = "" Then
        MsgBox "执行入库前，请在费用中心文本框选择内容"
        Me.费用中心.SetFocus
        Exit Sub
  End If
  If Me.单价 = "" Then
        MsgBox "执行入库前，请在单价文本框输入内容"
        Me.单价.SetFocus
        Exit Sub
  End If
  If Me.重要性等级 = "" Then
        MsgBox "执行入库前，请在重要性等级文本框选择内容"
        Me.重要性等级.SetFocus
        Exit Sub
  End If
  If Me.安全库存量 = "" Then
        MsgBox "执行入库前，请在安全库存量文本框输入内容"
        Me.安全库存量.SetFocus
        Exit Sub
  End If
  If Me.日期 = "" Then
        MsgBox "执行入库前，请在出入库日期文本框输入内容"
        Me.日期.SetFocus
        Exit Sub
  End If
  
  If MsgBox("请确认备件品名、规格和数量信息，并确认要执行入库吗？", vbInformation + vbYesNo, "重要提示") = vbNo Then Exit Sub
  
  '如果是从采购单列表中选择品名进行入库，则判断该采购单中被选中备件的收货日期字段是否有内容
  If blFromPR = True Then
    If strArray(5) <> "" Then
        If MsgBox("此备件已经于" & strArray(5) & "入库一次，还要再次入库吗？", vbInformation + vbYesNo, "重要提示") = vbNo Then
            Exit Sub
        End If
    End If
  End If
  
  strTemp = "Select * From K_专用备件清单"
  Rs1.Open strTemp, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
  Rs1.MoveFirst
  cunzai = False
  For i = 0 To Rs1.RecordCount - 1
    If Rs1("品名") = Me.品名 And Rs1("规格") = Me.规格 Then
        cunzai = True
        Rs1("数量") = Rs1("数量") + Me.数量
        Rs1("单价") = Me.单价
        Rs1("总价") = Rs1("数量") * Rs1("单价")
        Rs1("最后入库日期") = Me.日期
        Rs1.Update
        i = Rs1.RecordCount
    Else
        Rs1.MoveNext
    End If
  Next
  If cunzai = False Then
    Rs1.AddNew
    Rs1("品名") = Me.品名
    Rs1("规格") = Me.规格
    Rs1("品牌") = Me.品牌
    Rs1("数量") = Me.数量
    Rs1("单价") = Me.单价
    Rs1("总价") = Rs1("数量") * Rs1("单价")
    Rs1("用途") = Me.用途
    Rs1("费用中心") = Me.费用中心
    Rs1("重要性等级") = Me.重要性等级
    Rs1("安全库存量") = Me.安全库存量
    Rs1("最后入库日期") = Me.日期
    Rs1.Update
  End If
  
  '登记到专用备件入库登记表内
    strTemp = "Select * From K_专用备件入库登记"
    Rs2.Open strTemp, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Rs2.AddNew
    Rs2("备件ID") = Rs1("备件ID")
    Rs2("品名") = Rs1("品名")
    Rs2("规格") = Rs1("规格")
    Rs2("品牌") = Rs1("品牌")
    Rs2("用途") = Rs1("用途")
    Rs2("费用中心") = Rs1("费用中心")
    Rs2("入库数量") = Me.数量
    Rs2("单价") = Rs1("单价")
    Rs2("入库日期") = Me.日期
    Rs2("记录者") = Me.记录者
    Rs2.Update
    
'更新采购单列表中收货人和收货日期字段内容
  Dim Rs3 As ADODB.Recordset
  Set Rs3 = New ADODB.Recordset
  Dim Xing As String
  Dim Ming As String
  Xing = Left(Me.记录者, 1)
  Ming = Mid(Me.记录者, 2)
  
  If blFromPR = True Then
    strTemp = "Select * From K_采购单列表"
    Rs3.Open strTemp, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Rs3.MoveFirst
    For i = 0 To Rs3.RecordCount - 1
        If Rs3("采购汇总ID") = strArray(8) And Rs3("采购品名") = strArray(0) Then
            Rs3("收货人ID") = DLookup("员工ID", "K_员工列表", "员工姓=" & Xing & "" And "员工名=" & Ming & "")
            Rs3("收货日期") = Me.日期
            i = Rs3.RecordCount
        Else
            Rs3.MoveNext
        End If
    Next
    Rs3.Update
  End If
  
  Rs1.Close
  Rs2.Close
  Rs3.Close
  Set Rs1 = Nothing
  Set Rs2 = Nothing
  Set Rs3 = Nothing
  
  MsgBox "入库操作已经完成！", vbInformation, "提示"

Exit_CmdRuku_Click:
    Exit Sub
Err_CmdRuku_Click:
    MsgBox Err.Description
    Resume Exit_CmdRuku_Click
End Sub