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

2020年6月13日

はじめに

在庫管理システムを作るにあたって、複数社員で使用するにはログイン画面が必要であると思いつつ、今まで盛り込んできませんでした。

ログイン画面のみをテストで作りました。目指すはただ1点、

・パスワードはハッシュ値で管理する

サンプルにはハッシュ値の元になる文字列（平文）がありますが、動作確認後には削除してお使いください。

ハッシュ値にはSHA256を利用しました。

バージョン履歴

日付	バージョン	改訂内容
2020/04/16	0.1	とりあえず
2020/04/30	0.2	ログイン履歴を記録
2020/05/05	0.3	テーブル名変更。ログイン履歴画面変更。パスワード更新画面追加。他微修正。
2020/05/08	0.4	ログイン履歴の一覧をExcelにエクスポートする機能追加。
2020/06/03	0.5	テーブル名変更、「T_」を付加。VBAにバグがあったので修正。
2020/06/11	0.6	「T_社員」テーブルに新規パスワードフィールド追加して、「F_新規登録」フォーム削除。バグ修正。

使いやすいようにご自由に改変してお使いください。

在庫管理システムにフォームやクエリをエクスポートして使えるようにテーブル名を変更しました。

「新規登録」フォームを削除し、「T_社員」テーブルに「初期パスワード」フィールドを追加しました。この値がTrueの時に、強制的に「F_PW変更」フォームに飛びます。パスワードを変更するまで「初期パスワード」フィールドはFalseになりません。

フォームのプロパティ（共通）

プロパティ	変更後の設定
ポップアップ	はい
レコードセレクタ	いいえ
移動ボタン	いいえ
境界線スタイル	なし

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

平文のフィールドは動作確認後には削除してお使いください。

ID	オートナンバー型
社員コード	数値型
日時	短いテキスト
成功or失敗	Yes/No型
IPアドレス	短いテキスト

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

☑：成功
□：失敗

ID	オートナンバー型
バージョン	数値型
更新内容	テキスト型

ログイン画面

ログインが管理者である場合にはログイン履歴画面を表示するようにしてあります。

フォーム

ログイン画面

以下のコントロールを配置します。

社員コード：コンボボックス（名前：cmb_社員コード）
パスワード：テキストボックス（名前：txt_パスワード）

ログイン：コマンドボタン（名前：cmd_ログイン）
パスワード変更：コマンドボタン（名前：cmd_PW変更）
~~新規登録：コマンドボタン（名前：cmd_新規登録）~~

cmb_社員コード一覧に登録のない社員さんが登録依頼をする場合に管理者にEメールするということも可能かと思います。下記記事も参考にしてみてください。

: AccessデータベースからEメールを送る（サンプル付き）

在庫管理システムを作っていて「【安全在庫】に引っかかる品目が現れたら管理者にEメールを飛ばしたい」と思っていました。「さすがにAccessからはEメールは送れないだろう」と調べもしておりませんでした ...

続きを見る

VBAコード

Option Compare Database

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

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

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

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

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

Option Compare Database

Private Sub cmd_ログイン_Click()

Dim rs1 As DAO.Recordset

Dim rs2 As DAO.Recordset

Dim sql As String

If IsNull(Me.cmb_社員コード) Then

MsgBox "社員コードを入力してください"

Exit Sub

End If

If IsNull(Me.txt_パスワード) Then

MsgBox "パスワードを入力してください"

Exit Sub

End If

sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.cmb_社員コード

Set rs1 = CurrentDb.OpenRecordset(sql)

Set rs2 = CurrentDb.OpenRecordset("T_ログイン履歴", dbOpenTable)

With rs2

If rs1.EOF Then

MsgBox "レコードがみつかりません"

ElseIf rs1.Fields("パスワード") <> SHA256(Me.txt_パスワード) Then

MsgBox "パスワードが違います"

.AddNew

.Fields("社員コード") = Me.cmb_社員コード

.Fields("日時") = Now

.Fields("成功or失敗") = False

.Fields("IPアドレス") = GetIPAddress

.Update

lngLoginID = 0

Else

MsgBox "ログインしました"

.AddNew

.Fields("社員コード") = Me.cmb_社員コード

.Fields("日時") = Now

.Fields("成功or失敗") = True

.Fields("IPアドレス") = GetIPAddress

.Update

lngLoginID = Me.cmb_社員コード

DoCmd.Close

End If

End With

rs1.Close

Set rs1 = Nothing

rs2.Close

Set rs2 = Nothing

