広告 在庫管理

在庫管理システム－ログイン画面

2022年10月15日

ログイン画面については別途記事を作成しております。

在庫管理システム－ログイン画面
めいあんのIT格闘記
2020.04.16
在庫管理システム－ログイン画面
アクセス履歴付き ログイン画面を作る（Access）（サンプル付き）
https://meian-blog.net/teck/ログイン画面を作る（access）/
在庫管理システムを作っていて、ログインが必要かなと思いました。ハッシュ値（SHA256）の求め方が載っているサイトを見つけましたので、ログイン画面だけのサンプルを作ってみました。アクセス履歴のログ作成機能付きです。Accessユーザーの参考になれば幸いです。

フォーム

起動時に最初に表示されるログイン画面・F_ログイン、パスワード変更画面・F_PW変更、ログイン履歴・F_ログイン履歴（管理者でログインの場合のみ）

ログイン機能により、処理を行うユーザーを分け、履歴に残すようになっています。
新規パスワードに更新する際のパスワード文字列の上限・下限、英数のみか英数記号かを設定できます（テーブル・T_各種設定）。

オプション設定により、当在庫管理システムのAccessファイルを開いた際には「F_ログイン」から始まる設定になっています。
ログイン機能を必要としない場合には、ここを「F_メイン」とするか、空欄にしてください。
なお、ログインしない場合にはメインメニューの管理者用メニューはグレーアウトしたまま、ボタンが押せませんので、コードを書き換える必要があります。
具体的にはF_メインのVBAコードでcmd_○○.Enabled=falseの箇所を削除するかコメントアウトしてください。

VBAコード

以下、在庫管理システムVer.2.10のVBAコードです。

フォーム・F_ログイン画面のVBA

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
On Error GoTo 終了
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    'CloseWindow Application.hWndAccessApp       'Accessを最小化する
    Call FormInit(Me)
    
    Me.txt_パスワード.InputMask = "password"    'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。

    txt_パスワード.IMEMode = acImeModeDisable   'IMEモードオフ
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "Form_Load")
End Sub

'---------------------------------
Private Sub cmd_ログイン_Click()
On Error GoTo 終了
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim rst 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_ログイン履歴")
    
    '---------------------------------
    '関数SHA256はM_SHA256にあります
    '関数GetIPAddress、ComputerName、UserNameはM_M_IPアドレスにあります
    '---------------------------------
    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
            .Fields("コンピュータ名") = ComputerName   '不要であればコメントアウトしてください。
            .Fields("ユーザー名") = UserName           '不要であればコメントアウトしてください。
            .Update
            lngLoginID = 0
            Me.txt_パスワード = ""
            Me.txt_パスワード.SetFocus
        Else
            .AddNew
            .Fields("社員コード") = Me.cmb_社員コード
            .Fields("日時") = Now
            .Fields("成功or失敗") = True
            .Fields("IPアドレス") = GetIPAddress
            .Fields("コンピュータ名") = ComputerName   '不要であればコメントアウトしてください。
            .Fields("ユーザー名") = UserName           '不要であればコメントアウトしてください。
            .Update
            lngLoginID = Me.cmb_社員コード
            
            '書き込んだIDを記憶する
            rs2.MoveLast
            intID = Val(rs2.Fields("ID"))
            If rs1.Fields("権限") = "管理者" Then bAdmin = True Else bAdmin = False
            DoCmd.Close
        End If
    End With
    
    rs1.Close
    Set rs1 = Nothing
    rs2.Close
    Set rs2 = Nothing
    
    If lngLoginID <> 0 Then DoCmd.OpenForm ("F_メイン")
    
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "cmd_ログイン_Click")
End Sub

'---------------------------------
Private Sub cmd_PW変更_Click()
On Error GoTo 終了
    DoCmd.OpenForm "F_PW変更"
    
    If IsNull(cmb_社員コード) Then
        Forms![F_PW変更]![txt_社員コード].SetFocus
    Else
        Forms![F_PW変更]![txt_社員コード].Value = Me.cmb_社員コード
        Forms![F_PW変更]![txt_社員コード].SetFocus
    End If
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "cmd_PW変更_Click")
End Sub

