在庫管理システム簡易版の全ソースコード

メニュー（サイドバーが表示されない方向け）

簡易版Ver.2.10の全ソースコードです。Accessファイルをダウンロードして、VBエディタで見ても同じものです。
Ver.2.20に関しては体調が回復次第とします。64bit版対応のためにDeclare Functionを#If VB7 Then～#Else～#End Ifで囲んでいます。

フォーム・サブフォーム

F_メイン

F_メイン画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
On Error GoTo 終了
    Dim txtVer As String
    Dim txtβ As String
    Dim rst As DAO.Recordset
    Dim sql As String
    
    CloseWindow Application.hWndAccessApp       'Accessを最小化する
    
    '---------------------------------
    'サブルーチン初期値はM_Initializeにあります
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call 初期値
    Call FormInit(Me.Form)

    txtVer = Format(GetDatabaeLast("T_バージョン履歴", "バージョン"), "0.00")
    txtβ = GetDatabaeLast("T_バージョン履歴", "β")
    lbl_Title.Caption = lbl_Title.Caption & " Ver." & txtVer & txtβ
    
    Set rst = CurrentDb.OpenRecordset("T_ログイン履歴")
    With rst
            .AddNew
            .Fields("日時") = Now
            .Fields("IPアドレス") = GetIPAddress
            .Fields("コンピュータ名") = ComputerName   '不要であればコメントアウトしてください。
            .Fields("ユーザー名") = UserName           '不要であればコメントアウトしてください。
            .Update
            
            '書き込んだIDを記憶する
            rst.MoveLast
            intID = Val(rst.Fields("ID"))
    End With
    rst.Close
    Set rst = Nothing
    Exit Sub
終了:
    Call エラーログ("F_メイン", "Form_Load")
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_TableClear_Click()
On Error GoTo 終了
    DoCmd.OpenForm "F_テーブルクリア"
    Forms![F_テーブルクリア]![lbl_タイトル].Caption = "テーブルクリア"
    Forms![F_テーブルクリア].Caption = "テーブルクリア"
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_TableClear_Click")
End Sub

'---------------------------------
Private Sub cmd_インポート_Click()
On Error GoTo 終了
    DoCmd.OpenForm "F_テーブルクリア"
    Forms![F_テーブルクリア]![lbl_タイトル].Caption = "インポート"
    Forms![F_テーブルクリア].Caption = "インポート"
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_インポート_Click")
End Sub

'---------------------------------
Private Sub cmd_各種設定_Click()
On Error GoTo 終了
    strMaster = "各種設定"
    DoCmd.OpenForm "F_各種設定"
    Forms![F_各種設定]![lbl_タイトル].Caption = "各種設定"
    Forms![F_各種設定].Caption = "各種設定"
    Forms![F_各種設定].[SF_各種設定].Visible = True
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_各種設定_Click")
End Sub

'---------------------------------
Private Sub cmd_単位マスタ_Click()
On Error GoTo 終了
    strMaster = "単位マスタ"
    DoCmd.OpenForm "F_各種設定"
    Forms![F_各種設定]![lbl_タイトル].Caption = "単位マスタ"
    Forms![F_各種設定].Caption = "単位マスタ"
    Forms![F_各種設定].[SF_単位].Visible = True
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_単位マスタ_Click")
End Sub

'---------------------------------
Private Sub cmd_入出庫マスタ_Click()
On Error GoTo 終了
    strMaster = "入出庫マスタ"
    DoCmd.OpenForm "F_各種設定"
    Forms![F_各種設定]![lbl_タイトル].Caption = "入出庫マスタ"
    Forms![F_各種設定].Caption = "入出庫マスタ"
    Forms![F_各種設定].[SF_入出庫].Visible = True
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_入出庫マスタ_Click")
End Sub

'---------------------------------
Private Sub cmd_保管場所マスタ_Click()
On Error GoTo 終了
    strMaster = "保管場所マスタ"
    DoCmd.OpenForm "F_各種設定"
    Forms![F_各種設定]![lbl_タイトル].Caption = "保管場所マスタ"
    Forms![F_各種設定].Caption = "保管場所マスタ"
    Forms![F_各種設定].[SF_保管場所].Visible = True
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_保管場所マスタ_Click")
End Sub

'---------------------------------
Private Sub cmd_エラーログ_Click()
    DoCmd.OpenForm "F_エラーログ"
End Sub

'---------------------------------
'閉じる時にログアウト日時を記録
'---------------------------------
Private Sub cmd_閉じる_Click()
On Error GoTo 終了  'ログインなしに開いた場合にエラーになるため
    Dim dbs As Database
    Dim rst As DAO.Recordset
    Dim sql As String
    
    Set dbs = CurrentDb
    Set rst = CurrentDb.OpenRecordset("T_ログイン履歴", dbOpenDynaset)
    With rst
        .FindFirst "id=" & Str(intID)
        .Edit
        .Fields("ログアウト日時") = Now
        .Update
        .Close
    End With
    Set rst = Nothing
    
    DoCmd.Close
    'DoCmd.Quit     'コメントを外すと、終了時にAccessを閉じます。
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_閉じる_Click")
    DoCmd.Close
End Sub

'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub フォームフッター_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

F_ログイン履歴

F_ログイン履歴画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
End Sub

'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_ログイン履歴, 0)
End Sub

'---------------------------------
Private Sub cmd_clear_Click()
    DoCmd.RunSQL "DELETE FROM T_ログイン履歴"
    DoCmd.Requery
End Sub

'---------------------------------
Private Sub cmd_close_Click()
    DoCmd.Close
End Sub

'---------------------------------
Private Sub cmd_エクスポート_Click()
On Error GoTo 終了
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Q_ログイン履歴", "在庫管理.xls", True, "ログイン履歴"
    MsgBox ("マイドキュメントにエクスポートしました")
    Exit Sub
終了:
    Call エラーログ("F_ログイン履歴", "cmd_エクスポート_Click")
End Sub

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_ログイン履歴

SF_ログイン履歴のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
End Sub

F_入出庫処理

