|
今日份折腾计划 折腾的原因 调取采购单号时需要输入“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
|