Access

Accessによる簡易在庫管理システムのVBA抜粋

2021年5月30日

VBAの記述量が全体の半分ほどありますので、分割してVBAのコードのみをこちらに載せ直しました。
数ヶ月ぶりにAccessを触りました。在庫管理のファイルから載せ忘れているVBAコードもあり、大変ご迷惑おかけしました。

ログイン画面のVBA

Option Compare Database

Private Sub cmd_ログイン_Click()
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim sql As String

    If IsNull(Me.cmb_社員コード) Then
        MsgBox "社員コードを入力してください"
        Exit Sub
    End If
    
    If IsNull(Me.txt_パスワード) Then
        MsgBox "パスワードを入力してください"
        Exit Sub
    End If
    
    
    sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.cmb_社員コード
    Set rs1 = CurrentDb.OpenRecordset(sql)
    Set rs2 = CurrentDb.OpenRecordset("T_ログイン履歴", dbOpenTable)
    
    
    With rs2
        If rs1.EOF Then
            MsgBox "レコードがみつかりません"
        ElseIf rs1.Fields("パスワード") <> SHA256(Me.txt_パスワード) Then
            MsgBox "パスワードが違います"
            .AddNew
            .Fields("社員コード") = Me.cmb_社員コード
            .Fields("日時") = Now
            .Fields("成功or失敗") = False
            .Fields("IPアドレス") = GetIPAddress
            .Update
            lngLoginID = 0
        Else
            'MsgBox "ログインしました"
            .AddNew
            .Fields("社員コード") = Me.cmb_社員コード
            .Fields("日時") = Now
            .Fields("成功or失敗") = True
            .Fields("IPアドレス") = GetIPAddress
            .Update
            lngLoginID = Me.cmb_社員コード
            DoCmd.Close
        End If
    End With
    
    rs1.Close
    Set rs1 = Nothing
    rs2.Close
    Set rs2 = Nothing
    
    If lngLoginID <> 0 Then DoCmd.OpenForm ("F_メイン")
  
End Sub

Private Sub cmd_PW変更_Click()
    DoCmd.OpenForm "F_PW変更"
    
    If IsNull(txt_社員コード) Then
        Forms![F_PW変更]![txt_社員コード].SetFocus
    Else
        Forms![F_PW変更]![txt_社員コード].Value = Me!cmb_社員コード
        Forms![F_PW変更]![txt_社員コード].SetFocus
    End If
End Sub

Private Sub txt_パスワード_Enter()
    Dim rs As DAO.Recordset
    Dim sql As String
    
    sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me!cmb_社員コード
    Set rs = CurrentDb.OpenRecordset(sql)

    If rs.Fields("初期パスワード") = True Then
        MsgBox "初期パスワードを変更してください"
        cmd_PW変更_Click
    End If
End Sub

パスワード変更

Option Compare Database

Private Sub cmd_Cancel_Click()
    Forms![F_ログイン]![cmb_社員コード].SetFocus
    DoCmd.Close
End Sub

Private Sub cmd_更新_Click()
    Dim rst As DAO.Recordset

    If IsNull(Me.txt_社員コード) Then
        MsgBox "社員コードを入力してください"
        Exit Sub
    End If
    
    If IsNull(Me.txt_旧パスワード) Then
        MsgBox "今までのパスワードを入力してください"
        Exit Sub
    End If

    If IsNull(Me.txt_新パスワード) Then
        MsgBox "新パスワードを入力してください"
        Exit Sub
    End If
    
    If IsNull(Me.txt_新パスワード再) Then
        MsgBox "新パスワード（再）を入力してください"
        Exit Sub
    End If
    
    If Me.txt_新パスワード.Value <> Me.txt_新パスワード再.Value Then
        MsgBox "同じパスワードを入力してください"
        Exit Sub
    End If
    
    If Me.txt_新パスワード.Value = Me.txt_旧パスワード.Value Then
        MsgBox "パスワードは変更されていません"
        Exit Sub
    End If
    
    sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.txt_社員コード
    Set rst = CurrentDb.OpenRecordset(sql)
    
    With rst
        .Edit
        .Fields("パスワード") = SHA256(Me.txt_新パスワード)
        .Fields("平文") = Me.txt_新パスワード '動作確認後には削除してください
        .Fields("初期パスワード") = False
        .Update
        MsgBox "更新しました"
    End With
    
    rst.Close
    Set rst = Nothing
    
    DoCmd.Close