F_入出庫処理画面のVBAソースコード

Option Compare Database
Option Explicit
'---------------------------------
Private int入庫 As Integer
Private int入庫取消 As Integer
Private int出庫 As Integer
Private int出庫取消 As Integer
Private int個 As Integer
'---------------------------------
Private Sub Form_Load()
On Error GoTo 終了
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
    
    '---------------------------------
    '関数ReadDatabaseはM_外部データベースにあります
    '---------------------------------
    int入庫 = Val(ReadDatabase("T_入出庫", "入出庫", "入庫", "入出庫コード"))
    int入庫取消 = Val(ReadDatabase("T_入出庫", "入出庫", "入庫取消", "入出庫コード"))
    int出庫 = Val(ReadDatabase("T_入出庫", "入出庫", "出庫", "入出庫コード"))
    int出庫取消 = Val(ReadDatabase("T_入出庫", "入出庫", "出庫取消", "入出庫コード"))
    
    int個 = Val(ReadDatabase("T_単位", "単位", "個", "単位コード"))
    Call ClearControls
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "Form_Load")
End Sub
'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_品目, 567)
End Sub
'---------------------------------
Private Sub cmd_検索_Click()
On Error GoTo 終了
    Dim strFilter1 As String
    Dim strFilter2 As String
    With Me.SF_品目.Form
        .OrderBy = "品目コード"
        .FilterOn = True
    End With
    
    '---------------------------------
    'サブルーチン検索履歴はM_在庫管理にあります
    '---------------------------------
    If IsNull(cmb_品目型式) = False Then Call 検索履歴(Me.cmb_品目型式) 'コンボボックスの検索ワードをT_検索履歴に追加する
    Me.cmb_品目型式.Requery
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmd_検索_Click")
End Sub
'---------------------------------
Private Sub cmd_在庫検索_Click()
    DoCmd.OpenForm "F_在庫検索"
End Sub
'---------------------------------
Private Sub cmb_品目型式_Change()
    Call cmd_検索_Click
End Sub
'---------------------------------
' 入出庫処理本体
'---------------------------------
Private Sub cmd_OK_Click()
On Error GoTo 終了
    '空欄チェック
    Dim bBlank As Boolean
    Dim rst As DAO.Recordset
    Dim rst2 As DAO.Recordset
    Dim sql1, sql2, sql3 As String
    bBlank = False
    
        If IsNull(Me.cmb_品目) Then cmb_品目.BackColor = vbYellow: bBlank = True Else cmb_品目.BackColor = vbWhite
        If Me.txt_数量 = "" Then txt_数量.BackColor = vbYellow: bBlank = True Else txt_数量.BackColor = vbWhite
        If IsNull(Me.cmb_単位) Then cmb_単位.BackColor = vbYellow: bBlank = True Else cmb_単位.BackColor = vbWhite
        If IsNull(Me.cmb_入出庫) Then cmb_入出庫.BackColor = vbYellow: bBlank = True Else cmb_入出庫.BackColor = vbWhite
        If IsNull(Me.cmb_保管場所) Then cmb_保管場所.BackColor = vbYellow: bBlank = True Else cmb_保管場所.BackColor = vbWhite
        If bBlank = True Then
            MsgBox ("空欄があります")
            Exit Sub
        End If
        Set rst = CurrentDb.OpenRecordset("T_入出庫処理")
        With rst
            .AddNew
            .Fields("日付") = Now
            .Fields("品目コード") = Me.cmb_品目
            .Fields("入出庫コード") = Me.cmb_入出庫
            .Fields("数量") = Me.txt_数量
            .Fields("単位コード") = Me.cmb_単位
            .Fields("保管場所コード") = Me.cmb_保管場所
            .Fields("社員コード") = lngLoginID
            .Update
            .Close
        End With
        Set rst = Nothing
    
    MsgBox ("記入しました")
    Call ClearControls
    Me.SF_品目.Form.FilterOn = True
    
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmd_OK_Click")
    Resume Next
End Sub
'---------------------------------
Private Sub cmd_cancel_Click()
    Call ClearControls
End Sub
'---------------------------------
Sub ClearControls()
    With Me
        .cmb_品目.Value = ""
        .lbl_品目.Caption = ""
        .txt_数量.Value = ""
        .cmb_単位.Value = int個
        .lbl_単位.Caption = "個"
        .cmb_入出庫.Value = ""
        .lbl_入出庫.Caption = ""
        .cmb_保管場所.Value = ""
        .lbl_保管場所.Caption = ""
    End With
End Sub
'---------------------------------
Private Sub cmb_品目_AfterUpdate()
On Error GoTo 終了
    
    Me.lbl_品目.Caption = cmb_品目.Column(1)
    If IsNull(Me.cmb_品目) Then cmb_品目.BackColor = vbYellow Else cmb_品目.BackColor = vbWhite
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmb_品目_AfterUpdate")
End Sub
'---------------------------------
Private Sub txt_数量_AfterUpdate()
On Error GoTo 終了
    If Me.txt_数量 = "" Then txt_数量.BackColor = vbYellow Else txt_数量.BackColor = vbWhite
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "txt_数量_AfterUpdate")
End Sub
'---------------------------------
Private Sub cmb_単位_AfterUpdate()
On Error GoTo 終了
    
    Me.lbl_単位.Caption = cmb_単位.Column(1)
    If IsNull(Me.cmb_単位) Then cmb_単位.BackColor = vbYellow Else cmb_単位.BackColor = vbWhite
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmb_単位_AfterUpdate")
End Sub
'---------------------------------
Private Sub cmb_入出庫_BeforeUpdate(Cancel As Integer)
On Error GoTo 終了
    If (Me.cmb_入出庫.Value = int出庫 Or _
        Me.cmb_入出庫.Value = int入庫取消) _
        And Me.txt_数量.Value > 0 Then
        Me.txt_数量.Value = Me.txt_数量.Value * (-1)
    End If
    If (Me.cmb_入出庫.Value = int出庫取消 Or _
        Me.cmb_入出庫.Value = int入庫) _
        And Me.txt_数量.Value < 0 Then
        Me.txt_数量.Value = Me.txt_数量.Value * (-1)
    End If
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmb_入出庫_BeforeUpdate")
End Sub
'---------------------------------
Private Sub cmb_入出庫_AfterUpdate()
On Error GoTo 終了
    
    Me.lbl_入出庫.Caption = cmb_入出庫.Column(1)
    If IsNull(Me.cmb_入出庫) Then cmb_入出庫.BackColor = vbYellow Else cmb_入出庫.BackColor = vbWhite
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmb_入出庫_AfterUpdate")
End Sub
'---------------------------------
Private Sub cmb_保管場所_AfterUpdate()
On Error GoTo 終了
    
    Me.lbl_保管場所.Caption = cmb_保管場所.Column(1)
    If IsNull(Me.cmb_保管場所) Then cmb_保管場所.BackColor = vbYellow Else cmb_保管場所.BackColor = vbWhite
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmb_保管場所_AfterUpdate")
End Sub
'---------------------------------
Private Sub cmd_入出庫履歴_Click()
On Error GoTo 終了
    DoCmd.OpenForm "F_入出庫履歴"
    DoCmd.Close acForm, "F_入出庫処理", acSaveNo
    Exit Sub