'---------------------------------
Private Sub txt_パスワード_Enter()
On Error GoTo 終了
    Dim rs As DAO.Recordset
    Dim sql As String
    
    If IsNull(Me!cmb_社員コード) Then Exit Sub
    sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.cmb_社員コード
    Set rs = CurrentDb.OpenRecordset(sql)

    If rs.Fields("初期パスワード") = True Then
        MsgBox "初期パスワードを変更してください"
        cmd_PW変更_Click
    End If
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "txt_パスワード_Enter")
End Sub

'---------------------------------
Private Sub chk_表示_Click()
On Error GoTo 終了
    With Me.txt_パスワード
        If chk_表示.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password"
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "chk_表示_Click")
End Sub

'---------------------------------
Private Sub cmd_閉じる_Click()
    DoCmd.Close
    'DoCmd.Quit     'コメントを外すと、終了時にAccessを閉じます。
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_PW変更（パスワード変更）のVBA

Option Compare Database
Option Explicit

    Private lngパスワード長さ下限 As Long
    Private lngパスワード長さ上限 As Long
    Private txt_パスワード形式 As String
    Private intType As Integer
    Const c英数 = 0
    Const c英数区別 = 1
    Const c英数記号 = 2
    Const c英数記号区別 = 3

'---------------------------------
Private Sub Form_Load()
On Error GoTo 終了
    Dim sql As String
    Dim rst As DAO.Recordset
    
    '---------------------------------
    'サブルーチンFormInitはM_画面にあります
    '---------------------------------
    Call FormInit(Me.Form)
    
    txt_旧パスワード.InputMask = "password"      'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    txt_新パスワード.InputMask = "password"      'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    txt_新パスワード再.InputMask = "password"    'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    
    'IMEモードオフ
    txt_旧パスワード.IMEMode = acImeModeDisable
    txt_新パスワード.IMEMode = acImeModeDisable
    txt_新パスワード再.IMEMode = acImeModeDisable
    
    '---------------------------------
    '関数ReadDatabaseはM_外部データベースにあります
    '---------------------------------
    lngパスワード長さ下限 = Val(ReadDatabase("T_各種設定", "パラメータ", "パスワード長さ下限", "設定値"))
    lngパスワード長さ上限 = Val(ReadDatabase("T_各種設定", "パラメータ", "パスワード長さ上限", "設定値"))
    txt_パスワード形式 = ReadDatabase("T_各種設定", "パラメータ", "パスワード形式", "設定値")
    
    Set rst = Nothing
    Select Case txt_パスワード形式
        Case "英数"
            intType = c英数         '0:英数（区別なし）
        Case "英数区別"
            intType = c英数区別     '1:英数（大文字小文字区別）
            txt_パスワード形式 = "英数・大文字小文字区別"
        Case "英数記号"
            intType = c英数記号     '2:英数記号（区別なし）
        Case "英数記号区別"
            intType = c英数記号区別 '3:英数記号（大文字小文字区別）
            txt_パスワード形式 = "英数記号・大文字小文字区別"
    End Select
    Exit Sub
終了:
    Call エラーログ("F_PW変更", "Form_Load")
End Sub

'---------------------------------
Private Sub chk_表示旧_Click()
On Error GoTo 終了
    With Me.txt_旧パスワード
        If chk_表示旧.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password" 'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
    Exit Sub
終了:
    Call エラーログ("F_PW変更", "chk_表示旧_Click")
End Sub

'---------------------------------
Private Sub chk_表示新_Click()
On Error GoTo 終了
    With Me.txt_新パスワード
        If chk_表示新.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password"
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
    Exit Sub
終了:
    Call エラーログ("F_PW変更", "chk_表示新_Click")
End Sub

'---------------------------------
Private Sub chk_表示新再_Click()
On Error GoTo 終了
    With Me.txt_新パスワード再
        If chk_表示新再.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password"
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
    Exit Sub
終了:
    Call エラーログ("F_PW変更", "chk_表示新再_Click")
End Sub