End Sub

ログイン履歴のVBA

Option Compare Database

Private Sub Form_Resize()
    Me.Q_ログイン履歴のサブフォーム.Width = Me.InsideWidth
    Me.Q_ログイン履歴のサブフォーム.Height = Me.InsideHeight
End Sub

Private Sub cmd_Clear_Click()
    On Error Resume Next
    DoCmd.RunSQL "DELETE FROM T_ログイン履歴"
    DoCmd.Requery
End Sub

Private Sub cmd_close_Click()
    DoCmd.Close
End Sub

Private Sub cmd_エクスポート_Click()
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Q_ログイン履歴", "在庫管理.xls", True, "ログイン履歴"
    MsgBox ("マイドキュメントにエクスポートしました")
End Sub

メインフォームのVBA

Option Compare Database

Private Sub cmd_入出庫処理_Click()
    DoCmd.OpenForm "F_入出庫処理"
End Sub

Private Sub cmd_入出庫履歴_Click()
    DoCmd.OpenForm "F_入出庫履歴"
End Sub

Private Sub cmd_在庫検索_Click()
    DoCmd.OpenForm "F_在庫検索"
End Sub

Private Sub cmd_在庫転送_Click()
    DoCmd.OpenForm "F_在庫転送"
End Sub

Private Sub cmd_安全在庫_Click()
    DoCmd.OpenForm "F_安全在庫"
End Sub

Private Sub cmd_単位変換_Click()
    DoCmd.OpenForm "F_単位変換"
End Sub

Private Sub cmd_品目マスタ_Click()
    DoCmd.OpenForm "F_品目マスタ"
End Sub

Private Sub cmd_社員マスタ_Click()
    DoCmd.OpenForm "F_社員マスタ"
End Sub

Private Sub cmd_仕入先マスタ_Click()
    DoCmd.OpenForm "F_仕入先マスタ"
End Sub

Private Sub cmd_ログイン履歴_Click()
    DoCmd.OpenForm "F_ログイン履歴"
End Sub

Private Sub cmd_閉じる_Click()
    DoCmd.Close
End Sub

Private Sub Form_Open(Cancel As Integer)
    If lngLoginID <> lngAdmin Then
        cmd_品目マスタ.Enabled = False
        cmd_社員マスタ.Enabled = False
        cmd_仕入先マスタ.Enabled = False
        cmd_ログイン履歴.Enabled = False
    End If
End Sub

入出庫処理フォームのVBA

Option Compare Database

Private Sub Form_Load()
    ClearControls
End Sub

Private Sub cmd_OK_Click()
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫処理", dbOpenTable)
    
    If Me.txt_日付.Value = "" Or Me.cmb_品目.Value = "" Or Me.cmb_入出庫.Value = "" Or Me.txt_数量.Value = "" Or Me.cmb_単位.Value = "" Or Me.cmb_保管場所.Value = "" Then
        MsgBox ("空欄があります")
        Exit Sub
    End If
    
    With rst
        .AddNew
        .Fields("日付") = Me.txt_日付
        .Fields("品目コード") = Me.cmb_品目
        .Fields("入出庫コード") = Me.cmb_入出庫
        .Fields("数量") = Me.txt_数量
        .Fields("単位コード") = Me.cmb_単位
        .Fields("保管場所コード") = Me.cmb_保管場所
        .Fields("社員コード") = lngLoginID
        .Fields("指図番号") = Me.cmb_指図番号 & "-" & Me.cmb_サイド番号
        .Update
    End With
    
    rst.Close
    Set rst = Nothing
    
    MsgBox ("記入しました")
    Call ClearControls
    
End Sub

Private Sub cmd_品目検索_Click()
    DoCmd.OpenForm "F_品目検索"
    strFormName = "F_入出庫処理"
End Sub

Private Sub cmd_Cancel_Click()
    Call ClearControls
End Sub

Private Sub cmd_終了_Click()
   DoCmd.Close acForm, "F_入出庫処理", acSaveNo
End Sub

Sub ClearControls()
    With Me
        .txt_日付 = Date
        .cmb_品目.Value = ""
        .lbl_品目.Caption = ""
        .txt_数量.Value = ""
        .cmb_単位.Value = 529
        .lbl_単位.Caption = "個"
        .cmb_入出庫.Value = ""
        .lbl_入出庫.Caption = ""
        .cmb_保管場所.Value = ""
        .lbl_保管場所.Caption = ""
        .cmb_指図番号.Value = ""
        .cmb_サイド番号.Value = ""
    End With