終了:
    Call エラーログ("F_入出庫処理", "cmd_入出庫履歴_Click")
End Sub
'---------------------------------
Private Sub cmd_終了_Click()
   DoCmd.Close
End Sub
'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub
'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_品目

SF_品目のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Me.AllowEdits = False
End Sub

'---------------------------------
Private Sub 入出庫_DblClick(Cancel As Integer)
On Error GoTo 終了
    Dim rs As DAO.Recordset
    
    If Me!削除.Value = True Then Exit Sub
    
    If MsgBox("処理を取り消しますか？", vbYesNo, "処理取消") = vbYes Then
        Set rs = CurrentDb.OpenRecordset("T_入出庫処理")
        With rs
            .FindFirst "ID=" & Me!ID
            .Edit
            .Fields("削除") = True
            .Fields("削除日付") = Now
            .Update
        End With
        Set rs = Nothing
        MsgBox ("処理を取り消しました")
    End If
    Exit Sub
終了:
    Call エラーログ("SF_品目", "入出庫_DblClick")
End Sub

'---------------------------------
Private Sub 品目コード_DblClick(Cancel As Integer)
    '---------------------------------
    'サブルーチン処理はM_在庫管理にあります
    '---------------------------------
    Call 処理(Me.Form)
End Sub

'---------------------------------
Private Sub 品目型式_DblClick(Cancel As Integer)
    Call 処理(Me.Form)
End Sub

F_入出庫履歴

F_入出庫履歴画面のVBAソースコード

Option Compare Database
Option Explicit
'---------------------------------
Private Sub Form_Load()
On Error GoTo 終了
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    If lngDisplayRes >= 1920 Then Me.Width = 25000 Else Me.Width = 20000
    Call Form_Resize
    txt_終了日付.Value = Date + 1 '今日の日付を初期値にする
    Exit Sub
終了:
    Call エラーログ("F_入出庫履歴", "Form_Load")
End Sub
'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_入出庫履歴, 0)
End Sub
'---------------------------------
Private Sub cmd_検索_Click()
On Error GoTo 終了
    
    Dim strFilter As String
    
    strFilter = ""
    If (Not IsNull(Me.cmb_品目型式)) Then
        strFilter = "(SF_入出庫履歴.品目型式 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 & "SF_入出庫履歴.日付 >= [Forms]![F_入出庫履歴]![txt_開始日付]"
        If (Not IsNull(Me.txt_終了日付)) Then
            strFilter = strFilter & " and "
        End If
    End If
    If (Not IsNull(Me.txt_終了日付)) Then
        strFilter = strFilter & "SF_入出庫履歴.日付 <= [Forms]![F_入出庫履歴]![txt_終了日付]"
    End If
    If (Not IsNull(strFilter)) Then
        With Me.SF_入出庫履歴.Form
            .Requery
            .Filter = strFilter
            .FilterOn = True
        End With
    End If
    
    '---------------------------------
    'サブルーチン検索履歴はM_在庫管理にあります
    '---------------------------------
    If IsNull(cmb_品目型式) = False Then Call 検索履歴(Me.cmb_品目型式) 'コンボボックスの検索ワードをT_検索履歴に追加する
    Me.cmb_品目型式.Requery
    Exit Sub
終了:
    Call エラーログ("F_入出庫履歴", "cmd_検索_Click")
End Sub
'---------------------------------
Private Sub cmb_品目型式_Change()
    Call cmd_検索_Click
End Sub
'---------------------------------
Private Sub txt_開始日付_Change()
    Call cmd_検索_Click
End Sub
'---------------------------------
Private Sub txt_終了日付_Change()
    Call cmd_検索_Click
End Sub
'---------------------------------
Private Sub cmd_エクスポート_Click()
On Error GoTo 終了
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Q_入出庫履歴", "在庫管理.xls", True, "入出庫履歴"
    MsgBox ("マイドキュメントにエクスポートしました")
    Exit Sub
終了:
    Call エラーログ("F_入出庫履歴", "cmd_エクスポート_Click")
End Sub
'---------------------------------
Private Sub cmd_終了_Click()
   DoCmd.Close
End Sub
'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub
'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_入出庫履歴

SF_入出庫履歴のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Me.AllowEdits = False
End Sub

F_在庫検索

F_在庫検索画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
End Sub

'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_在庫検索, 0)
End Sub

'---------------------------------
Private Sub cmd_検索_Click()
On Error GoTo 終了
    Dim strFilter1 As String

    strFilter1 = str検索フィルタ


    With Me.SF_在庫検索.Form
        .Filter = strFilter1
        .FilterOn = True
    End With
    
    '---------------------------------
    'サブルーチン検索履歴はM_在庫管理にあります
    '---------------------------------
    If IsNull(cmb_品目型式) = False Then Call 検索履歴(Me.cmb_品目型式) 'コンボボックスの検索ワードをT_検索履歴に追加する
    Me.cmb_品目型式.Requery
    Exit Sub