'---------------------------------
Private Sub cmd_更新_Click()
On Error GoTo 終了
    Dim sql As String
    Dim rst As DAO.Recordset
    Dim IsCheck As Boolean

    '社員コード入力チェック
    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
    
    '---------------------------------
    'パスワードの文字をチェックをする
    '関数Is英数記号はM_文字列にあります
    '---------------------------------
    IsCheck = Is英数記号(Me.txt_新パスワード, intType)
            
    '新パスワード入力チェック
    If Len(Me.txt_新パスワード) < lngパスワード長さ下限 _
        Or Len(Me.txt_新パスワード) > lngパスワード長さ上限 _
        Or IsCheck = False Then
        MsgBox "パスワードは" & _
            lngパスワード長さ下限 & "文字以上" & _
            lngパスワード長さ上限 & "文字以下の" & _
            txt_パスワード形式 & "にしてください"
        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)
    
    '---------------------------------
    '関数SHA256はM_SHA256あります
    '---------------------------------
    With rst
        .Edit
        .Fields("パスワード") = SHA256(Me.txt_新パスワード) 'パスワードのハッシュ値を入力
        .Fields("平文") = ""
        .Fields("初期パスワード") = False
        .Update
        MsgBox "更新しました"
    End With
    
    rst.Close
    Set rst = Nothing
    
    If SysCmd(acSysCmdGetObjectState, acForm, "F_ログイン") = 1 Then 'F_ログインが開いているかどうか
        Forms![F_ログイン]![txt_パスワード].Value = Me.txt_新パスワード.Value
        Forms![F_ログイン]![cmd_ログイン].SetFocus
    End If
    DoCmd.Close

    Exit Sub
終了:
    Call エラーログ("F_PW変更", "cmd_更新_Click")
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_ログイン履歴の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

社員コード（番号）に文字列がある場合

社員番号にアルファベットなどの文字列を含む場合には本来の社員番号を格納するフィールドを追加するとよいかと思います。
従来の社員コードには重複しない番号を振ってください。ここをなくすとクエリも変更しなければなりません。ここでは文字列の社員番号を使った例を示します。

テーブル「T_社員」に「社員番号」を「短いテキスト」で追加。
ログイン画面ではコンボボックスをテキストボックスに変えます。
（コンボボックス）cmb_社員コード　➡　（テキストボックス）txt_社員コード

フォーム・「F_ログイン」の「cmd_ログイン_Click」のVBAコードを以下のように変更します。
オリジナル箇所は行頭でコメントアウトし、変更箇所はその直下の行にインデントしない状態で記述。

Private Sub cmd_ログイン_Click()
On Error GoTo 終了
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim rst As DAO.Recordset
    Dim sql As String

    'If IsNull(Me.cmb_社員コード) Then
If IsNull(Me.txt_社員コード) Then     ' 社員番号が文字列の場合
        MsgBox "社員コードを入力してください"
        Exit Sub
    End If
    
    If IsNull(Me.txt_パスワード) Then
        MsgBox "パスワードを入力してください"
        Exit Sub
    End If
    
    'sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.cmb_社員コード
sql = "SELECT * FROM T_社員 WHERE 社員番号='" & Me.txt_社員コード & "'"     ' 社員番号が文字列の場合
    Set rs1 = CurrentDb.OpenRecordset(sql)
    Set rs2 = CurrentDb.OpenRecordset("T_ログイン履歴")
    '---------------------------------
    '関数SHA256はM_SHA256にあります
    '関数GetIPAddress、ComputerName、UserNameはM_M_IPアドレスにあります
    '---------------------------------
    If rs1.EOF Then
        MsgBox "レコードが見つかりません"
        Exit Sub
    End If
lngLoginID = Val(rs1.Fields("社員コード"))  ' 社員番号が文字列の場合
    
    With rs2
        If rs1.Fields("パスワード") <> SHA256(Me.txt_パスワード) Then
            MsgBox "パスワードが違います"
            .AddNew
            '.Fields("社員コード") = Me.cmb_社員コード
.Fields("社員コード") = lngLoginID     ' 社員番号が文字列の場合
            .Fields("日時") = Now
            .Fields("成功or失敗") = False
            .Fields("IPアドレス") = GetIPAddress
            .Fields("コンピュータ名") = ComputerName   '不要であればコメントアウトしてください。
            .Fields("ユーザー名") = UserName           '不要であればコメントアウトしてください。
            .Update
            lngLoginID = 0
            Me.txt_パスワード = ""
            Me.txt_パスワード.SetFocus
        Else
            .AddNew
            '.Fields("社員コード") = Me.cmb_社員コード