End Sub

Private Sub cmb_品目_AfterUpdate()
    On Error Resume Next
    Me.lbl_品目.Caption = cmb_品目.Column(1)
End Sub

Private Sub cmb_入出庫_BeforeUpdate(Cancel As Integer)
    If (Me.cmb_入出庫.Value = 610 Or Me.cmb_入出庫.Value = 601) And Me.txt_数量.Value > 0 Then
        Me.txt_数量.Value = Me.txt_数量.Value * (-1)
    End If
    If (Me.cmb_入出庫.Value = 611 Or Me.cmb_入出庫.Value = 600) And Me.txt_数量.Value < 0 Then
        Me.txt_数量.Value = Me.txt_数量.Value * (-1)
    End If
End Sub

Private Sub cmb_単位_AfterUpdate()
    On Error Resume Next
    Me.lbl_単位.Caption = cmb_単位.Column(1)
End Sub

Private Sub cmb_入出庫_AfterUpdate()
    On Error Resume Next
    Me.lbl_入出庫.Caption = cmb_入出庫.Column(1)
End Sub

Private Sub cmb_保管場所_AfterUpdate()
    On Error Resume Next
    Me.lbl_保管場所.Caption = cmb_保管場所.Column(1)
End Sub

入庫及び出庫取り消しのときにはプラスに、出庫及び入庫取り消しのときにはマイナスになるようにします。しかし、いかんせん、入出庫処理をせずに品目や商品を持っていったり入れたりする人がいるものです。棚卸しして差異が生じたときには「棚卸調整」にて増えたらプラスに減っていたらマイナスの数量を入力するようにします。

上記コードにて「600」が入庫、「601」は入庫取り消し。「610」は出庫、「611」は出庫取り消しとしております。これはサンプルデータベースの数値ですので、変更時には上記コードも修正ください。

独り言

ソースコードに数字を直接記載するのは良くないですね。
テーブルを参照して入庫や出庫を識別するようにした方が良いかと思います。

F_品目検索のVBA

Option Compare Database

Private Sub cmd_検索_Click()
    With Me.Q_品目のサブフォーム.Form
        .Filter = "品目型式 Like '*' & [Forms]![F_品目検索]![cmb_品目型式] & '*'"
        .FilterOn = True
    End With
    
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_検索履歴", dbOpenTable)
    With rst
        .AddNew
        .Fields("検索履歴") = Me.cmb_品目型式
        .Update
        .Close
    End With
    Set rst = Nothing

End Sub

Private Sub Form_Resize()
    Me.Q_品目のサブフォーム.Width = Me.InsideWidth
    Me.Q_品目のサブフォーム.Height = Me.InsideHeight
End Sub

Q_品目のサブフォームのVBA

「品目コード」の部分でも「品目型式」の部分でもダブルクリックするとフォーム「F_入出庫処理」に値が入るようにしていますので、同じ記述が並んでおります。

Option Compare Database

Private Sub 品目コード_DblClick(Cancel As Integer)

    Select Case strFormName
        Case "F_入出庫処理"
            DoCmd.OpenForm "F_入出庫処理"
            Forms![F_入出庫処理]![cmb_品目].value = Me!品目コード
            Forms![F_入出庫処理]![lbl_品目].Caption = Me!品目型式
            Forms![F_入出庫処理]![txt_数量].SetFocus
        Case "F_在庫転送"
            DoCmd.OpenForm "F_在庫転送"
            Forms![F_在庫転送]![cmb_品目].value = Me!品目コード
            Forms![F_在庫転送]![lbl_品目].Caption = Me!品目型式
            Forms![F_在庫転送]![txt_数量].SetFocus
        Case "F_単位変換"
            DoCmd.OpenForm "F_単位変換"
            Forms![F_単位変換]![cmb_品目].value = Me!品目コード
            Forms![F_単位変換]![lbl_品目].Caption = Me!品目型式
            Forms![F_単位変換]![txt_変換前数量].SetFocus
    End Select
    DoCmd.Close acForm, "F_品目検索", acSaveNo
End Sub

