Access

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

2020年4月16日

サンプルのダウンロードは下にあります。

ハッシュ値には.NET Flamework3.5のSHA256を利用しました。

自動管理システムのご依頼はATDシステムズへ

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

バージョン履歴

日付バージョン改訂内容
2020/04/160.1とりあえず
2020/04/300.2ログイン履歴を記録
2020/05/050.3テーブル名変更。ログイン履歴画面変更。パスワード更新画面追加。他微修正。
2020/05/080.4ログイン履歴の一覧をExcelにエクスポートする機能追加。
2020/06/030.5テーブル名変更、「T_」を付加。VBAにバグがあったので修正。
2020/06/110.6「T_社員」テーブルに新規パスワードフィールド追加して、「F_新規登録」フォーム削除。バグ修正。
2022/10/271.0改良版

テーブル

社員テーブル・T_社員

IDオートナンバー型
社員コード数値型
社員コード短いテキスト
所属短いテキスト
権限短いテキスト
パスワード短いテキスト
平文短いテキスト
初期パスワードYes/No型
登録日日付/時刻型
削除Yes/No型

ログイン履歴テーブル・T_ログイン履歴

コンピュータ名・ユーザー名・ログアウト日時の3つのフィールドはVer.1.00にて追加。

IDオートナンバー型
社員コード数値型
日付日付/時刻型
成功or失敗Yes/No型
IPアドレス短いテキスト
コンピュータ名短いテキスト
ユーザー名短いテキスト
ログアウト日時日付/時刻型

バージョン履歴テーブル・T_バージョン履歴

ログイン画面のバージョン履歴です。

IDオートナンバー型
日付日付/時刻型
バージョン数値型
改訂内容短いテキスト

各種設定テーブル・T_各種設定

在庫管理システムにて使用する設定をVBAコードに直接記入するのではなく、このテーブルに記載するように変更しました。
まだ、VBAコード上に残っているものもあろうかと思いますが、今後のバージョンアップによって、このテーブルに記載していきます。

IDオートナンバー型
パラメータ短いテキスト
設定値短いテキスト

合否テーブル・T_合否

ログイン履歴にのみ使用しているテーブルです。

IDオートナンバー型
成功or失敗Yes/No型
ログイン短いテキスト

フォーム

下図のようにコントロールを配置します。

サブフォームの作り方(F_ログイン履歴画面向け)

新規フォームにて空フォームを呼び出し、【デザイン】タブから【サブフォーム】を選びます。

クエリ

新規クエリにて3つのテーブル(ログイン履歴、社員、合否)を読み込み、結合させます。

以下のSQLを【SQLビュー】にコピペすると上記のクエリがサクッと反映されるかもしれません。

SQLビュー

上記SQLをクエリにコピーするには【作成】タブから【クエリデザイン】を選びます。
【テーブルの選択】は閉じて、現れたウィンドウのタブの部分で右クリックし、【SQLビュー】を選びます。
【SQLビュー】の状態でコードをペーストし、タブから【デザインビュー】を選べば元に戻ります。

SELECT T_ログイン履歴.日時, T_合否.[ログイン], T_社員.社員, T_社員.社員コード, T_ログイン履歴.IPアドレス, T_ログイン履歴.[コンピュータ名], T_ログイン履歴.[ユーザー名]
FROM (T_ログイン履歴 INNER JOIN T_社員 ON T_ログイン履歴.社員コード = T_社員.社員コード) INNER JOIN T_合否 ON T_ログイン履歴.成功or失敗 = T_合否.成功or失敗
ORDER BY T_ログイン履歴.日時 DESC;

VBAコード

フォーム・F_ログインのVBAコード

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

フォーム・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()
    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<

フォーム・F_ログイン履歴のVBAコード

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

標準モジュール

ハッシュ値生成関数の標準モジュール・M_SHA256のVBAコード

関数名:SHA256
参考URL:http://www.se-japan.com/memo/vbscript/

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

IPアドレス取得関数の標準モジュールM_IPアドレスのVBAコード

関数名:GetIPAddress

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        ' 1回のみ
        Next
        Exit For        ' 1回のみ
    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_文字列のVBAコード

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

サブフォームのサイズを調整する標準モジュール・M_画面

'---------------------------------
'サブフォームの大きさを変更するサブルーチン
'frm:フォーム
'ctl:コントロール
'---------------------------------
Public Sub AdjustWidth(strform As Form, strCtrl As Control, lngTop As Long)
    On Error Resume Next
    
    strCtrl.Height = strCtrl.Height * 0.7             '最初にフォームの内側を小さくしておく
    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
    strform.直線1.Width = strform.InsideWidth