.Fields("社員コード") = lngLoginID     ' 社員番号が文字列の場合
            .Fields("日時") = Now
            .Fields("成功or失敗") = True
            .Fields("IPアドレス") = GetIPAddress
            .Fields("コンピュータ名") = ComputerName   '不要であればコメントアウトしてください。
            .Fields("ユーザー名") = UserName           '不要であればコメントアウトしてください。
            .Update
            'lngLoginID = Me.cmb_社員コード
            
            '書き込んだIDを記憶する
            .MoveLast
            intID = Val(rs2.Fields("ID"))
            If rs1.Fields("権限") = "管理者" Then bAdmin = True Else bAdmin = False
            DoCmd.Close
        End If
    End With
    
    rs1.Close
    Set rs1 = Nothing
    rs2.Close
    Set rs2 = Nothing
    
    If lngLoginID <> 0 Then DoCmd.OpenForm ("F_メイン")
    
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "cmd_ログイン_Click")
End Sub

Private Sub cmd_PW変更_Click()
On Error GoTo 終了
    DoCmd.OpenForm "F_PW変更"
    
    'If IsNull(cmb_社員コード) Then
If IsNull(txt_社員コード) Then
        Forms![F_PW変更]![txt_社員コード].SetFocus
    Else
        'Forms![F_PW変更]![txt_社員コード].Value = Me.cmb_社員コード
Forms![F_PW変更]![txt_社員コード].Value = txt_社員コード
        Forms![F_PW変更]![txt_社員コード].SetFocus
    End If
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "cmd_PW変更_Click")
End Sub

'---------------------------------
Private Sub txt_パスワード_Enter()
On Error GoTo 終了
    Dim rs As DAO.Recordset
    Dim sql As String
    
    'If IsNull(Me!cmb_社員コード) Then Exit Sub
If IsNull(txt_社員コード) Then Exit Sub
    'sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.cmb_社員コード
sql = "SELECT * FROM T_社員 WHERE 社員番号='" & Me.txt_社員コード & "'"
    Set rs = CurrentDb.OpenRecordset(sql)

    If rs.Fields("初期パスワード") = True Then
        MsgBox "初期パスワードを変更してください"
        cmd_PW変更_Click
    End If
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "txt_パスワード_Enter")
End Sub

'---------------------------------
Private Sub txt_パスワード_Enter()
On Error GoTo 終了
    Dim rs As DAO.Recordset
    Dim sql As String
    
    'If IsNull(Me!cmb_社員コード) Then Exit Sub
If IsNull(txt_社員コード) Then Exit Sub
    'sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.cmb_社員コード
sql = "SELECT * FROM T_社員 WHERE 社員番号='" & Me.txt_社員コード & "'"
    Set rs = CurrentDb.OpenRecordset(sql)

    If rs.Fields("初期パスワード") = True Then
        MsgBox "初期パスワードを変更してください"
        cmd_PW変更_Click
    End If
    Exit Sub
終了:
    Call エラーログ("F_ログイン", "txt_パスワード_Enter")
End Sub

フォーム・「F_メイン」の「cmd_PW変更_Click」を以下のように変更します。

Private Sub cmd_PW変更_Click()
On Error GoTo 終了
    
Dim rst As DAO.Recordset    ' 社員番号が文字列の場合
Dim sql As String           ' 社員番号が文字列の場合
sql = "SELECT * FROM T_社員 WHERE 社員コード =" & lngLoginID     ' 社員番号が文字列の場合
Set rst = CurrentDb.OpenRecordset(sql)

    DoCmd.OpenForm "F_PW変更"
    
    'Forms![F_PW変更]![txt_社員コード].Value = lngLoginID
Forms![F_PW変更]![txt_社員コード].Value = rst.Fields("社員番号")
    Forms![F_PW変更]![txt_社員コード].SetFocus
    Exit Sub
終了:
    Call エラーログ("F_メイン", "cmd_PW変更_Click")
End Sub

一応デバッグして、エラーはない状態にはなりました。
旧バージョンからのインポート機能やExcelからのインポートも要修正ですが、実施していません。

-在庫管理