Private Sub 品目型式_DblClick(Cancel As Integer)
    Select Case strFormName
        Case "F_入出庫処理"
            DoCmd.OpenForm "F_入出庫処理"
            Forms![F_入出庫処理]![cmb_品目].value = Me!品目コード
            Forms![F_入出庫処理]![lbl_品目].Caption = Me!品目型式
            Forms![F_入出庫処理]![txt_数量].SetFocus
        Case "F_在庫転送"
            DoCmd.OpenForm "F_在庫転送"
            Forms![F_在庫転送]![cmb_品目].value = Me!品目コード
            Forms![F_在庫転送]![lbl_品目].Caption = Me!品目型式
            Forms![F_在庫転送]![txt_数量].SetFocus
        Case "F_単位変換"
            DoCmd.OpenForm "F_単位変換"
            Forms![F_単位変換]![cmb_品目].value = Me!品目コード
            Forms![F_単位変換]![lbl_品目].Caption = Me!品目型式
            Forms![F_単位変換]![txt_変換前数量].SetFocus
    End Select
    DoCmd.Close acForm, "F_品目検索", acSaveNo
End Sub

入出庫履歴フォームのVBA

Option Compare Database

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyReturn
        KeyCode = 0
        Call cmd_検索_Click
    Case vbKeyEscape
        KeyCode = 0
        Call CMD_終了
    End Select
End Sub

Private Sub cmd_検索_Click()
    On Error Resume Next
    Dim strFilter As String
    
    strFilter = ""
    If (Not IsNull(Me.cmb_品目型式)) Then
        strFilter = "(Q_メイン.品目型式 Like '*' & [Forms]![F_入出庫履歴]![cmb_品目型式] & '*')"
        If (Not IsNull(Me.txt_開始日付)) Or (Not IsNull(Me.txt_終了日付)) Then
            strFilter = strFilter & " and "
        End If
    End If
    If (Not IsNull(Me.txt_開始日付)) Then
        strFilter = strFilter & "Q_メイン.日付 >= [Forms]![F_入出庫履歴]![txt_開始日付]"
        If (Not IsNull(Me.txt_終了日付)) Then
            strFilter = strFilter & " and "
        End If
    End If
    If (Not IsNull(Me.txt_終了日付)) Then
        strFilter = strFilter & "Q_メイン.日付 <= [Forms]![F_入出庫履歴]![txt_終了日付]"
    End If
    Debug.Print strFilter
    If (Not IsNull(strFilter)) Then
        With Me.Q_入出庫履歴のサブフォーム.Form
            .Requery
            .Filter = strFilter
            .FilterOn = True
        End With
    End If
    
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_検索履歴", dbOpenTable)
    With rst
        .AddNew
        .Fields("検索履歴") = Me.cmb_品目型式
        .Update
        .Close
    End With
    Set rst = Nothing

End Sub

Private Sub cmd_終了_Click()
   DoCmd.Close acForm, "F_入出庫履歴", acSaveNo
End Sub

Private Sub cmd_エクスポート_Click()
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Q_入出庫履歴", "在庫管理.xls", True, "入出庫履歴"
    MsgBox ("マイドキュメントにエクスポートしました")
End Sub

Private Sub Form_Resize()
    Me.Q_入出庫履歴のサブフォーム.Width = Me.InsideWidth
    Me.Q_入出庫履歴のサブフォーム.Height = Me.InsideHeight
End Sub

入出庫履歴サブフォームのVBA

フィールド「品目型式」をダブルクリックした時に、「在庫検索」フォームを開き、テキストボックスにダブルクリックした箇所の「品目型式」を渡す記述です。

Option Compare Database

Private Sub 入出庫_DblClick(Cancel As Integer)
    Dim YesNo As Boolean
    Dim rs As DAO.Recordset
    
    If Me!削除.value = True Then Exit Sub
    
    YesNo = MsgBox("処理を取り消しますか？", vbYesNo, "処理取消")
    
    If YesNo = False Then
        Exit Sub
    Else
        Set rs = CurrentDb.OpenRecordset("T_入出庫処理", dbOpenDynaset)
        With rs
            .FindFirst "ID=" & Me!ID
            .Edit
            .Fields("削除") = True
            .Fields("削除日付") = Date
            .Update
        End With
        Set rs = Nothing
        MsgBox ("処理を取り消しました")
    End If
End Sub

Private Sub 品目型式_DblClick(Cancel As Integer)
    DoCmd.OpenForm "F_在庫検索"
    Forms![F_在庫検索]![cmb_品目型式].value = Me!品目型式
    Forms!F_在庫検索!.Q_集計のサブフォーム.Requery
