ログイン画面については別途記事を作成しております。
フォーム
起動時に最初に表示されるログイン画面・F_ログイン、パスワード変更画面・F_PW変更、ログイン履歴・F_ログイン履歴(管理者でログインの場合のみ)
ログイン機能により、処理を行うユーザーを分け、履歴に残すようになっています。
新規パスワードに更新する際のパスワード文字列の上限・下限、英数のみか英数記号かを設定できます(テーブル・T_各種設定)。
オプション設定により、当在庫管理システムのAccessファイルを開いた際には「F_ログイン」から始まる設定になっています。
ログイン機能を必要としない場合には、ここを「F_メイン」とするか、空欄にしてください。
なお、ログインしない場合にはメインメニューの管理者用メニューはグレーアウトしたまま、ボタンが押せませんので、コードを書き換える必要があります。
具体的にはF_メインのVBAコードでcmd_○○.Enabled=falseの箇所を削除するかコメントアウトしてください。
- Accessのオプション
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からのインポートも要修正ですが、実施していません。