End Sub

'---------------------------------
Public Sub FormSize(frm As Form)
    If lngDisplayRes >= 1920 Then frm.Width = 20000 Else frm.Width = 17000
End Sub

その他の標準モジュール・Module1

Option Compare Database
Option Explicit

'---------------------------------
Public lngLoginID As Long       'ログインした社員コード
Public bAdmin As Boolean        '管理者かどうか、管理者ならTrue、そうでなければFalse
Public intID As Integer         'ログインした際のログイン履歴のIDフィールド

'---------------------------------
'データベースからの読み込み
'引数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 Resume Next
    Dim sql As String
    Dim rst As DAO.Recordset
    
    sql = "SELECT * FROM " & strTable & " WHERE " & strField1 & "= '" & strParameter & "'"
    Set rst = CurrentDb.OpenRecordset(sql)
    ReadDatabase = rst.Fields(strField2)
    If IsNull(ReadDatabase) = True Then ReadDatabase = ""
    
    rst.Close
    Set rst = Nothing
End Function

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

    rst.Close
    Set rst = Nothing
End Function

'---------------------------------
' ログアウト日時も記録する場合には、
' 最後に閉じるフォーム内に下記のコードを貼り付け、
' 冒頭のアポストロフィーを削除してコメントを解除してください
'---------------------------------
'閉じる時にログアウト日時を記録
'---------------------------------
'Private Sub cmd_閉じる_Click()
'On Error Resume Next                    'ログインなしに開いた場合にエラーになるため
'    Dim dbs As Database
'    Dim rst As DAO.Recordset
'    Dim sql As String
    
'    Set dbs = CurrentDb
'    Set rst = CurrentDb.OpenRecordset("T_ログイン履歴", dbOpenDynaset)
'    With rst
'        .MoveLast                       '一旦最後に移動しないと機能しない
'        .AbsolutePosition = intID - 1   'ID=intIDの行に移動
'        .Edit
'        .Fields("ログアウト日時") = Now
'        .Update
'        .Close
'    End With
'    Set rst = Nothing
    
'    DoCmd.Close
'End Sub

サンプルダウンロード

拡張子.mdb形式にしましたので、Access2002~Access2021で開けると思います。Ver.1.0(2022/10/27)

データベースを開くとログイン画面がポップアップ表示されます。
最初の1回目はそのウィンドウで右クリックし、「閉じる」をクリックしてください。
次に「コンテンツの有効化」をクリックします。
次回以降はこのデータベースを起動しますと、ログイン画面から使用できます。また編集して使えるようになります。

コンテンツの有効化

サンプルにおける登録済み社員は管理太郎1人だけです。
パスワード欄は「password」の8文字です。
最初のログイン時にパスワード変更を求めますので、初期パスワードを変更してご利用ください。

DOWNLOAD 

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

最後に

パスワードのSHA256の文字列を簡単に求めます。
VBAのエディタからメニュー【表示】ー【イミディエイトウィンドウ】を選択します(あるいはショートカットキー[Ctrl]+G)。
例えば「sanmple」という文字列のハッシュ値を求めたい場合、イミディエイトウィンドウにて

print sha256("sample")

とすることで、sha256のハッシュ値を得られます。コピペだけでなく、行末でEnterキーを押してください。

エクスポート

ログイン画面のないアプリにエクスポートする方法です。テーブル・フォーム・クエリをエクスポートします。エクスポートしたいフォーム等で右クリックして【エクスポート】から下記の画面のように【Access】を選びます。

エクスポート先のデータベースファイルを選択します。例えば、まだログイン画面を実装していない在庫管理システムなどのデータベースファイルを選択します。

【OK】ボタンをクリックします。これで先方のデータベースファイルにフォーム・クエリ・テーブルをエクスポートできます。

.NET Flamework3.5をインストールできない場合

コメントにて.NET Flamework3.5がインストールされていないPCにてSHA256を計算したい旨ありました。そのPCはインターネットに接続されておらず、またUSBメモリはセキュリティ上使用不可になっているとのことで、探しました。こちらのコードが参考になるかと思います。Visual Basic6ですので、.NET用に書き換える必要はありますが。

https://wiz-code.net/vb/algorithm/sha256/13_vba.html

完成したら

完成すると、フォームの表示だけにしたくなります。その際のAccessの設定は下記リンクに記載がありますので参照ください。ここでダウンロードするデータベースは編集できるように下記リンクのような処理は施しておりません。

・フォームオープン時のVBA記述
・Accessのオプション設定

https://www.feedsoft.net/access/guide-form/guidef81.html

-Access
-, , , , ,