End Sub

在庫検索フォームのVBA

「検索ボタン」のプロパティからイベントプロシージャを選択して、下記のようにVBAコードを記載します。

Option Compare Database

Private Sub cmd_検索_Click()
    'Me!Q_集計のサブフォーム.Requery
    
    With Me.Q_集計のサブフォーム.Form
        .Filter = "品目型式 Like '*' & [Forms]![F_在庫検索]![cmb_品目型式] & '*'"
        .FilterOn = True
    End With
    
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_検索履歴", dbOpenTable)
    With rst
        .AddNew
        .Fields("検索履歴") = Me.cmb_品目型式
        .Update
        .Close
    End With
    Set rst = Nothing

End Sub

Private Sub cmd_エクスポート_Click()
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Q_集計", "在庫管理.xls", True, "在庫数"
    MsgBox ("マイドキュメントにエクスポートしました")
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyReturn
        KeyCode = 0
        Call cmd_検索_Click
    Case vbKeyEscape
        KeyCode = 0
        Call CMD_終了
    End Select
End Sub

Private Sub cmd_終了_Click()
   DoCmd.Close acForm, "F_在庫検索", acSaveNo
End Sub

Private Sub Form_Resize()
    Me.Q_集計のサブフォーム.Width = Me.InsideWidth
    Me.Q_集計のサブフォーム.Height = Me.InsideHeight
End Sub

安全在庫フォームのVBA

Option Compare Database

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyReturn
        KeyCode = 0
        Call cmd_検索_Click
    Case vbKeyEscape
        KeyCode = 0
        Call CMD_終了
    End Select
End Sub

Private Sub cmd_終了_Click()
   DoCmd.Close acForm, "F_安全在庫", acSaveNo
End Sub

Private Sub cmd_検索_Click()
    With Me.Q_安全在庫のサブフォーム.Form
        .Filter = "品目型式 Like '*' & [Forms]![F_安全在庫]![cmb_品目型式] & '*'"
        '.Filter = " and DSum(数量, Q_安全在庫, <[T_品目].[安全在庫])"
        .FilterOn = True
    End With
    
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_検索履歴", dbOpenTable)
    With rst
        .AddNew
        .Fields("検索履歴") = Me.cmb_品目型式
        .Update
        .Close
    End With
    Set rst = Nothing

End Sub

Private Sub Form_Resize()
    Me.Q_安全在庫のサブフォーム.Width = Me.InsideWidth
    Me.Q_安全在庫のサブフォーム.Height = Me.InsideHeight
End Sub

在庫転送フォームのVBA

Option Compare Database

Private Sub Form_Load()
    ClearControls
End Sub

Private Sub cmd_OK_Click()
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫処理", dbOpenTable)
    
    If Me.txt_日付.value = "" Or Me.cmb_品目.value = "" Or Me.cmb_単位.value = "" Or Me.cmb_転送元.value = "" Or Me.cmb_転送先.value = "" Or Me.txt_数量.value = "" Then
        MsgBox ("空欄があります")
        Exit Sub
    End If
    If Me.cmb_転送元.value = Me.cmb_転送先.value Then
        MsgBox ("転送元と転送先が同じです")
        Exit Sub
    End If
    
    With rst
        .AddNew
        .Fields("日付") = Me.txt_日付
        .Fields("品目コード") = Me.cmb_品目
        .Fields("入出庫コード") = 650
        .Fields("数量") = Me.txt_数量 * (-1)
        .Fields("保管場所コード") = Me.cmb_転送元
        .Fields("単位コード") = Me.cmb_単位
        .Fields("社員コード") = lngLoginID
        .Update
        .AddNew
        .Fields("日付") = Me.txt_日付
        .Fields("品目コード") = Me.cmb_品目
        .Fields("入出庫コード") = 640
        .Fields("数量") = Me.txt_数量
        .Fields("保管場所コード") = Me.cmb_転送先
        .Fields("単位コード") = Me.cmb_単位
        .Fields("社員コード") = lngLoginID
        .Update
    End With
    
    rst.Close
    Set rst = Nothing
    
    MsgBox ("記入しました")
    Call ClearControls
    
End Sub

Private Sub cmd_品目検索_Click()
    DoCmd.OpenForm "F_品目検索"
    strFormName = "F_在庫転送"
End Sub

Private Sub cmd_Cancel_Click()
    Call ClearControls
