货品库存管理系统-单机版（2） VBA代码 源代码分析 Access数据库管理系统
代码较多，建议复制代码至本地文档后可按窗体名称搜索
货品管理
Option Compare Database
Option Explicit
Public update_num As Integer
Private Sub Command更新_Click()
On Error Resume Next
If 货品编号 = "" Or IsNull(货品编号) = True Then
MsgBox "货品编号值为空！"
Exit Sub
End If
update_num = 1
If MsgBox("是否更新该记录", vbYesNo) <> vbYes Then
DoCmd.RunCommand acCmdUndo
Exit Sub
End If
DoCmd.SetWarnings (False)
On Error Resume Next
DoCmd.RunCommand acCmdSaveRecord
Exit Sub
If Error.Number <> 0 Then
MsgBox Error.Description
Else
End If
End Sub
Private Sub Command删除_Click()
If MsgBox("是否删除该记录", vbYesNo) <> vbYes Then
Exit Sub
End If
On Error Resume Next
DoCmd.SetWarnings (False)
DoCmd.RunCommand acCmdDeleteRecord
MsgBox "删除成功"
DoCmd.Close acForm, Me.Name
If Error.Number <> 0 Then
MsgBox Error.Description
End If
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo 数据更新前提醒_Err
If update_num = 1 Then
update_num = 0
Exit Sub
End If
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
Private Sub Form_Close()
On Error Resume Next
Forms("货品查询").数据表子窗体.Requery
End Sub
货品类别数据表
Private Sub Form_BeforeUpdate(Cancel As Integer)
If gx_num = 0 Then
Exit Sub
End If
On Error GoTo 数据更新前提醒_Err
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
货品数据表
Option Compare Database
Private Sub Form_BeforeUpdate(Cancel As Integer)
If gx_num = 0 Then
Exit Sub
End If
On Error GoTo 数据更新前提醒_Err
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
Private Sub 货品编号_DblClick(Cancel As Integer)
If hp_type = 0 Then
DoCmd.OpenForm "货品管理", acNormal, , "货品编号='" & 货品编号 & "'"
Exit Sub
End If
If hp_type = 1 Then '明细台账
Forms("明细台账").选择货品.Value = Me.货品编号
Forms("明细台账").货品编号.Value = ""
mxtz_a1 = 1
DoCmd.Close acForm, "货品选择"
Exit Sub
End If
If hp_type = 2 Then '明细台账
Forms("出入库统计查询").选择货品.Value = Me.货品编号
Forms("出入库统计查询").数据表子窗体.Form.Filter = "货品编号='" & Me.货品编号 & "'"
Forms("出入库统计查询").数据表子窗体.Form.FilterOn = True
DoCmd.Close acForm, "货品选择"
Exit Sub
End If
If hp_type = 3 Then
rkhp_num = 1
rkhp_text = Me.货品编号
DoCmd.Close acForm, "货品选择"
Exit Sub
End If
If hp_type = 4 Then
ckhp_num = 1
ckhp_text = Me.货品编号
DoCmd.Close acForm, "货品选择"
Exit Sub
End If
End Sub
货品添加
Option Compare Database
Option Explicit
Private Sub Command导入_Click()
On Error GoTo inputerror
Dim upfilename As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
With dlgOpen
.AllowMultiSelect = False
.Filters.Add "Excel", "*.xlsx; *.xlsm", 1
If .Show = -1 Then
upfilename = .SelectedItems(1)
Else
Exit Sub
End If
End With
'------------------------------------------------清空表数据
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 本地货品表"
DoCmd.RunSQL del_sql
'------------------------------------------
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("本地货品表", dbOpenTable)
'打开创建的表并处理数据
Dim excelopenpathname As String
excelopenpathname = upfilename '复制粘贴新Excel文件的路径和名称
'处理打开的表数据
Dim xlapp As excel.Application
Dim xlwbk As excel.Workbook
Dim xlwsh As excel.Worksheet
Set xlapp = New excel.Application
Dim CreateExcel As Object
Set CreateExcel = xlapp
xlapp.Visible = True
Set xlwbk = xlapp.WorkBooks.Open(excelopenpathname)
xlwbk.Activate
Set xlwsh = xlwbk.Worksheets(1)
With xlwsh
Dim i
On Error Resume Next
'--------------------------------------------------处理过程
If .cells(2, 1).Value <> "" Then
Else
GoTo exitexcel
End If
For i = 2 To .Range("A1").End(xlDown).Row
add_rs.AddNew
add_rs!货品编号.Value = .cells(i, 1).Value
add_rs!货品名称.Value = .cells(i, 2).Value
add_rs!规格型号.Value = .cells(i, 3).Value
add_rs!单位.Value = .cells(i, 4).Value
add_rs!入库价.Value = .cells(i, 5).Value
add_rs!出库价.Value = .cells(i, 6).Value
add_rs!货品类别.Value = .cells(i, 7).Value
add_rs!期初库存.Value = .cells(i, 8).Value
add_rs!期初金额.Value = .cells(i, 9).Value
add_rs!最低库存.Value = .cells(i, 10).Value
add_rs!最高库存.Value = .cells(i, 11).Value
add_rs!备注.Value = .cells(i, 12).Value
add_rs.Update
Next i
End With
exitexcel:
xlwbk.Save
xlwbk.Close
xlapp.Quit
'------------------------------------------
Me.数据表子窗体.Requery
Exit Sub
inputerror:
MsgBox Err.Description
End Sub
Private Sub Command清空_Click()
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
入库价.Value = ""
出库价.Value = ""
货品类别.Value = ""
期初库存.Value = ""
期初金额.Value = ""
最低库存.Value = ""
最高库存.Value = ""
备注.Value = ""
End Sub
Private Sub Command上传_Click()
On Error GoTo 上传数据失败错误
If MsgBox("是否将数据添加至货品表，注意：重复的货品编号将不会添加", vbOKCancel) <> vbOK Then
Exit Sub
End If
If Nz(DCount("货品编号", "本地货品表"), 0) = 0 Then '上传货品记录数量
Exit Sub
End If
'---------------------------------------------------------------查询前端
Dim search_rs As DAO.Recordset
Dim search_sql As String
search_sql = "Select * From 本地货品表"
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
'---------------------------------------------------------------建立查询
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("货品表", dbOpenTable)
'---------------------------------------------------------------
On Error Resume Next
Do While search_rs.EOF = False
If search_rs!货品编号.Value <> "" Then
add_rs.AddNew
add_rs!货品编号.Value = search_rs!货品编号.Value
add_rs!货品名称.Value = search_rs!货品名称.Value
add_rs!规格型号.Value = search_rs!规格型号.Value
add_rs!单位.Value = search_rs!单位.Value
add_rs!入库价.Value = search_rs!入库价.Value
add_rs!出库价.Value = search_rs!出库价.Value
add_rs!货品类别.Value = search_rs!货品类别.Value
add_rs!期初库存.Value = search_rs!期初库存.Value
add_rs!期初金额.Value = search_rs!期初金额.Value
add_rs!最低库存.Value = search_rs!最低库存.Value
add_rs!最高库存.Value = search_rs!最高库存.Value
add_rs!备注.Value = search_rs!备注.Value
add_rs.Update
End If
search_rs.MoveNext
Loop
'---------------------------------------------------------------断开后端链接
add_rs.Close
Set add_rs = Nothing
'---------------------------------------------------------------断开前端链接
search_rs.Close
Set search_rs = Nothing
MsgBox "上传数据完成"
Exit Sub
上传数据失败错误:
MsgBox "上传数据失败！" & vbCrLf & Err.Description
End Sub
Private Sub Command添加_Click()
On Error GoTo 添加失败错误
If 货品编号 = "" Or IsNull(货品编号) = True Then
MsgBox "货品编号值为空！"
Exit Sub
End If
If Nz(DCount("货品编号", "货品表", "货品编号='" & Me.货品编号 & "'"), 0) > 0 Then
MsgBox "该货品编号已存在！"
Exit Sub
End If
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("货品表", dbOpenTable)
add_rs.AddNew
'--------------------------------------------------------------字段赋值
On Error Resume Next
With add_rs
add_rs!货品编号.Value = 货品编号.Value
add_rs!货品名称.Value = 货品名称.Value
add_rs!规格型号.Value = 规格型号.Value
add_rs!单位.Value = 单位.Value
add_rs!入库价.Value = 入库价.Value
add_rs!出库价.Value = 出库价.Value
add_rs!货品类别.Value = 货品类别.Value
add_rs!期初库存.Value = 期初库存.Value
add_rs!期初金额.Value = 期初金额.Value
add_rs!最低库存.Value = 最低库存.Value
add_rs!最高库存.Value = 最高库存.Value
add_rs!备注.Value = 备注.Value
End With
'----------------------------------------------------------
add_rs.Update
add_rs.Close
Set add_rs = Nothing
'----------------------------------------------------------
MsgBox "添加成功！"
Call Command清空_Click
Exit Sub
添加失败错误:
MsgBox Err.Description
End Sub
Private Sub Form_Close()
On Error Resume Next
hp_filter = ""
Forms("货品查询").数据表子窗体.Requery
End Sub
Private Sub Form_Load()
DoCmd.Restore
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 本地货品表"
DoCmd.RunSQL del_sql
Me.数据表子窗体.Requery
End Sub
货品选择
Option Compare Database
Option Explicit
Private Sub Command查询_Click()
On Error GoTo 结束查询
Dim search_field As String
If Me.查询字段 = "日期" Then
If 起始日期 <> "" And IsNull(起始日期) = False And 截止日期 <> "" And IsNull(截止日期) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
hp_filter = search_field & " between #" & Me.起始日期 & "# and #" & Me.截止日期 & "#"
Me.数据表子窗体.Form.Filter = hp_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
hp_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
End If
If Me.查询字段 = "入库价" Or Me.查询字段 = "出库价" Or Me.查询字段 = "期初库存" Or Me.查询字段 = "期初金额" Or Me.查询字段 = "最低库存" Or Me.查询字段 = "最高库存" Then
If 最小 <> "" And IsNull(最小) = False And 最大 <> "" And IsNull(最大) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
hp_filter = search_field & " >= " & Me.最小 & " And " & search_field & " <= " & Me.最大
Me.数据表子窗体.Form.Filter = hp_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
hp_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
End If
If 查询内容 <> "" And IsNull(查询内容) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
hp_filter = search_field & " like '*" & Me.查询内容 & "*'"
Me.数据表子窗体.Form.Filter = hp_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
hp_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
结束查询:
MsgBox Err.Description
End Sub
Private Sub Command全部_Click()
hp_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End Sub
Private Sub Command数据导出_Click()
On Error GoTo 导出失败
'------------------------------------------------清空表数据
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 导出货品表"
DoCmd.RunSQL del_sql
Dim dflink_sql As String
hp_filter = Me.数据表子窗体.Form.Filter
If hp_filter <> "" And Me.数据表子窗体.Form.FilterOn = True Then
dflink_sql = "SELECT * FROM 货品表 " & " Where " & hp_filter
Else
dflink_sql = "SELECT * FROM 货品表"
End If
hp_order = Me.数据表子窗体.Form.OrderBy
If hp_order <> "" Then
dflink_sql = dflink_sql & " order by " & hp_order
End If
Dim dflink_rs As DAO.Recordset
Set dflink_rs = CurrentDb.OpenRecordset(dflink_sql, dbOpenDynaset)
With dflink_rs
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("导出货品表", dbOpenTable)
Do While .EOF = False
add_rs.AddNew
add_rs!货品编号.Value = !货品编号.Value
add_rs!货品名称.Value = !货品名称.Value
add_rs!规格型号.Value = !规格型号.Value
add_rs!单位.Value = !单位.Value
add_rs!入库价.Value = !入库价.Value
add_rs!出库价.Value = !出库价.Value
add_rs!货品类别.Value = !货品类别.Value
add_rs!期初库存.Value = !期初库存.Value
add_rs!期初金额.Value = !期初金额.Value
add_rs!最低库存.Value = !最低库存.Value
add_rs!最高库存.Value = !最高库存.Value
add_rs!备注.Value = !备注.Value
add_rs.Update
.MoveNext
Loop
End With
add_rs.Close
Set add_rs = Nothing
dflink_rs.Close
Set dflink_rs = Nothing
Call 导出查询表结果("导出货品表")
Exit Sub
导出失败:
MsgBox Err.Description
End Sub
Private Sub Command添加_Click()
DoCmd.OpenForm "货品添加", acNormal
End Sub
Private Sub Form_Load()
DoCmd.Restore
hp_filter = ""
hp_order = "货品编号 DESC"
Me.数据表子窗体.Form.OrderBy = hp_order
Me.数据表子窗体.Form.OrderByOn = True
Me.查询内容.Visible = True
'-----------------------------隐藏日期控件
Me.起始日期.Visible = False
Me.截止日期.Visible = False
'-----------------------------隐藏金额控件
Me.最小.Visible = False
Me.最大.Visible = False
End Sub
Private Sub 查询字段_Change()
If Me.查询字段 = "日期" Then
Me.起始日期.Visible = True
Me.截止日期.Visible = True
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
If Me.查询字段 = "入库价" Or Me.查询字段 = "出库价" Or Me.查询字段 = "期初库存" Or Me.查询字段 = "期初金额" Or Me.查询字段 = "最低库存" Or Me.查询字段 = "最高库存" Then
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = True
Me.最大.Visible = True
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
End Sub
经办人数据表
Private Sub Form_BeforeUpdate(Cancel As Integer)
If gx_num = 0 Then
Exit Sub
End If
On Error GoTo 数据更新前提醒_Err
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
库存统计查询
Option Compare Database
Option Explicit
Private Sub Command查询_Click()
On Error GoTo 结束查询
Dim search_field As String
If Me.查询字段 = "日期" Then
If 起始日期 <> "" And IsNull(起始日期) = False And 截止日期 <> "" And IsNull(截止日期) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
kc_filter = search_field & " between #" & Me.起始日期 & "# and #" & Me.截止日期 & "#"
Me.数据表子窗体.Form.Filter = kc_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
kc_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
End If
If Me.查询字段 = "入库数量" Or Me.查询字段 = "出库数量" Or Me.查询字段 = "当前库存" Or Me.查询字段 = "最低库存" Or Me.查询字段 = "最高库存" Or Me.查询字段 = "期初库存" Then
If 最小 <> "" And IsNull(最小) = False And 最大 <> "" And IsNull(最大) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
kc_filter = search_field & " >= " & Me.最小 & " And " & search_field & " <= " & Me.最大
Me.数据表子窗体.Form.Filter = kc_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
kc_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
End If
If 查询内容 <> "" And IsNull(查询内容) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
kc_filter = search_field & " like '*" & Me.查询内容 & "*'"
Me.数据表子窗体.Form.Filter = kc_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
kc_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
结束查询:
MsgBox Err.Description
End Sub
Private Sub Command全部_Click()
kc_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End Sub
Private Sub Command数据导出_Click()
On Error GoTo 导出失败
'------------------------------------------------清空表数据
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 导出库存统计表"
DoCmd.RunSQL del_sql
Dim dflink_sql As String
kc_filter = Me.数据表子窗体.Form.Filter
If kc_filter <> "" And Me.数据表子窗体.Form.FilterOn = True Then
dflink_sql = "SELECT * FROM 库存统计查询 " & " Where " & kc_filter
Else
dflink_sql = "SELECT * FROM 库存统计查询"
End If
kc_order = Me.数据表子窗体.Form.OrderBy
If kc_order <> "" Then
dflink_sql = dflink_sql & " order by " & kc_order
End If
Dim dflink_rs As DAO.Recordset
Set dflink_rs = CurrentDb.OpenRecordset(dflink_sql, dbOpenDynaset)
With dflink_rs
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("导出库存统计表", dbOpenTable)
Do While .EOF = False
add_rs.AddNew
add_rs!货品编号.Value = !货品编号.Value
add_rs!货品名称.Value = !货品名称.Value
add_rs!规格型号.Value = !规格型号.Value
add_rs!单位.Value = !单位.Value
add_rs!入库数量.Value = !入库数量.Value
add_rs!出库数量.Value = !出库数量.Value
add_rs!当前库存.Value = !当前库存.Value
add_rs!最低库存.Value = !最低库存.Value
add_rs!最高库存.Value = !最高库存.Value
add_rs!最低库存状态.Value = !最低库存状态.Value
add_rs!最高库存状态.Value = !最高库存状态.Value
add_rs!货品类别.Value = !货品类别.Value
add_rs!期初库存.Value = !期初库存.Value
add_rs.Update
.MoveNext
Loop
End With
add_rs.Close
Set add_rs = Nothing
dflink_rs.Close
Set dflink_rs = Nothing
Call 导出查询表结果("导出库存统计表")
Exit Sub
导出失败:
MsgBox Err.Description
End Sub
Private Sub Command添加_Click()
DoCmd.OpenForm "库存统计添加", acNormal
End Sub
Private Sub Form_Load()
DoCmd.Restore
kc_filter = ""
kc_order = ""
Me.查询内容.Visible = True
'-----------------------------隐藏日期控件
Me.起始日期.Visible = False
Me.截止日期.Visible = False
'-----------------------------隐藏金额控件
Me.最小.Visible = False
Me.最大.Visible = False
End Sub
Private Sub 查询字段_Change()
If Me.查询字段 = "日期" Then
Me.起始日期.Visible = True
Me.截止日期.Visible = True
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
If Me.查询字段 = "入库数量" Or Me.查询字段 = "出库数量" Or Me.查询字段 = "当前库存" Or Me.查询字段 = "最低库存" Or Me.查询字段 = "最高库存" Or Me.查询字段 = "期初库存" Then
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = True
Me.最大.Visible = True
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
End Sub
领用单位数据表
Private Sub Form_BeforeUpdate(Cancel As Integer)
If gx_num = 0 Then
Exit Sub
End If
On Error GoTo 数据更新前提醒_Err
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
明细台账
Option Compare Database
Option Explicit
Public 期初库存num As Single
Public 期初金额num As Currency
Private Sub Command查询_Click()
If Me.货品编号 <> "" Then
Call 获取货品明细台账(Me.货品编号)
End If
Me.数据表子窗体.Requery
End Sub
Private Sub Command打印台账_Click()
On Error GoTo outputerror
'------------------------------------------
Dim copyfilename As String
copyfilename = "明细台账.xlsx" '要复制的源文件（Excel）
'---------------------------------输入文件名
Dim outputname As String
outputname = InputBox("请输入导出的文件名", "导出明细台账", "明细台账：" & Me.货品编号 & " " & Me.货品名称) '---------------------------------------------------输入要生成的表名
If outputname = "" Or IsNull(outputname) Then '为空则不执行程序
'GoTo outputerror
Exit Sub
End If
'----------------------------------选择导出的位置（文件夹）
Dim exportpath As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
If .Show = -1 Then
exportpath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
fs.copyfile fs.BuildPath(CurrentProject.Path, copyfilename), exportpath & "\" & outputname & ".xlsx"
'================================================================================打开创建的表并处理数据
Dim excelopenpathname As String
excelopenpathname = exportpath & "\" & outputname & ".xlsx" '复制粘贴新Excel文件的路径和名称
'================================================================================处理打开的表数据
Dim xlapp As Object
Set xlapp = CreateObject("excel.application")
Dim xlwbk As Object
Dim xlwsh As Object
Dim CreateExcel As Object
Set CreateExcel = xlapp
xlapp.Visible = False
Set xlwbk = xlapp.WorkBooks.Open(excelopenpathname)
xlwbk.Activate
Set xlwsh = xlwbk.Worksheets(1)
With xlwsh
'--------------------------------------------------处理过程
.cells(3, "C").Value = Me.货品编号.Value
.cells(4, "C").Value = Me.货品名称.Value
.cells(5, "C").Value = Me.规格型号.Value
.cells(3, "J").Value = Me.货品类别.Value
.cells(6, "M").Value = Me.单位.Value
End With
With xlwsh
'****************************************************************循环采购出库查询
Dim search_sql As String
search_sql = "SELECT * FROM 明细台账表"
Dim search_rs As DAO.Recordset
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
'------------------------------------------------------------------
Dim add_row As Long
add_row = 9
Do While search_rs.EOF = False
.cells(add_row, 2).Value = search_rs!日期.Value
.cells(add_row, 3).Value = search_rs!凭证单号.Value
.cells(add_row, 4).Value = search_rs!出入库摘要.Value
.cells(add_row, 5).Value = search_rs!入库数量.Value
.cells(add_row, 6).Value = search_rs!入库单价.Value
.cells(add_row, 9).Value = search_rs!入库金额.Value
.cells(add_row, 7).Value = search_rs!出库数量.Value
.cells(add_row, 8).Value = search_rs!出库单价.Value
.cells(add_row, 10).Value = search_rs!出库金额.Value
.cells(add_row, 11).Value = search_rs!结存数量.Value
.cells(add_row, 12).Value = search_rs!结存均价.Value
.cells(add_row, 13).Value = search_rs!结存金额.Value
.Range(.cells(add_row, 2), .cells(add_row, 13)).Borders.LineStyle = 1
add_row = add_row + 1
search_rs.MoveNext
Loop
'------------------------------------------------------------------
search_rs.Close
Set search_rs = Nothing
'****************************************************************
.Columns.AutoFit
End With
xlwbk.Save
xlwbk.Close
xlapp.Quit
MsgBox "导出完成"
'------------------------------------------
Exit Sub
outputerror:
MsgBox "导出数据出错，请检查！可能存在同名工作簿" & vbCrLf & Err.Description
End Sub
Private Sub Command全部_Click()
mxtz_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End Sub
Private Sub Form_Load()
'---------------------------------------初始化删除显示表
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 明细台账表"
DoCmd.RunSQL del_sql
'---------------------------------------
Me.数据表子窗体.SourceObject = ""
Me.数据表子窗体.SourceObject = "明细台账数据表"
End Sub
Private Sub Form_Timer()
If mxtz_a1 = 1 Then
Call 货品基础信息
mxtz_a1 = 0
End If
End Sub
Private Sub 选择货品_AfterUpdate()
If Me.选择货品 <> "" Then
Dim search_rs As DAO.Recordset
Dim search_sql As String
search_sql = "Select * From 货品表 Where 货品编号='" & Me.选择货品 & "'"
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
If search_rs.EOF = False Then
货品编号.Value = search_rs!货品编号.Value
货品名称.Value = search_rs!货品名称.Value
规格型号.Value = search_rs!规格型号.Value
单位.Value = search_rs!单位.Value
货品类别.Value = search_rs!货品类别.Value
'----------------------------------------------------
期初库存num = Nz(search_rs!期初库存.Value, 0)
期初金额num = Nz(search_rs!期初金额.Value, 0)
'----------------------------------------------------
Else
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
货品类别.Value = ""
'----------------------------------------------------
期初库存num = 0
期初金额num = 0
'----------------------------------------------------
End If
search_rs.Close
Set search_rs = Nothing
Else
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
货品类别.Value = ""
'----------------------------------------------------
期初库存num = 0
期初金额num = 0
'----------------------------------------------------
End If
End Sub
Private Sub 选择货品_Change()
If Me.选择货品 <> "" Then
Dim search_rs As DAO.Recordset
Dim search_sql As String
search_sql = "Select * From 货品表 Where 货品编号='" & Me.选择货品 & "'"
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
If search_rs.EOF = False Then
货品编号.Value = search_rs!货品编号.Value
货品名称.Value = search_rs!货品名称.Value
规格型号.Value = search_rs!规格型号.Value
单位.Value = search_rs!单位.Value
货品类别.Value = search_rs!货品类别.Value
'----------------------------------------------------
期初库存num = Nz(search_rs!期初库存.Value, 0)
期初金额num = Nz(search_rs!期初金额.Value, 0)
'----------------------------------------------------
Else
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
货品类别.Value = ""
'----------------------------------------------------
期初库存num = 0
期初金额num = 0
'----------------------------------------------------
End If
search_rs.Close
Set search_rs = Nothing
Else
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
货品类别.Value = ""
'----------------------------------------------------
期初库存num = 0
期初金额num = 0
'----------------------------------------------------
End If
End Sub
Sub 获取货品明细台账(ByVal hpname As String)
'----------------------------------------------------删除原表记录
On Error GoTo 导出失败
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 明细台账表"
DoCmd.RunSQL del_sql
'----------------------------------------------------获取明细记录循环计算添加
Dim dflink_sql As String
dflink_sql = "SELECT * FROM 出入库明细查询 where 货品编号='" & Me.货品编号 & "' order by 出入库日期 ASC"
Dim dflink_rs As DAO.Recordset
Set dflink_rs = CurrentDb.OpenRecordset(dflink_sql, dbOpenDynaset)
With dflink_rs
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("明细台账表", dbOpenTable)
'-------------------------添加期初数据
add_rs.AddNew
add_rs!凭证单号.Value = "期初"
add_rs!出入库摘要.Value = "期初"
add_rs!入库数量.Value = 0
add_rs!入库单价.Value = 0
add_rs!入库金额.Value = 0
add_rs!出库数量.Value = 0
add_rs!出库单价.Value = 0
add_rs!出库金额.Value = 0
add_rs!结存数量.Value = 期初库存num
If 期初库存num <> 0 Then
add_rs!结存均价.Value = CCur(期初金额num / 期初库存num)
Else
add_rs!结存均价.Value = 0
End If
add_rs!结存金额.Value = 期初金额num
add_rs.Update
'-------------------------
Dim 上期金额num As Currency
Dim 入库金额num As Currency
Dim 出库金额num As Currency
Dim 入库数量num As Single
Dim 出库数量num As Single
Dim 入库单价num As Currency
Dim 出库单价num As Currency
Dim 出入库摘要text As String
上期金额num = 期初金额num
Dim 结存数量num As Single
Dim 结存均价num As Currency
Dim 结存金额num As Currency
Dim 上期数量num As Single
Dim 上期均价num As Currency
上期数量num = 期初库存num
If 期初库存num <> 0 Then
上期均价num = Nz(CCur(期初金额num / 期初库存num), 0)
Else
上期均价num = 0
End If
Do While .EOF = False
入库金额num = 0
入库数量num = 0
入库单价num = 0
出库金额num = 0
出库数量num = 0
出库单价num = 0
If !出入库.Value = "入库" Then
入库金额num = !货品金额.Value
入库数量num = !数量.Value
入库单价num = !单价.Value
出库金额num = 0
出库数量num = 0
出库单价num = 0
End If
If !出入库.Value = "出库" Then
出库金额num = !货品金额.Value
出库数量num = !数量.Value
出库单价num = !单价.Value
入库金额num = 0
入库数量num = 0
入库单价num = 0
End If
出入库摘要text = !出入库类别.Value & "-" & !出入库.Value
'--------------------------------计算结存
结存金额num = 上期金额num + 入库金额num - 出库金额num
上期金额num = 结存金额num
结存数量num = 上期数量num + 入库数量num - 出库数量num
上期数量num = 结存数量num
If 结存数量num <> 0 Then
结存均价num = Nz(结存金额num / 结存数量num)
Else
结存均价num = 0
End If
'--------------------------------
add_rs.AddNew
add_rs!日期.Value = !出入库日期.Value
add_rs!凭证单号.Value = !凭证单号.Value
add_rs!出入库摘要.Value = 出入库摘要text
add_rs!入库数量.Value = 入库数量num
add_rs!入库单价.Value = 入库单价num
add_rs!入库金额.Value = 入库金额num
add_rs!出库数量.Value = 出库数量num
add_rs!出库单价.Value = 出库单价num
add_rs!出库金额.Value = 出库金额num
add_rs!结存数量.Value = 结存数量num
add_rs!结存均价.Value = 结存均价num
add_rs!结存金额.Value = 结存金额num
add_rs.Update
.MoveNext
Loop
End With
add_rs.Close
Set add_rs = Nothing
dflink_rs.Close
Set dflink_rs = Nothing
'------------------------------------------------------
Exit Sub
导出失败:
MsgBox Err.Description
End Sub
Private Sub 选择货品_DblClick(Cancel As Integer)
hp_type = 1
DoCmd.OpenForm "货品选择", acNormal
End Sub
Sub 货品基础信息()
If Me.选择货品 <> "" Then
Dim search_rs As DAO.Recordset
Dim search_sql As String
search_sql = "Select * From 货品表 Where 货品编号='" & Me.选择货品 & "'"
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
If search_rs.EOF = False Then
货品编号.Value = search_rs!货品编号.Value
货品名称.Value = search_rs!货品名称.Value
规格型号.Value = search_rs!规格型号.Value
单位.Value = search_rs!单位.Value
货品类别.Value = search_rs!货品类别.Value
'----------------------------------------------------
期初库存num = Nz(search_rs!期初库存.Value, 0)
期初金额num = Nz(search_rs!期初金额.Value, 0)
'----------------------------------------------------
Else
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
货品类别.Value = ""
'----------------------------------------------------
期初库存num = 0
期初金额num = 0
'----------------------------------------------------
End If
search_rs.Close
Set search_rs = Nothing
Else
货品编号.Value = ""
货品名称.Value = ""
规格型号.Value = ""
单位.Value = ""
货品类别.Value = ""
'----------------------------------------------------
期初库存num = 0
期初金额num = 0
'----------------------------------------------------
End If
End Sub
入库单查询
Option Compare Database
Option Explicit
Private Sub Command查询_Click()
On Error GoTo 结束查询
Dim search_field As String
If Me.查询字段 = "入库日期" Then
If 起始日期 <> "" And IsNull(起始日期) = False And 截止日期 <> "" And IsNull(截止日期) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
rk_filter = search_field & " between #" & Me.起始日期 & "# and #" & Me.截止日期 & "#"
Me.数据表子窗体.Form.Filter = rk_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
rk_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
End If
If Me.查询字段 = "金额" Then
If 最小 <> "" And IsNull(最小) = False And 最大 <> "" And IsNull(最大) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
rk_filter = search_field & " >= " & Me.最小 & " And " & search_field & " <= " & Me.最大
Me.数据表子窗体.Form.Filter = rk_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
rk_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
End If
If 查询内容 <> "" And IsNull(查询内容) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
search_field = Me.查询字段
rk_filter = search_field & " like '*" & Me.查询内容 & "*'"
Me.数据表子窗体.Form.Filter = rk_filter
Me.数据表子窗体.Form.FilterOn = True
Me.数据表子窗体.Requery
Else
rk_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End If
Me.数据表子窗体.SetFocus
Exit Sub
结束查询:
MsgBox Err.Description
End Sub
Private Sub Command全部_Click()
rk_filter = ""
Me.数据表子窗体.Form.FilterOn = False
Me.数据表子窗体.Requery
End Sub
Private Sub Command数据导出_Click()
On Error GoTo 导出失败
'------------------------------------------------清空表数据
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 导出入库单表"
DoCmd.RunSQL del_sql
Dim dflink_sql As String
rk_filter = Me.数据表子窗体.Form.Filter
If rk_filter <> "" And Me.数据表子窗体.Form.FilterOn = True Then
dflink_sql = "SELECT * FROM 入库单查询 " & " Where " & rk_filter
Else
dflink_sql = "SELECT * FROM 入库单查询"
End If
rk_order = Me.数据表子窗体.Form.OrderBy
If rk_order <> "" Then
dflink_sql = dflink_sql & " order by " & rk_order
End If
Dim dflink_rs As DAO.Recordset
Set dflink_rs = CurrentDb.OpenRecordset(dflink_sql, dbOpenDynaset)
With dflink_rs
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("导出入库单表", dbOpenTable)
Do While .EOF = False
add_rs.AddNew
add_rs!入库单号.Value = !入库单号.Value
add_rs!供货单位.Value = !供货单位.Value
add_rs!入库类别.Value = !入库类别.Value
add_rs!入库日期.Value = !入库日期.Value
add_rs!供货人.Value = !供货人.Value
add_rs!经办人.Value = !经办人.Value
add_rs!备注.Value = !备注.Value
add_rs!金额.Value = !金额.Value
add_rs.Update
.MoveNext
Loop
End With
add_rs.Close
Set add_rs = Nothing
dflink_rs.Close
Set dflink_rs = Nothing
Call 导出查询表结果("导出入库单表")
Exit Sub
导出失败:
MsgBox Err.Description
End Sub
Private Sub Command添加_Click()
DoCmd.OpenForm "入库单添加", acNormal
End Sub
Private Sub Form_Load()
DoCmd.Restore
rk_filter = ""
rk_order = "入库单号 DESC"
'Me.数据表子窗体.Form.OrderBy = rk_order
'Me.数据表子窗体.Form.OrderByOn = True
Me.查询内容.Visible = True
'-----------------------------隐藏日期控件
Me.起始日期.Visible = False
Me.截止日期.Visible = False
'-----------------------------隐藏金额控件
Me.最小.Visible = False
Me.最大.Visible = False
End Sub
Private Sub 查询字段_Change()
If Me.查询字段 = "入库日期" Then
Me.起始日期.Visible = True
Me.截止日期.Visible = True
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
If Me.查询字段 = "金额" Then
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = True
Me.最大.Visible = True
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
End Sub
入库单查询数据表
Private Sub 入库单号_DblClick(Cancel As Integer)
DoCmd.OpenForm "入库单管理", acNormal, , "入库单号='" & 入库单号 & "'"
End Sub
入库单管理
Option Compare Database
Option Explicit
Public update_num As Integer
Private Sub Command更新_Click()
On Error Resume Next
If 入库单号 = "" Or IsNull(入库单号) = True Then
MsgBox "入库单号值为空！"
Exit Sub
End If
update_num = 1
If MsgBox("是否更新该记录", vbYesNo) <> vbYes Then
DoCmd.RunCommand acCmdUndo
Exit Sub
End If
DoCmd.SetWarnings (False)
On Error Resume Next
DoCmd.RunCommand acCmdSaveRecord
Exit Sub
If Error.Number <> 0 Then
MsgBox Error.Description
Else
End If
End Sub
Private Sub Command入库单_Click()
On Error GoTo outputerror
'------------------------------------------
Dim copyfilename As String
copyfilename = "入库单.xlsx" '要复制的源文件（Excel）
'---------------------------------输入文件名
Dim outputname As String
outputname = InputBox("请输入导出的文件名", "导出入库单", "入库单" & Me.入库单号) '---------------------------------------------------输入要生成的表名
If outputname = "" Or IsNull(outputname) Then '为空则不执行程序
'GoTo outputerror
Exit Sub
End If
'----------------------------------选择导出的位置（文件夹）
Dim exportpath As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
If .Show = -1 Then
exportpath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
fs.copyfile fs.BuildPath(CurrentProject.Path, copyfilename), exportpath & "\" & outputname & ".xlsx"
'================================================================================打开创建的表并处理数据
Dim excelopenpathname As String
excelopenpathname = exportpath & "\" & outputname & ".xlsx" '复制粘贴新Excel文件的路径和名称
'================================================================================处理打开的表数据
Dim xlapp As Object
Set xlapp = CreateObject("excel.application")
Dim xlwbk As Object
Dim xlwsh As Object
Dim CreateExcel As Object
Set CreateExcel = xlapp
xlapp.Visible = False
Set xlwbk = xlapp.WorkBooks.Open(excelopenpathname)
xlwbk.Activate
Set xlwsh = xlwbk.Worksheets(1)
With xlwsh
'--------------------------------------------------处理过程
.cells(1, "K").Value = Me.入库单号.Value
.cells(3, "D").Value = Me.供货单位.Value
.cells(3, "H").Value = Me.入库类别.Value
.cells(3, "K").Value = Me.入库日期.Value
.cells(6, "K").Value = Me.金额.Value
.cells(7, "D").Value = Me.供货人.Value
.cells(7, "K").Value = Me.经办人.Value
.cells(8, "D").Value = Me.备注.Value
.cells(6, "D").Value = rmb(Me.金额)
End With
'Set xlwsh = xlwbk.Worksheets(2)
With xlwsh
'****************************************************************循环采购入库查询
Dim search_sql As String
search_sql = "SELECT * FROM 入库明细查询 " & " Where 入库单号='" & Me.入库单号 & "' Order by 入库序号 ASC"
Dim search_rs As DAO.Recordset
'MsgBox search_sql
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
'------------------------------------------------------------------
Dim add_row As Long
add_row = 5
Do While search_rs.EOF = False
.rows(add_row).Insert
.cells(add_row, 2).Value = search_rs!入库序号.Value
.cells(add_row, 3).Value = search_rs!货品编号.Value
.cells(add_row, 4).Value = search_rs!货品名称.Value
.cells(add_row, 5).Value = search_rs!规格型号.Value
.cells(add_row, 6).Value = search_rs!货品类别.Value
.cells(add_row, 9).Value = search_rs!单位.Value
.cells(add_row, 7).Value = search_rs!单价.Value
.cells(add_row, 8).Value = search_rs!数量.Value
.cells(add_row, 10).Value = search_rs!货品金额.Value
.cells(add_row, 11).Value = search_rs!明细备注.Value
add_row = add_row + 1
search_rs.MoveNext
Loop
'------------------------------------------------------------------
search_rs.Close
Set search_rs = Nothing
'****************************************************************
End With
xlwbk.Save
xlwbk.Close
xlapp.Quit
MsgBox "导出完成"
'------------------------------------------
Exit Sub
outputerror:
MsgBox "导出数据出错，请检查！可能存在同名工作簿" & vbCrLf & Err.Description
End Sub
Private Sub Command删除_Click()
If MsgBox("是否删除该记录", vbYesNo) <> vbYes Then
Exit Sub
End If
On Error Resume Next
DoCmd.SetWarnings (False)
DoCmd.RunCommand acCmdDeleteRecord
MsgBox "删除成功"
DoCmd.Close acForm, Me.Name
If Error.Number <> 0 Then
MsgBox Error.Description
End If
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo 数据更新前提醒_Err
If update_num = 1 Then
update_num = 0
Exit Sub
End If
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
Private Sub Form_Close()
On Error Resume Next
Forms("入库单查询").数据表子窗体.Requery
End Sub
Private Sub Form_Load()
Me.金额 = Nz(DLookup("金额", "入库单金额查询", "入库单号='" & Me.入库单号 & "'"), 0)
End Sub
入库单添加
Option Compare Database
Option Explicit
Private Sub Command导入_Click()
On Error GoTo inputerror
Dim upfilename As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
With dlgOpen
.AllowMultiSelect = False
.Filters.Add "Excel", "*.xlsx; *.xlsm", 1
If .Show = -1 Then
upfilename = .SelectedItems(1)
Else
Exit Sub
End If
End With
'------------------------------------------------清空表数据
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 本地入库单表"
DoCmd.RunSQL del_sql
'------------------------------------------
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("本地入库单表", dbOpenTable)
'打开创建的表并处理数据
Dim excelopenpathname As String
excelopenpathname = upfilename '复制粘贴新Excel文件的路径和名称
'处理打开的表数据
Dim xlapp As excel.Application
Dim xlwbk As excel.Workbook
Dim xlwsh As excel.Worksheet
Set xlapp = New excel.Application
Dim CreateExcel As Object
Set CreateExcel = xlapp
xlapp.Visible = True
Set xlwbk = xlapp.WorkBooks.Open(excelopenpathname)
xlwbk.Activate
Set xlwsh = xlwbk.Worksheets(1)
With xlwsh
Dim i
On Error Resume Next
'--------------------------------------------------处理过程
If .cells(2, 1).Value <> "" Then
Else
GoTo exitexcel
End If
For i = 2 To .Range("A1").End(xlDown).Row
add_rs.AddNew
add_rs!入库单号.Value = .cells(i, 1).Value
add_rs!供货单位.Value = .cells(i, 2).Value
add_rs!入库类别.Value = .cells(i, 3).Value
add_rs!入库日期.Value = .cells(i, 4).Value
add_rs!供货人.Value = .cells(i, 5).Value
add_rs!经办人.Value = .cells(i, 6).Value
add_rs!备注.Value = .cells(i, 7).Value
add_rs.Update
Next i
End With
exitexcel:
xlwbk.Save
xlwbk.Close
xlapp.Quit
'------------------------------------------
Me.数据表子窗体.Requery
Exit Sub
inputerror:
MsgBox Err.Description
End Sub
Private Sub Command清空_Click()
入库单号.Value = 生成入库单号(Date)
供货单位.Value = ""
入库类别.Value = ""
入库日期.Value = Date
供货人.Value = ""
经办人.Value = ""
备注.Value = ""
End Sub
Private Sub Command上传_Click()
On Error GoTo 上传数据失败错误
If MsgBox("是否将数据添加至入库单表，注意：重复的入库单号将不会添加", vbOKCancel) <> vbOK Then
Exit Sub
End If
If Nz(DCount("入库单号", "本地入库单表"), 0) = 0 Then '上传入库单记录数量
Exit Sub
End If
'---------------------------------------------------------------查询前端
Dim search_rs As DAO.Recordset
Dim search_sql As String
search_sql = "Select * From 本地入库单表"
Set search_rs = CurrentDb.OpenRecordset(search_sql, dbOpenDynaset)
'---------------------------------------------------------------建立查询
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("入库单表", dbOpenTable)
'---------------------------------------------------------------
On Error Resume Next
Do While search_rs.EOF = False
add_rs.AddNew
add_rs!入库单号.Value = search_rs!入库单号.Value
add_rs!供货单位.Value = search_rs!供货单位.Value
add_rs!入库类别.Value = search_rs!入库类别.Value
add_rs!入库日期.Value = search_rs!入库日期.Value
add_rs!供货人.Value = search_rs!供货人.Value
add_rs!经办人.Value = search_rs!经办人.Value
add_rs!备注.Value = search_rs!备注.Value
add_rs.Update
search_rs.MoveNext
Loop
'---------------------------------------------------------------断开后端链接
add_rs.Close
Set add_rs = Nothing
'---------------------------------------------------------------断开前端链接
search_rs.Close
Set search_rs = Nothing
MsgBox "上传数据完成"
Exit Sub
上传数据失败错误:
MsgBox "上传数据失败！" & vbCrLf & Err.Description
End Sub
Private Sub Command添加_Click()
On Error GoTo 添加失败错误
If 入库单号 = "" Or IsNull(入库单号) = True Then
MsgBox "入库单号值为空！"
Exit Sub
End If
If 入库日期 = "" Or IsNull(入库日期) = True Then
MsgBox "入库日期值为空！"
Exit Sub
End If
If Nz(DCount("入库单号", "入库单表", "入库单号='" & Me.入库单号 & "'"), 0) > 0 Then
MsgBox "该入库单号已存在！"
Exit Sub
End If
Dim add_rs As DAO.Recordset
Set add_rs = CurrentDb.OpenRecordset("入库单表", dbOpenTable)
add_rs.AddNew
'--------------------------------------------------------------字段赋值
On Error Resume Next
With add_rs
add_rs!入库单号.Value = 入库单号.Value
add_rs!供货单位.Value = 供货单位.Value
add_rs!入库类别.Value = 入库类别.Value
add_rs!入库日期.Value = 入库日期.Value
add_rs!供货人.Value = 供货人.Value
add_rs!经办人.Value = 经办人.Value
add_rs!备注.Value = 备注.Value
'add_rs!金额.Value = 金额.Value
End With
'----------------------------------------------------------
add_rs.Update
add_rs.Close
Set add_rs = Nothing
'----------------------------------------------------------
MsgBox "添加成功！"
Call Command清空_Click
Exit Sub
添加失败错误:
MsgBox Err.Description
End Sub
Private Sub Form_Close()
On Error Resume Next
rk_filter = ""
Forms("入库单查询").数据表子窗体.Requery
End Sub
Private Sub Form_Load()
DoCmd.Restore
Me.入库日期 = Date
Me.入库单号 = 生成入库单号(Date)
DoCmd.SetWarnings (False)
Dim del_sql As String
del_sql = "Delete From 本地入库单表"
DoCmd.RunSQL del_sql
Me.数据表子窗体.Requery
End Sub
Private Sub 入库单号_DblClick(Cancel As Integer)
If Me.入库日期 <> "" Then
Me.入库单号 = 生成入库单号(Me.入库日期)
Else
Me.入库单号 = 生成入库单号(Date)
End If
End Sub
Private Sub 入库日期_DblClick(Cancel As Integer)
Me.入库日期 = Date
End Sub
Function 生成入库单号(ByVal numdate As Date) As String
On Error GoTo 错误
Dim search_num As String
search_num = "RK" & Format(numdate, "YYYYMMDD")
Dim num_count As Long
num_count = Nz(DCount("入库单号", "入库单表", "入库单号 like '*" & search_num & "*'"), 0) + 1
生成入库单号 = search_num & "" & Format(num_count, "000")
Exit Function
错误:
生成入库单号 = ""
End Function
入库类别数据表
Private Sub Form_BeforeUpdate(Cancel As Integer)
If gx_num = 0 Then
Exit Sub
End If
On Error GoTo 数据更新前提醒_Err
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
入库明细查询数据表
Option Compare Database
Private Sub Form_AfterUpdate()
On Error Resume Next
Forms("入库单管理").金额 = Nz(DLookup("金额", "入库单金额查询", "入库单号='" & Forms("入库单管理").入库单号 & "'"), 0)
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If gx_num = 0 Then
Exit Sub
End If
On Error GoTo 数据更新前提醒_Err
If (MsgBox("是否保存对记录的修改", 1, "修改记录提醒") = 1) Then
Beep
' MsgBox "记录修改成功", vbyesOnly, "提醒"
Me.货品编号.Requery
Else
DoCmd.RunCommand acCmdUndo
End If
数据更新前提醒_Exit:
' Exit Function
Exit Sub
数据更新前提醒_Err:
MsgBox Error$
Resume 数据更新前提醒_Exit
End Sub
Private Sub Form_Timer()
If rkhp_num = 1 Then
If Me.货品编号 <> rkhp_text Then
Me.货品编号 = rkhp_text
Me.单价 = Nz(DLookup("入库价", "货品表", "货品编号='" & Me.货品编号 & "'"), 0)
End If
rkhp_num = 0
End If
End Sub
Private Sub 货品编号_AfterUpdate()
Me.单价 = Nz(DLookup("入库价", "货品表", "货品编号='" & Me.货品编号 & "'"), 0)
End Sub
Private Sub 货品编号_Change()
Me.单价 = Nz(DLookup("入库价", "货品表", "货品编号='" & Me.货品编号 & "'"), 0)
End Sub
Private Sub 货品编号_DblClick(Cancel As Integer)
hp_type = 3
DoCmd.OpenForm "货品选择", acNormal
End Sub
系统主页
Private Sub Command更新提醒_Click()
If gx_num = 1 Then
If MsgBox("是否关闭记录更新时提醒", vbYesNo) = vbYes Then
gx_num = 0
End If
Exit Sub
End If
If gx_num = 0 Then
If MsgBox("是否打开记录更新时提醒", vbYesNo) = vbYes Then
gx_num = 1
End If
Exit Sub
End If
End Sub
Private Sub Command退出系统_Click()
If MsgBox("是否退出系统", vbYesNo) <> vbYes Then
Exit Sub
End If
Application.Quit acQuitSaveAll
End Sub
Private Sub Command系统后台_Click()
DoCmd.Close acForm, Me.Name
DoCmd.SelectObject acForm, , True
End Sub
Private Sub Form_Load()
gx_num = 1
End Sub
公告函数变量（模块）
Option Compare Database
'更新提醒
Public gx_num As Integer
'货品
Public hp_filter As String '货品筛选
Public hp_order As String '货品排序
Public hp_num As String '货品主键
'入库
Public rk_filter As String '入库筛选
Public rk_order As String '入库排序
Public rk_num As String '入库主键
'出库
Public ck_filter As String '出库筛选
Public ck_order As String '出库排序
Public ck_num As String '出库主键
'出入库明细
Public crkmx_filter As String '出入库明细筛选
Public crkmx_order As String '出入库明细排序
'库存统计
Public kc_filter As String '库存筛选
Public kc_order As String '库存排序
'出入库查询
Public crkcx_filter As String '出入库查询
Public crkcx_order As String '出入库排序
'明细台账
Public mxtz_filter As String '出入库查询
Public mxtz_order As String '出入库排序
Public mxtz_a1 As Integer
'选择货品
Public hp_type As Integer
'出库明细货品选择
Public ckhp_text As String
Public ckhp_num As Integer
'入库明细货品选择
Public rkhp_text As String
Public rkhp_num As Integer
Function IsFileExists(ByVal strFileName As String) As Boolean '判断文件是否存在
If Len(Dir(strFileName)) <> 0 Then
IsFileExists = True
Else
IsFileExists = False
End If
End Function
Public Sub 导出查询表结果(ByVal tablename As String)
On Error GoTo 导出查询_Err
DoCmd.OutputTo acOutputTable, tablename, "", "", False, "", , acExportQualityPrint
导出查询_Exit:
Exit Sub
导出查询_Err:
Resume 导出查询_Exit
End Sub
Public Function rmb(s As Currency) As String '人民币转大写
Dim s1, s2, l, x
s1 = LTrim(CStr(Abs(s)))
l = Len(s1)
Select Case l - InStrRev(s1, ".")
'双引号内是小数点
Case l
s2 = s1 + ".00"
Case 1
s2 = s1 + "0"
Case 2
s2 = s1
End Select
l = Len(s2)
Dim dx, c1, c2
dx = ""
c1 = "零壹贰叁肆伍陆柒捌玖"
c2 = "分角 元拾佰仟万拾佰仟亿拾佰"
'角和元之间留一个空格
Do While l >= 1
x = Mid(s2, Len(s2) - l + 1, 1)
If x <> "." Then
dx = dx + Mid(c1, Val(x) + 1, 1) + Trim(Mid(c2, (l - 1) + 1, 1))
End If
l = l - 1
Loop
rmb = dx + "整"
End Function