終了:
    Call エラーログ("F_在庫検索", "cmd_検索_Click")
End Sub

'---------------------------------
Private Sub cmb_品目型式_Change()
    Call cmd_検索_Click
End Sub

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

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

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_在庫検索

SF_在庫検索のVBAソースコード

Option Compare Database

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
End Sub

'---------------------------------
Private Sub 品目型式_DblClick(Cancel As Integer)
On Error GoTo 終了
        Forms![F_入出庫処理]![cmb_品目].Value = Me.品目コード.Value
        Forms![F_入出庫処理]![lbl_品目].Caption = Me.品目型式.Value
        Forms![F_入出庫処理]![cmb_保管場所].Value = Me.保管場所コード.Value
        Forms![F_入出庫処理]![lbl_保管場所].Caption = Me.保管場所.Value
        DoCmd.Close
    Exit Sub
終了:
    Call エラーログ("SF_在庫検索", "品目型式_DblClick")
End Sub

F_安全在庫

F_安全在庫画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
End Sub

'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_安全在庫, 0)
End Sub

'---------------------------------
Private Sub cmd_検索_Click()
On Error GoTo 終了
    Dim strFilter1 As String

    strFilter1 = str検索フィルタ

    With Me.SF_安全在庫.Form
        .Filter = strFilter1
        .FilterOn = True
    End With
    
    '---------------------------------
    'サブルーチン検索履歴はM_在庫管理にあります
    '---------------------------------
    If IsNull(cmb_品目型式) = False Then Call 検索履歴(Me.cmb_品目型式) 'コンボボックスの検索ワードをT_検索履歴に追加する
    Me.cmb_品目型式.Requery
    Exit Sub
終了:
    Call エラーログ("F_安全在庫", "cmd_検索_Click")
End Sub

'---------------------------------
Private Sub cmb_品目型式_Change()
    Call cmd_検索_Click
End Sub

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

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_安全在庫

SF_安全在庫のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Me.AllowEdits = False
End Sub

F_テーブルクリア

F_テーブルクリア画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
'インポートのルーチンと共用にしました。
'---------------------------------

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
End Sub

'---------------------------------
Private Sub cmd_実行_Click()
On Error GoTo 終了
    Dim objRec As ADODB.Recordset
    
    '全てチェックされていなければ実行しない
    If chk_ログイン履歴.Value = False And _
        chk_検索履歴.Value = False And _
        chk_入出庫処理.Value = False And _
        chk_品目マスタ.Value = False And _
        chk_保管場所.Value = False And _
        chk_入出庫コード.Value = False And _
        chk_単位コード.Value = False And _
        chk_各種設定.Value = False Then
        Exit Sub
    End If

    Select Case lbl_タイトル.Caption
        Case "インポート"
            '---------------------------------
            '以下のサブルーチンM_外部データベースにあります
            '---------------------------------
            If MsgBox("旧バージョンのデータベースファイルを選択してください。" & vbCr _
                & "現在のテーブルを消去してインポートします。" & vbCr _
                & "必ずバックアップを取って実行してください。" & vbCr _
                & "よろしければYesをクリックしてください", vbYesNo) = vbYes Then
                
                '---------------------------------
                'サブルーチンADO_CONNECTIONはM_外部データベースにあります
                '---------------------------------
                If ADO_CONNECTION = False Then
                    MsgBox "インポートはキャンセルされました"
                    Exit Sub
                End If
                
                If chk_品目マスタ.Value = True Then Call 品目
                If chk_単位コード.Value = True Then Call 単位
                If chk_保管場所.Value = True Then Call 保管場所
                If chk_入出庫コード.Value = True Then Call 入出庫
                If chk_入出庫処理.Value = True Then Call 入出庫処理
                If chk_検索履歴.Value = True Then Call 検索クリア
                If chk_ログイン履歴.Value = True Then Call ログイン履歴
                If chk_各種設定.Value = True Then Call 各種設定
                
                MsgBox ("インポートが完了しました")
                '---------------------------------
                'サブルーチンADO_DISCONNECTIONはM_外部データベースにあります
                '---------------------------------
                Call ADO_DISCONNECTION
            End If
        
        Case "テーブルクリア"
            If MsgBox("レコードを削除してもよろしいですか？", vbYesNo) = vbYes Then
                DoCmd.SetWarnings False
                If chk_ログイン履歴.Value = True Then DoCmd.RunSQL "DELETE * FROM T_ログイン履歴"
                If chk_検索履歴.Value = True Then DoCmd.RunSQL "DELETE * FROM T_検索履歴"
                If chk_入出庫処理.Value = True Then DoCmd.RunSQL "DELETE * FROM T_入出庫処理"
                If chk_品目マスタ.Value = True Then DoCmd.RunSQL "DELETE * FROM T_品目"
                If chk_保管場所.Value = True Then DoCmd.RunSQL "DELETE * FROM T_保管場所"
                If chk_入出庫コード.Value = True Then DoCmd.RunSQL "DELETE * FROM T_入出庫"
                If chk_単位コード.Value = True Then DoCmd.RunSQL "DELETE * FROM T_単位"
                If chk_各種設定.Value = True Then DoCmd.RunSQL "DELETE * FROM T_各種設定"
                MsgBox "削除しました"
                DoCmd.Close
            End If
    End Select
    Exit Sub
終了:
    Call エラーログ("F_テーブルクリア", "cmd_実行_Click")
End Sub

'---------------------------------
Private Sub chk_all_Click()
    If chk_all.Value = True Then
        chk_ログイン履歴.Value = True
        chk_検索履歴.Value = True
        chk_入出庫処理.Value = True
        chk_品目マスタ.Value = True
        chk_保管場所.Value = True
        chk_入出庫コード.Value = True
        chk_単位コード.Value = True
        chk_各種設定.Value = True
    Else
        chk_ログイン履歴.Value = False
        chk_検索履歴.Value = False
        chk_入出庫処理.Value = False
        chk_品目マスタ.Value = False
        chk_保管場所.Value = False
        chk_入出庫コード.Value = False
        chk_単位コード.Value = False
        chk_各種設定.Value = False
    End If