End Sub

Private Sub cmd_終了_Click()
   DoCmd.Close acForm, "F_在庫転送", acSaveNo
End Sub

Private Sub cmb_品目_AfterUpdate()
    On Error Resume Next
    Me.lbl_品目.Caption = cmb_品目.Column(1)
End Sub

Private Sub cmb_転送元_AfterUpdate()
    On Error Resume Next
    Me.lbl_転送元.Caption = cmb_転送元.Column(1)
End Sub

Private Sub cmb_転送先_AfterUpdate()
    On Error Resume Next
    Me.lbl_転送先.Caption = cmb_転送先.Column(1)
End Sub

Private Sub txt_数量_BeforeUpdate(Cancel As Integer)
    If txt_数量.value < 0 Then txt_数量.value = txt_数量.value * (-1)
End Sub

Private Sub cmb_単位_AfterUpdate()
    On Error Resume Next
    Me.lbl_単位.Caption = cmb_単位.Column(1)
End Sub

Sub ClearControls()
    With Me
        .txt_日付 = Date
        .cmb_品目.value = ""
        .lbl_品目.Caption = ""
        .cmb_転送元.value = ""
        .lbl_転送元.Caption = ""
        .cmb_転送先.value = ""
        .lbl_転送先.Caption = ""
        .txt_数量.value = ""
        .cmb_単位.value = 529
        .lbl_単位.Caption = "個"
    End With
End Sub

単位変換フォームのVBA

Option Compare Database

Private Sub Form_Load()
    ClearControls
End Sub

Private Sub cmd_OK_Click()
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫処理", dbOpenTable)
    
    If Me.txt_日付.value = "" Or Me.cmb_品目.value = "" Or Me.cmb_変換前単位.value = "" Or Me.cmb_変換後単位.value = "" Or Me.txt_変換前数量.value = "" Or Me.txt_変換後数量.value = "" Or Me.cmb_保管場所.value = "" Then
        MsgBox ("空欄があります")
        Exit Sub
    End If
    If Me.cmb_変換前単位.value = Me.cmb_変換後単位.value Then
        MsgBox ("変換前と変換後の単位が同じです")
        Exit Sub
    End If
    
    With rst
        .AddNew
        .Fields("日付") = Me.txt_日付
        .Fields("品目コード") = Me.cmb_品目
        .Fields("入出庫コード") = 660
        .Fields("数量") = Me.txt_変換前数量
        .Fields("保管場所コード") = Me.cmb_保管場所
        .Fields("単位コード") = Me.cmb_変換前単位
        .Fields("社員コード") = lngLoginID
        .Update
        .AddNew
        .Fields("日付") = Me.txt_日付
        .Fields("品目コード") = Me.cmb_品目
        .Fields("入出庫コード") = 670
        .Fields("数量") = Me.txt_変換後数量
        .Fields("保管場所コード") = Me.cmb_保管場所
        .Fields("単位コード") = Me.cmb_変換後単位
        .Fields("社員コード") = lngLoginID
        .Update
    End With
    
    rst.Close
    Set rst = Nothing
    
    MsgBox ("記入しました")
    Call ClearControls
    
End Sub

Private Sub cmd_品目検索_Click()
    DoCmd.OpenForm "F_品目検索"
    strFormName = "F_単位変換"
End Sub

Private Sub cmd_Cancel_Click()
    Call ClearControls
End Sub

Private Sub cmd_終了_Click()
   DoCmd.Close acForm, "F_単位変換", acSaveNo
End Sub

Sub ClearControls()
    With Me
        .txt_日付 = Date
        .cmb_品目.value = ""
        .lbl_品目.Caption = ""
        .cmb_変換前単位.value = ""
        .lbl_変換前単位.Caption = ""
        .cmb_変換後単位.value = ""
        .lbl_変換後単位.Caption = ""
        .txt_変換前数量.value = ""
        .txt_変換後数量.value = ""
        .cmb_保管場所.value = ""
        .lbl_保管場所.Caption = ""
    End With
End Sub

Private Sub cmb_品目_AfterUpdate()
    On Error Resume Next
    Me.lbl_品目.Caption = cmb_品目.Column(1)
End Sub

Private Sub txt_変換前数量_AfterUpdate()
    On Error Resume Next
    If txt_変換前数量.value > 0 Then txt_変換前数量.value = txt_変換前数量.value * (-1)
End Sub