If lngLoginID = lngAdmin Then DoCmd.OpenForm ("F_ログイン履歴")

End Sub

Private Sub cmd_PW変更_Click()

DoCmd.OpenForm "F_PW変更"

If IsNull(txt_社員コード) Then

Forms![F_PW変更]![txt_社員コード].SetFocus

Else

Forms![F_PW変更]![txt_社員コード].Value = Me!cmb_社員コード

Forms![F_PW変更]![txt_社員コード].SetFocus

End If

End Sub

Private Sub txt_パスワード_Enter()

Dim rs As DAO.Recordset

Dim sql As String

sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me!cmb_社員コード

Set rs = CurrentDb.OpenRecordset(sql)

If rs.Fields("初期パスワード") = True Then

MsgBox "初期パスワードを変更してください"

cmd_PW変更_Click

End If

End Sub

パスワード変更画面

フォーム

パスワード変更画面

以下のコントロールを配置します。

社員コード：テキストボックス（名前：txt_社員コード）
旧パスワード：テキストボックス（名前：txt_旧パスワード）
パスワード：テキストボックス（名前：txt_パスワード）
パスワード再入力：テキストボックス（名前：txt_パスワード再）

登録：コマンドボタン（名前：cmd_登録）
キャンセル：コマンドボタン（名前：cmd_Cancel）

VBA

Option Compare Database

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

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

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

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

End Sub

Option Compare Database

Private Sub cmd_Cancel_Click()

Forms![F_ログイン]![cmb_社員コード].SetFocus

DoCmd.Close

End Sub

Private Sub cmd_更新_Click()

Dim rst As DAO.Recordset

If IsNull(Me.txt_社員コード) Then

MsgBox "社員コードを入力してください"

Exit Sub

End If

If IsNull(Me.txt_旧パスワード) Then

MsgBox "今までのパスワードを入力してください"

Exit Sub

End If

If IsNull(Me.txt_新パスワード) Then

MsgBox "新パスワードを入力してください"

Exit Sub

End If

If IsNull(Me.txt_新パスワード再) Then

MsgBox "新パスワード（再）を入力してください"

Exit Sub

End If

If Me.txt_新パスワード.Value <> Me.txt_新パスワード再.Value Then

MsgBox "同じパスワードを入力してください"

Exit Sub

End If

If Me.txt_新パスワード.Value = Me.txt_旧パスワード.Value Then

MsgBox "パスワードは変更されていません"

Exit Sub

End If

sql = "SELECT * FROM T_社員 WHERE 社員コード=" & Me.txt_社員コード

Set rst = CurrentDb.OpenRecordset(sql)

With rst

.Edit

.Fields("パスワード") = SHA256(Me.txt_新パスワード)

.Fields("平文") = Me.txt_新パスワード '動作確認後には削除してください

.Fields("初期パスワード") = False

.Update

MsgBox "更新しました"

End With

rst.Close

Set rst = Nothing

DoCmd.Close

End Sub

ログイン履歴画面

フォーム

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

F_ログイン履歴

以下のコントロールを配置します。

履歴クリア：コマンドボタン（名前：cmd_Clear）
EXCELにエクスポート：コマンドボタン（名前：cmd_エクスポート）
閉じる：コマンドボタン（名前：cmd_Close）

サブフォーム（名前：Q_ログイン履歴のサブフォーム）

クエリ

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

Q_ログイン履歴

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

SELECT T_ログイン履歴.日時, T_合否.[ログイン], T_社員.社員コード, T_社員.社員, T_ログイン履歴.IPアドレス

FROM (T_ログイン履歴 INNER JOIN T_社員 ON T_ログイン履歴.社員コード = T_社員.社員コード) INNER JOIN T_合否 ON T_ログイン履歴.成功or失敗 = T_合否.成功or失敗

ORDER BY T_ログイン履歴.日時 DESC;

SQLビュー

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

SQLビューの開き方

VBAコード

Option Compare Database

Private Sub Form_Resize()

Me.Q_ログイン履歴のサブフォーム.Width = Me.InsideWidth

Me.Q_ログイン履歴のサブフォーム.Height = Me.InsideHeight

End Sub

Private Sub cmd_Clear_Click()

On Error Resume Next

DoCmd.RunSQL "DELETE FROM T_ログイン履歴"

DoCmd.Requery

End Sub

Private Sub cmd_close_Click()

DoCmd.Close

End Sub

Private Sub cmd_エクスポート_Click()

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Q_ログイン履歴", "ログイン履歴.xls", True, "ログイン履歴"