End Sub

'---------------------------------
Private Sub chk_ログイン履歴_Click()
    If chk_ログイン履歴.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub chk_検索履歴_Click()
    If chk_検索履歴.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub chk_入出庫処理_Click()
    If chk_入出庫処理.Value = False Then chk_all.Value = False
End Sub

Private Sub chk_品目マスタ_Click()
    If chk_品目マスタ.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub chk_保管場所_Click()
    If chk_保管場所.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub chk_入出庫コード_Click()
    If chk_入出庫コード.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub chk_単位コード_Click()
    If chk_単位コード.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub chk_各種設定_Click()
    If chk_各種設定.Value = False Then chk_all.Value = False
End Sub

'---------------------------------
Private Sub cmd_cancel_Click()
    DoCmd.Close
End Sub

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

F_品目マスタ

F_品目マスタ画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub cmd_更新_Click()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Dim sql As String
    
    sql = "SELECT * FROM T_品目 WHERE '品目コード= " & Me.txt_品目コード & "'"
    Set rst = CurrentDb.OpenRecordset(sql)
    rst.FindFirst "品目コード= " & Me.txt_品目コード
        
        With rst
            .Edit
            .Fields("品目型式") = Me.txt_品目型式
            .Fields("メーカー") = Me.txt_メーカー
            .Fields("安全在庫") = Me.txt_安全在庫
            .Fields("最小ロット") = Me.txt_最小ロット
            .Fields("標準ロット") = Me.txt_標準ロット
            .Fields("標準納期") = Me.txt_標準納期
            .Fields("単価") = Me.txt_単価
            .Fields("Webサイト") = Me.txt_Webサイト
            .Fields("削除") = Me.chk_削除
            .Update
            .Close
        End With
        Set rst = Nothing
        Me.SF_品目マスタ.Requery
    Exit Sub
終了:
    Call エラーログ("F_品目マスタ", "cmd_更新_Click")
End Sub

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
End Sub

'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_品目マスタ, 0)
End Sub

'---------------------------------
Private Sub cmd_インポート_Click()
On Error GoTo 終了

    '---------------------------------
    'サブルーチンImportFromExcelはM_在庫管理にあります
    '---------------------------------
    ImportFromExcel ("品目")
    Me.SF_品目マスタ.Requery
    Exit Sub
終了:
    Call エラーログ("F_品目マスタ", "cmd_インポート_Click")
End Sub

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

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_品目マスタ

SF_品目マスタのVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Me.AllowEdits = False
End Sub

'---------------------------------
Private Sub Webサイト_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub メーカー_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub 安全在庫_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub 最小ロット_Click()
    Call DetailToTextBox
End Sub

Private Sub 削除_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub 標準ロット_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub 標準納期_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub 品目コード_Click()
        Call DetailToTextBox
End Sub

'---------------------------------
Private Sub 品目型式_Click()
    Call DetailToTextBox
End Sub

'---------------------------------
Private Sub DetailToTextBox()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    
    Set rst = Me.RecordsetClone
    rst.Bookmark = Me.Bookmark

    With Me.Parent
        .txt_品目コード.Value = rst.Fields("品目コード")
        .txt_品目型式.Value = rst.Fields("品目型式")
        .txt_メーカー.Value = rst.Fields("メーカー")
        .txt_単価.Value = rst.Fields("単価")
        .txt_安全在庫.Value = rst.Fields("安全在庫")
        .txt_最小ロット.Value = rst.Fields("最小ロット")
        .txt_標準ロット.Value = rst.Fields("標準ロット")
        .txt_標準納期.Value = rst.Fields("標準納期")
        .txt_Webサイト.Value = rst.Fields("Webサイト")
        .chk_削除.Value = rst.Fields("削除")
    End With
    Exit Sub
終了:
    Call エラーログ("SF_品目マスタ", "DetailToTextBox")
End Sub

F_各種設定

F_各種設定画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
End Sub

'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Select Case strMaster
        Case "各種設定"
            Call AdjustWidth(Me, SF_各種設定, 0)
        Case "入出庫マスタ"
            Call AdjustWidth(Me, SF_入出庫, 0)
        Case "保管場所マスタ"
            Call AdjustWidth(Me, SF_保管場所, 0)
        Case "単位マスタ"
            Call AdjustWidth(Me, SF_単位, 0)
    End Select
    
End Sub

'---------------------------------
Private Sub cmd_close_Click()
    DoCmd.Close
End Sub

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_各種設定、SF_単位、SF_保管場所、SF_入出庫

SF_各種設定、SF_単位、SF_保管場所、SF_入出庫のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Me.AllowEdits = False
End Sub

'---------------------------------
Private Sub Form_Close()
    Me.Visible = False
End Sub、

F_エラーログ

F_エラーログ画面のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    Call Form_Resize
End Sub

'---------------------------------
Private Sub Form_Resize()
    '---------------------------------
    'サブルーチンAdjustWidthはM_画面にあります
    '---------------------------------
    Call AdjustWidth(Me, Me.SF_エラーログ, 0)
End Sub

'---------------------------------
Private Sub cmd_clear_Click()
    DoCmd.RunSQL "DELETE FROM T_エラーログ"
    DoCmd.Requery
End Sub

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

'---------------------------------
' マウスドラッグでフォーム移動
'---------------------------------
Private Sub フォームヘッダー_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

'---------------------------------
Private Sub 詳細_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button And acLeftButton Then
        ReleaseCapture
        Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

SF_エラーログ

SF_エラーログのVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
End Sub

標準モジュール

M_Initialize

M_InitializeのVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
'フォームに共通するSub・Function
'---------------------------------
Public lngLoginID As Long       'ログインした社員コード
Public bAdmin As Boolean        '管理者かどうか、管理者ならTrue、そうでなければFalse
Public strFileName As String    'デフォルトのフォルダは「マイドキュメント」です。
Public lngDisplayRes As Long    '画面の解像度（1920x1080、1366x768などによってフォームのサイズを変更する場合にしようします）
Public intID As Integer         'ログインした際のログイン履歴のIDフィールド
Public lngBomID As Long
Public strMaster As String     'F_各種設定がどのコマンドボタンから呼ばれたか
Public str検索フィルタ As String

