アクセス履歴付き ログイン画面を作る（Access）（サンプル付き）

Option Compare Database
Option Explicit
'---------------------------------
Private Sub Form_Load()
    Me.txt_パスワード.InputMask = "password"    'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    'リボンを非表示
    'DoCmd.ShowToolbar "Ribbon", acToolbarNo    'リボンを消す際は行頭のコメントを消去
    
    'Accessを最小化
    'CloseWindow Application.hWndAccessApp      'リボンを消す際は行頭のコメントを消去
    
End Sub
'---------------------------------
Private Sub cmd_ログイン_Click()
    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_ログイン履歴", dbOpenTable)
    
    '---------------------------------
    '関数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_メイン")
    If lngLoginID <> 0 Then MsgBox "ログインしました"
    
End Sub
'---------------------------------
Private Sub cmd_PW変更_Click()
    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
End Sub
'---------------------------------
Private Sub txt_パスワード_Enter()
    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
End Sub
'---------------------------------
Private Sub chk_表示_Click()
    With Me.txt_パスワード
        If chk_表示.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password"
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
End Sub

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()
    Dim sql As String
    Dim rst As DAO.Recordset
    
    Me.txt_旧パスワード.InputMask = "password"      'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    Me.txt_新パスワード.InputMask = "password"      'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    Me.txt_新パスワード再.InputMask = "password"    'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
    
    '---------------------------------
    '関数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
End Sub
'---------------------------------
Private Sub chk_表示旧_Click()
    With Me.txt_旧パスワード
        If chk_表示旧.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password" 'InputMaskはパスワード形式、即ち「*****」とマスクすることです。変更しないでください。
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
End Sub
'---------------------------------
Private Sub chk_表示新_Click()
    With Me.txt_新パスワード
        If chk_表示新.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password"
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
End Sub
Private Sub chk_表示新再_Click()
    With Me.txt_新パスワード再
        If chk_表示新再.Value = True Then
            .InputMask = ""
        Else
            .InputMask = "Password"
        End If
        .SetFocus
        .SelStart = .SelLength
    End With
End Sub
'---------------------------------
Private Sub cmd_更新_Click()
    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
            
        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
End Sub
'---------------------------------
Private Sub cmd_cancel_Click()
    DoCmd.Close
End Sub<

Option Compare Database
Option Explicit

'---------------------------------
Private Sub Form_Load()
    '---------------------------------
    'サブルーチンFormSizeはM_画面にあります
    '---------------------------------
    Call FormSize(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()
    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

Option Compare Database

'---------------------------------
'SHA256ハッシュ値を求める関数
's：ハッシュ値を求める文字列
'---------------------------------
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

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

Option Compare Database
'---------------------------------
    'ASCIIコードについて
    '数字:48～57
    'アルファベット大文字:65～90
    'アルファベット小文字:97～122
    '記号:33～47と58～64と91～96と123～126
    '本来なら正規表現で書くとよいのですが、Regex.IsMatchがなぜか使えず。
'---------------------------------
'---------------------------------
'ログインパスワードの文字チェックを行う
'引数1：strText（パスワード文字列）
'引数2:t（判定するタイプ）
'返り値:True/False
'---------------------------------
Public Function Is英数記号(ByVal strText As String, ByVal t As Byte) As Boolean
    '---------------------------------
    'tはタイプ(0~3)
    '0:英数（区別なし）
    '1:英数区別（大文字小文字区別）
    '2:英数記号（区別なし）
    '3:英数記号区別（大文字小文字区別）
    '---------------------------------
    Dim intASC As Integer  'ASCIIコード
    Dim b大文字 As Boolean '大文字かどうか
    Dim b小文字 As Boolean '小文字かどうか
    Dim b数字 As Boolean   '数字かどうか
    Dim b記号 As Boolean   '記号かどうか
    Dim cnt As Byte 'ループカウント
    
    '初期値入力
    cnt = 1
    b大文字 = False
    b小文字 = False
    b数字 = False
    b記号 = False
    
    '文字列の文字数分だけループ処理
    Do While cnt <= Len(strText)
    
        'Asc関数を使用して、任意の文字の文字コードを取得
        intASC = Asc(Mid(strText, cnt, 1))
        
        '取得した文字コードが英数字かどうかチェック
        If Is数字(intASC) = True Then b数字 = True
        If Is大文字(intASC) = True Then b大文字 = True
        If Is小文字(intASC) = True Then b小文字 = True
        If Is記号(intASC) = True Then b記号 = True
        'ループ用変数のカウントアップ
        cnt = cnt + 1
    Loop
    
    If b数字 = False Then  '数字は必須
        Is英数記号 = False
        Exit Function
    End If
    
    Select Case t
        Case 0    '0:英数（区別なし）
            If b大文字 = True Or b小文字 = True Then Is英数記号 = True Else Is英数記号 = False
        Case 1    '1:英数（大文字小文字区別）
            If b大文字 = True And b小文字 = True Then Is英数記号 = True Else Is英数記号 = False
        Case 2    '2:英数記号（区別なし）
            If b記号 = True And (b大文字 = True Or b小文字 = True) Then Is英数記号 = True Else Is英数記号 = False
        Case 3    '3:英数記号（大文字小文字区別）
            If b記号 = True And b大文字 = True And b小文字 = True Then Is英数記号 = True Else Is英数記号 = False
    End Select
End Function
'---------------------------------
Private Function Is数字(num As Integer) As Boolean
        '取得した文字が数字かどうかチェック
        If (num >= 48 And num <= 57) Then
            Is数字 = True
        Else
            Is数字 = False
        End If
End Function
'---------------------------------
Private Function Is大文字(num As Integer) As Boolean
        '取得した文字コードが大文字かどうかチェック
        If (num >= 65 And num <= 90) Then
            Is大文字 = True
        Else
            Is大文字 = False
        End If
End Function
'---------------------------------
Private Function Is小文字(num As Integer) As Boolean
        '取得した文字コードが小文字かどうかチェック
        If (num >= 97 And num <= 122) Then
            Is小文字 = True
        Else
            Is小文字 = False
        End If
End Function
'---------------------------------
Private Function Is記号(num As Integer) As Boolean
        '取得した文字コードが記号かどうかチェック
        If (num >= 33 And num <= 47) Or _
            (num >= 58 And num <= 64) Or _
            (num >= 91 And num <= 96) Or _
            (num >= 123 And num <= 126) _
        Then
            Is記号 = True
        Else
            Is記号 = False
        End If
End Function

print sha256("sample")