MsgBox ("マイドキュメントにエクスポートしました")

End Sub

標準モジュール

ハッシュ値生成関数

関数名：SHA256

参考URL⇩

www.se-japan.com

ＳＥジャパン株式会社

http://www.se-japan.com/memo/vbscript/

ＳＥジャパン株式会社　ホームページ

IPアドレス取得関数

関数名：GetIPAddress

VBAコード

Option Compare Database
Public lngLoginID As Long
Public Const lngAdmin = 99999

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

Function GetIPAddress() As String

Dim NetAdapters, objNic, strIPAddress
    Set NetAdapters = GetObject("winmgmts:{impersonationLevel=impersonate}!\.rootcimv2") _
                           .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

Option Compare Database

Public lngLoginID As Long

Public Const lngAdmin = 99999

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

Function GetIPAddress() As String

Dim NetAdapters, objNic, strIPAddress

Set NetAdapters = GetObject("winmgmts:{impersonationLevel=impersonate}!\.rootcimv2") _

.ExecQuery("Select * from Win32_NetworkAdapterConfiguration " & _

"Where (IPEnabled = TRUE)")

For Each objNic In NetAdapters 'ネットワークアダプターは、複数ある場合がある

For Each strIPAddress In objNic.IPAddress 'IPは、複数割り当てられている場合がある

GetIPAddress = strIPAddress

Exit For ' １回のみ

End Function

サンプルダウンロード

拡張子.mdb形式にしましたので、Access2002～Access2019で開けると思います。

Ver.0.6（2020/06/11）

ファイルはこちら

最後に

パスワードのSHA256の文字列を簡単に求めます。

VBAのエディタからメニュー【表示】ー【イミディエイトウィンドウ】を選択します。

例えば「sanmple」という文字列のハッシュ値を求めたい場合、イミディエイトウィンドウにて

1	print sha256("sample")

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

イミディエイトウィンドウ

エクスポート

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

エクスポート

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

エクスポート2

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

エクスポート3

完成したら

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

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

www.feedsoft.net

起動時にAccess本体を非表示にし、フォームのみ表示する

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

アプリを作成した場合など、起動時にデータベースウィンドウやリボンなどのAccess本体を非表示にし、フォームのみ表示させたい場合があります。その方法を掲載しています。VBE画面が表示されForm_Open内に,リボンを非表示にするVBAを入力します

-Access
-Access, SHA256, VBA, パスワード, ハッシュ値, ログイン画面

佐々木より:

2020年6月14日 11:10 午前

お世話になっております。
職場で顧客管理システムを構築するために必要なログインフォームを考えていたところ
こちらの記事にたどり着きました。
お伺いしたいのですが、
自宅ＰＣで　print sha256("sample")　を実行すると、
2146232576(80131700)　オートメーションエラー　が出ましたが、
.NET Framework 3.5をインストールすると解消されました。
ですが、職場はセキュリティの都合でインターネットはつながっておらず、
また、外部からＵＳＢメモリなどでデータを持ち込むこともできません。
.Net Framework 4.xで動作するような、なにか解決策はありませんでしょうか。

返信
- meian0607 より:
  
  2020年6月14日 12:52 午後
  
  佐々木様
  コメントありがとうございます。
  
  .net Flameworkのバージョン問題(互換性)があるのですね。
  自宅のPCにも3.5がインストールされていますが｢なぜ古いバージョンの3.5が入っているのだろう？｣と常々思っていましたが、3.5は互換性の点からもないと困るバージョンなのですね。
  .net Flameworkに依存しないとなるとSHA256のアルゴリズムからまるまる計算する関数なりクラスを実装しないといけません。
  ちょっと検索しますと、使えそうなものもありました。(https://wiz-code.net/vb/algorithm/sha256/13_vba.html)
  いずれ書き換えてみようと思いますが、お急ぎでしたら、上記リンクのコード(クラス)に置き換えてみてはいかがでしょうか？
  
  返信

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

はじめに

簡易的にAccessデータベースで在庫管理システムを作成（サンプル付）

バージョン履歴

フォームのプロパティ（共通）

テーブル

ログイン画面

フォーム

AccessデータベースからEメールを送る（サンプル付き）

VBAコード

パスワード変更画面

フォーム

VBA

ログイン履歴画面

フォーム

クエリ

SQLビュー

VBAコード

標準モジュール

ハッシュ値生成関数

IPアドレス取得関数

VBAコード

サンプルダウンロード

最後に

エクスポート

完成したら

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