'---------------------------------
'フォームを最小化
'---------------------------------
Declare Function CloseWindow Lib "user32" (ByVal hwnd As Long) As Long

'---------------------------------
'フォームをドラッグ
'---------------------------------
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub ReleaseCapture Lib "user32.dll" ()
 
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

'---------------------------------
Public Sub 初期値()
On Error GoTo 終了
    '---------------------------------
    '関数GetWindowSizeはM_画面にあります
    '関数GetDatabaeLastはM_在庫管理にあります
    '---------------------------------
    lngDisplayRes = GetWindowSize   '画面の解像度を取得する
    strFileName = ReadDatabase("T_各種設定", "パラメータ", "ExcelFileName", "設定値")
    str検索フィルタ = ReadDatabase("T_各種設定", "パラメータ", "検索フィルタ", "設定値")
    strMaster = ""
    Exit Sub
終了:
    Call エラーログ("M_Initialize", "初期値")
End Sub

M_IPアドレス

M_IPアドレスのVBAソースコード

Option Compare Database

    ' 関数の宣言
    ' ユーザー名を取得
    Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" _
        Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    ' コンピュータ名を取得
    Private Declare PtrSafe Function GetComputerName Lib "kernel32.dll" _
        Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    ' コンピュータ名を取得
    Private Declare PtrSafe Function GetComputerNameEx Lib "kernel32.dll" _
        Alias "GetComputerNameExA" (ByVal NameType As Long, ByVal lpBuffer As String, lpnSize As Long) As Long
    ' 参考Webサイト：https://mt-soft.sakura.ne.jp/kyozai/excel_vba/300_vba_kiso/70_getinfo/index.htm

'---------------------------------
'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

'---------------------------------
' ログインユーザ名を取得する
'---------------------------------
Public Function UserName() As String
' ユーザー名の長さを示す定数
    Const UNLEN = 256 + 1

    Dim strUserNameBuffer As String * UNLEN
    Dim lngUserNameLength As Long
    Dim lngResult         As Long
 
    ' ユーザー名の長さを設定
    lngUserNameLength = Len(strUserNameBuffer)
    ' ユーザー名を取得
    lngResult = GetUserName(strUserNameBuffer, lngUserNameLength)
    ' ユーザー名を表示
    UserName = Left(strUserNameBuffer, InStr(strUserNameBuffer, vbNullChar) - 1)
End Function

'---------------------------------
' コンピュータ名を取得する
'---------------------------------
Public Function ComputerName() As String
    ' コンピュータ名の長さ
    Const MAX_COMPUTERNAME_LENGTH = 15 + 1
    
    Dim strComputerNameBuffer As String * MAX_COMPUTERNAME_LENGTH
    Dim lngComputerNameLength As Long
    Dim lngResult             As Long
 
    ' コンピュータ名の長さを設定
    lngComputerNameLength = Len(strComputerNameBuffer)
    ' コンピュータ名を取得
    lngResult = GetComputerName(strComputerNameBuffer, lngComputerNameLength)
    ' コンピュータ名を取り出し
    ComputerName = Left(strComputerNameBuffer, InStr(strComputerNameBuffer, vbNullChar) - 1)
End Function

M_画面

M_画面のVBAソースコード

'---------------------------------
'フォームとは無関係のSub・Function
'---------------------------------
Option Compare Database
Option Explicit
'デスクトップサイズ取得関係のAPIの宣言
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
  x1 As Long
  y1 As Long
  x2 As Long
  y2 As Long
End Type
'---------------------------------
Declare Function CloseWindow Lib "user32" (ByVal hwnd As Long) As Long
'---------------------------------
'画面の解像度を取得する
'---------------------------------
Public Function GetWindowSize()
    Dim r As RECT
    Dim hwnd As Long
    Dim lngWidth As Long
    Dim lngHeight As Long
    
    hwnd = GetDesktopWindow()
    
    GetWindowRect hwnd, r
    
    lngWidth = r.x2 - r.x1
    lngHeight = r.y2 - r.y1
    
    'MsgBox "ディスプレイの解像度は " & lngWidth & "×" & lngHeight
    
    GetWindowSize = lngWidth
End Function
'---------------------------------
'サブフォームの大きさを変更するサブルーチン
'frm：フォーム
'ctl：コントロール
'---------------------------------
Public Sub AdjustWidth(strForm As Form, strCtrl As Control, lngTop As Long)
    If strForm.InsideHeight < 6500 Then strForm.InsideHeight = 6500
    
    strCtrl.Height = strCtrl.Height * 0.8              '最初にフォームの内側を小さくしておく
    strForm.Section(acFooter).Height = strForm.InsideHeight - strForm.Section(acDetail).Height - strForm.Section(acHeader).Height - lngTop
    strCtrl.Height = strForm.Section(acFooter).Height
    '
    strCtrl.Left = 0
    strCtrl.Width = strForm.InsideWidth
End Sub
'---------------------------------
Public Sub FormInit(frm As Form)
On Error GoTo 終了
    If lngDisplayRes >= 1920 Then frm.Width = 20000 Else frm.Width = 17000
    
    frm.RecordSelectors = False     'レコードセレクタを非表示
    frm.NavigationButtons = False   '移動ボタン非表示
    frm.ShortcutMenu = False        '右クリック禁止
    frm.ShortcutMenuBar = False
    Exit Sub
終了:
    Call エラーログ("M_画面", "FormInit")
End Sub

M_外部データベース

M_外部データベースのVBAソースコード