Private Sub txt_変換後数量_AfterUpdate()
    On Error Resume Next
    If txt_変換後数量.value < 0 Then txt_変換後数量.value = txt_変換後数量.value * (-1)
End Sub

Private Sub cmb_変換前単位_AfterUpdate()
    On Error Resume Next
    Me.lbl_変換前単位.Caption = cmb_変換前単位.Column(1)
End Sub

Private Sub cmb_変換後単位_AfterUpdate()
    On Error Resume Next
    Me.lbl_変換後.Caption = cmb_変換後.Column(1)
End Sub

Private Sub cmb_保管場所_AfterUpdate()
    On Error Resume Next
    Me.lbl_保管場所.Caption = cmb_保管場所.Column(1)
End Sub

品目マスタのVBA

Option Compare Database

Private Sub cmd_インポート_Click()
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("T_品目", dbOpenTable)
    
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "品目", strFileName, True, "品目!A1:K65536"
    Me.品目のサブフォーム.Requery
    MsgBox "インポートしました"
    Set rs = Nothing

End Sub

Private Sub cmd_終了_Click()
    DoCmd.Close
End Sub

Private Sub Form_Resize()
    Me.品目のサブフォーム.Width = Me.InsideWidth
    Me.品目のサブフォーム.Height = Me.InsideHeight
End Sub

社員マスタのVBA

Option Compare Database

Private Sub cmd_終了_Click()
    DoCmd.Close
End Sub

Private Sub cmd_インポート_Click()
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("T_社員", dbOpenTable)
    
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "社員", strFileName, True, "社員!A1:G65536"
    Me.社員のサブフォーム.Requery
    MsgBox "インポートしました"
    Set rs = Nothing

End Sub

Private Sub Form_Resize()
    Me.社員のサブフォーム.Width = Me.InsideWidth
    Me.社員のサブフォーム.Height = Me.InsideHeight
End Sub

仕入先マスタのVBA

Option Compare Database

Private Sub cmd_終了_Click()
    DoCmd.Close
End Sub

Private Sub cmd_インポート_Click()
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("T_仕入先", dbOpenTable)
    
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "仕入先", strFileName, True, "仕入先!A1:K65536"
    Me.仕入先のサブフォーム.Requery
    MsgBox "インポートしました"
    Set rs = Nothing

End Sub

Private Sub Form_Resize()
    Me.仕入先のサブフォーム.Width = Me.InsideWidth
    Me.仕入先のサブフォーム.Height = Me.InsideHeight
End Sub

標準モジュール

Option Compare Database

Public strFormName  As String '「品目検索」をどのフォームから読みだしたかを指定する変数
Public lngLoginID As Long 'ログインした社員コード
Public Const lngAdmin = 99999 '管理者のコード（仮）です。適宜変更ください
Public Const strFileName = "在庫管理システム・元データ.xls" '適宜変更ください。デフォルトのフォルダは「マイドキュメント」です。

' ハッシュ値計算
Function SHA256(s As String) As String
    Dim objSHA256
    Dim objUTF8

    Dim bytes() As Byte
    Dim hash() As Byte

    Dim i
    Dim wk

    '// INIT
    Set objSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    Set objUTF8 = CreateObject("System.Text.UTF8Encoding")

    '// 文字列を UTF8 にエンコードし、バイト配列に変換
    bytes = objUTF8.GetBytes_4(s)

    '// ハッシュ値を計算（バイナリ）
    hash = objSHA256.ComputeHash_2((bytes))

    '// バイナリを16進数文字列に変換
    For i = 1 To UBound(hash) + 1
        wk = wk & Right("0" & Hex(AscB(MidB(hash, i, 1))), 2)
    Next i

    '// 結果を返す
    SHA256 = LCase(wk)

End Function

'アクセス端末のIPアドレス取得
Function GetIPAddress() As String

    Dim NetAdapters, objNic, strIPAddress
    Set NetAdapters = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") _
                           .ExecQuery("Select * from Win32_NetworkAdapterConfiguration " & _
                           "Where (IPEnabled = TRUE)")

    For Each objNic In NetAdapters 'ネットワークアダプターは、複数ある場合がある
        For Each strIPAddress In objNic.IPAddress 'IPは、複数割り当てられている場合がある
            GetIPAddress = strIPAddress
            Exit For        ' １回のみ
        Next
        Exit For        ' １回のみ
    Next

End Function

-Access
-, , , , , , , , , , ,