Option Compare Database
'---------------------------------
'＊　Accessデータベース接続
'参照：https://808hanablog.com/how-to-connect-to-external-access-with-vba
'---------------------------------
Public ADO_CN As ADODB.Connection 'ADOコネクション
'---------------------------------
Public Function ADO_CONNECTION() As Boolean
On Error GoTo 終了
    Dim ACCESS_FILEPATH As String 'Accessファイルパス
    
    'Accessファイルパス
    ACCESS_FILEPATH = GetAccessFile
    If ACCESS_FILEPATH <> "" Then
        'Connectionオブジェクトのインスタンス化
        Set ADO_CN = New ADODB.Connection
        'Access接続
        ADO_CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ACCESS_FILEPATH & ";"
        ADO_CONNECTION = True
    Else
        ADO_CONNECTION = False
    End If
    Exit Function
終了:
    Call エラーログ("M_外部データベース", "ADO_CONNECTION")
End Function
'---------------------------------
'＊　Accessデータベース接続解除
'---------------------------------
Public Sub ADO_DISCONNECTION()
    
    '接続解除
    ADO_CN.Close
    Set ADO_CN = Nothing
End Sub
'---------------------------------
'参照：https://officevba.info/filedialog/
'要Microsoft Office ○○ Object Library
'[ツール]-[参照設定]にて設定
'---------------------------------
Public Function GetAccessFile()
On Error GoTo 終了
    Dim i
    Dim WSH As Object
    Set WSH = CreateObject("Wscript.Shell")
    Dim DesktopPath As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "ファイルの選択"   'ダイアログのタイトル
        .Filters.Clear
        .Filters.Add "Access", "*.mdb; *.accdb"
        If .Show = True Then
            For i = 1 To .SelectedItems.Count
                GetAccessFile = .SelectedItems(i)
            Next i
        End If
    End With
    Set WSH = Nothing
    Exit Function
終了:
    Call エラーログ("M_外部データベース", "GetAccessFile")
End Function
'---------------------------------
Public Sub 品目()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_品目")
    
    'T_品目
    Set objRec = ADO_CN.Execute("T_品目", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_品目"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("品目コード") = objRec.Fields("品目コード").Value
            .Fields("品目型式") = objRec.Fields("品目型式").Value
            .Fields("メーカー") = objRec.Fields("メーカー").Value
            .Fields("安全在庫") = objRec.Fields("安全在庫").Value
            .Fields("最小ロット") = objRec.Fields("最小ロット").Value
            .Fields("標準ロット") = objRec.Fields("標準ロット").Value
            .Fields("標準納期") = objRec.Fields("標準納期").Value
            .Fields("WEBサイト") = objRec.Fields("WEBサイト").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Update
        End With
        
        objRec.MoveNext
    Wend
終了:
End Sub
'---------------------------------
Public Sub 単位()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_単位")
    
    'T_単位
    Set objRec = ADO_CN.Execute("T_単位", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_単位"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("単位コード") = objRec.Fields("単位コード").Value
            .Fields("単位") = objRec.Fields("単位").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub
'---------------------------------
Public Sub 入出庫()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫")
    
    'T_入出庫
    Set objRec = ADO_CN.Execute("T_入出庫", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_入出庫"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("入出庫コード") = objRec.Fields("入出庫コード").Value
            .Fields("入出庫") = objRec.Fields("入出庫").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub
'---------------------------------
Public Sub 保管場所()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_保管場所")
    
    'T_保管場所
    Set objRec = ADO_CN.Execute("T_保管場所", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_保管場所"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("保管場所コード") = objRec.Fields("保管場所コード").Value
            .Fields("保管場所") = objRec.Fields("保管場所").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub
'---------------------------------
Public Sub 検索クリア()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_検索履歴")
    
    'T_検索履歴
    Set objRec = ADO_CN.Execute("T_検索履歴", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_検索履歴"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("検索履歴") = objRec.Fields("検索履歴").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub
'---------------------------------
Public Sub ログイン履歴()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_ログイン履歴")
    
    'T_ログイン履歴
    Set objRec = ADO_CN.Execute("T_ログイン履歴", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_ログイン履歴"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("日時") = objRec.Fields("日時").Value
            .Fields("成功or失敗") = objRec.Fields("成功or失敗").Value
            .Fields("IPアドレス") = objRec.Fields("IPアドレス").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub
'---------------------------------
Public Sub 入出庫処理()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_入出庫処理")
    
    'T_入出庫処理
    Set objRec = ADO_CN.Execute("T_入出庫処理", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_入出庫処理"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("日付") = objRec.Fields("日付").Value
            .Fields("社員コード") = objRec.Fields("社員コード").Value
            .Fields("品目コード") = objRec.Fields("品目コード").Value
            .Fields("入出庫コード") = objRec.Fields("入出庫コード").Value
            .Fields("数量") = objRec.Fields("数量").Value
            .Fields("単位コード") = objRec.Fields("単位コード").Value
            .Fields("保管場所コード") = objRec.Fields("保管場所コード").Value
            .Fields("削除") = objRec.Fields("削除").Value
            .Fields("削除日付") = objRec.Fields("削除日付").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub
'Ver.2.00βより追加
'---------------------------------
Public Sub 各種設定()
On Error GoTo 終了
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_各種設定")
    
    'T_各種設定
    Set objRec = ADO_CN.Execute("T_各種設定", , adCmdTable)
    DoCmd.RunSQL "DELETE * FROM T_各種設定"
    While Not objRec.EOF 'テーブルの最後になれば終了
        With rst
            .AddNew
            .Fields("パラメータ") = objRec.Fields("パラメータ").Value
            .Fields("設定値") = objRec.Fields("設定値").Value
            .Update
        End With
        objRec.MoveNext
    Wend
終了:
End Sub

M_在庫管理

M_在庫管理のVBAソースコード

Option Compare Database
Option Explicit

'---------------------------------
'検索履歴をT_検索履歴に記録するサブルーチン
'txt：検索ワード
'---------------------------------
Sub 検索履歴(txt As String)
On Error GoTo 終了
    Dim rst As DAO.Recordset
    
    '重複データなら検索履歴として追記しない
    If Nz(DLookup("検索履歴", "T_検索履歴", "検索履歴 = '" & txt & "'"), "empty") = "empty" Then
        Set rst = CurrentDb.OpenRecordset("T_検索履歴")
        With rst
            .AddNew
            .Fields("検索履歴") = Nz(txt, "")
            .Update
        End With
        
        rst.Close
        Set rst = Nothing
    End If
    Exit Sub
終了:
    Call エラーログ("M_在庫管理", "検索履歴")
End Sub

'---------------------------------
'サブフォームの項目をダブルクリックした時の処理
'strForm：サブフォーム名
'---------------------------------
Public Sub 処理(strForm As Form)
On Error GoTo 終了
    Select Case strForm.Parent.Name 'サブフォームの親フォーム名で処理を振り分け
        Case "F_安全在庫"
            '特になし
        Case "F_在庫検索"
            '特になし
        Case "F_入出庫履歴"
            '特になし
        Case "F_BOM"
                Forms![F_BOM]![cmb_親品目コード].Value = Forms![F_BOM]![SF_BOM]![親品目コード].Value
                Forms![F_BOM]![lbl_親品目型式].Caption = Forms![F_BOM]![SF_BOM]![T_品目.品目型式].Value
                Forms![F_BOM]![cmb_子品目コード].Value = Forms![F_BOM]![SF_BOM]![品目コード].Value
                Forms![F_BOM]![lbl_子品目型式].Caption = Forms![F_BOM]![SF_BOM]![T_品目_1.品目型式].Value
                Forms![F_BOM]![txt_数量].Value = Forms![F_BOM]![SF_BOM]![数量].Value
                Forms![F_BOM]![cmb_単位].Value = Forms![F_BOM]![SF_BOM]![T_単位.単位コード].Value
                Forms![F_BOM]![lbl_単位].Caption = Forms![F_BOM]![SF_BOM]![T_単位.単位].Value
                Forms![F_BOM]![cmb_保管場所].Value = Forms![F_BOM]![SF_BOM]![T_保管場所.保管場所コード].Value
                Forms![F_BOM]![lbl_保管場所].Caption = Forms![F_BOM]![SF_BOM]![T_保管場所.保管場所].Value
        Case "F_入出庫処理"
            If Forms![F_入出庫処理]![SF_品目]![削除].Value = True Then
                MsgBox "削除された品目です"
                GoTo 終了
            Else
                Forms![F_入出庫処理]![cmb_品目].Value = Forms![F_入出庫処理]![SF_品目]![品目コード].Value
                Forms![F_入出庫処理]![lbl_品目].Caption = Forms![F_入出庫処理]![SF_品目]![品目型式].Value
                Forms![F_入出庫処理]![cmb_品目].BackColor = vbWhite
                Forms![F_入出庫処理]![txt_数量].SetFocus
            End If
    End Select
    Exit Sub
終了:
    Call エラーログ("M_在庫管理", "ReadDatabase")
End Sub

'---------------------------------
'テーブルからの読み込み
'引数1 : strTable : テーブル
'引数2 : strField : 項目
'返り値 ： フィールドの値（文字列）
'---------------------------------
Public Function ReadDatabase(ByVal strTable As String, ByVal strField1 As String, ByVal strParameter As String, ByVal strField2 As String) As String
On Error GoTo 終了
    Dim sql As String
    Dim rst As DAO.Recordset
    
    sql = "SELECT * FROM " & strTable & " WHERE " & strField1 & "= '" & strParameter & "'"
    Set rst = CurrentDb.OpenRecordset(sql)
    ReadDatabase = Nz(rst.Fields(strField2), "")
    
    rst.Close
    Set rst = Nothing
    Exit Function
終了:
    Call エラーログ("M_在庫管理", "ReadDatabase")
End Function

'---------------------------------
'テーブルの最終行のフィールド名のデータを取得する
'strTable=テーブル名
'strFiele=フィールド名
'---------------------------------
Public Function GetDatabaeLast(ByVal strTable As String, ByVal strField As String) As String
On Error GoTo 終了
    Dim sql As String
    Dim rst As DAO.Recordset
    
    If IsNull(strTable) Or IsNull(strField) Then
        GetDatabaeLast = ""
        Exit Function
    End If
    
    sql = "SELECT * FROM " & strTable
    Set rst = CurrentDb.OpenRecordset(sql)
    rst.MoveLast
    GetDatabaeLast = Nz(rst.Fields(strField), "")

    rst.Close
    Set rst = Nothing
    Exit Function
終了:
    Call エラーログ("M_在庫管理", "GetDatabaeLast")
End Function

'---------------------------------
' Excelからのインポート
'---------------------------------
Public Sub ImportFromExcel(strTable As String)
On Error GoTo 終了
    If strFileName = "" Then strFileName = "在庫管理システム・元データ"
    Dim str範囲 As String
    Dim strTable2 As String

    Dim rst As DAO.Recordset
    strTable2 = "T_" & strTable
    Set rst = CurrentDb.OpenRecordset(strTable2)
    str範囲 = strTable & "!B1:K65535"
    
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTable2, strFileName, True, str範囲
    MsgBox "インポートしました"
    rst.Close
    Set rst = Nothing
    Exit Sub
終了:
    Call エラーログ("M_在庫管理", "ImportFromExcel")
    If Err.Number = 3011 Then
        MsgBox "ファイルが見つかりませんでした。" & vbCr & "ファイルはマイドキュメントにおいてください。"
    Else
        MsgBox "インポートできませんでした"
        Debug.Print Err.Number
    End If
End Sub

'---------------------------------
Public Sub 並び替え(ByVal subForm As Control, ByVal strField As String)
    
    subForm.Form.OrderBy = strField '並べ替えの基準とするフィールドを設定
    subForm.Requery

End Sub

'---------------------------------
Public Sub エラーログ(ByVal m As String, ByVal p As String)
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("T_エラーログ")
    With rst
        .AddNew
        .Fields("日時") = Now
        .Fields("エラー番号") = Err.Number
        .Fields("エラーメッセージ") = Err.Description
        .Fields("エラーモジュール") = m
        .Fields("エラープロシージャ") = p
        .Update
        .Close
    End With
    Set rst = Nothing
End Sub