自分がMicrosoft Accessで業務アプリケーションを製作するときに、ほぼ共通して必ず仕込んでいるコードを紹介する。
汎用性はそこそこ高いと思うので参考にしてくれたら幸いだ。
条件付きで終了時にデータベース最適化
本番リリース版（拡張子がaccde）に限り、アプリケーション終了時に自分自身のファイルサイズが既定値を超えていたらデータベースの最適化を行う。
定数LIMITはConst定義されているものとする。データベース本体がSQL Server等ではなくローカルにある場合限定だ。
Private Sub Form_Unload(Cancel As Integer)
Dim nSize As Long
If Right(CurrentDb.Name, 5) <> "accde" Then Exit Sub
nSize = FileLen(CurrentDb.Name) / 1024
If nSize > LIMIT Then
SetOption "Auto Compact", True
MsgBox "ファイルサイズが肥大化してきたので最適化してから終了します", vbInformation, TITLE
Else
SetOption "Auto Compact", False
End If
Application.Quit
End Sub
ローカルデータベースは壊れやすいので、このタイミングで自分自身をファイルサーバにバックアップするのも良い。
Dim sMyName As String, sBackupFolder As String, sToFile As String
Dim oFSO As Object, File
sMyName = CurrentDb.Name
Set oFSO = CreateObject("Scripting.FileSystemObject")
' 自分自身のバックアップ
sBackupFolder = oFSO.BuildPath(CurrentProject.Path, "SystemBackup") ' バックアップフォルダ
If Not oFSO.FolderExists(sBackupFolder) Then oFSO.CreateFolder sBackupFolder ' バックアップフォルダが無ければ作成
sToFile = oFSO.BuildPath(sBackupFolder, oFSO.GetBaseName(sMyName) & "_" & Format(Now, "yymmddhhmmss") & "." & oFSO.GetExtensionName(sMyName))
oFSO.CopyFile sMyName, sToFile ' コピー
' 50日以上経過した古いバックアップファイルを削除
For Each File In oFSO.GetFolder(sBackupFolder).Files
If LCase(oFSO.GetExtensionName(File)) = "accde" And DateDiff("d", File.DateLastModified, Date) > 50 Then oFSO.DeleteFile File
Next
「コンテンツの有効化」をクリックしてもらうために
お客様先のポリシー設定によっては、初回起動時に「セキュリティの警告」が表示される。
「コンテンツの有効化」をクリックしてもらうためのガイドを載せた「解除フォーム」を用意し、Accessを開いたとき最初に表示される既定のフォームに設定する。
「コンテンツの有効化」がクリックされるまで、ガイドは毎回表示される。有効化がクリックされると、リボンやメニュー、ナビゲーションウィンドウ（テーブルやクエリの一覧）を隠した上で、本来のメインフォームに制御を移す。
Private Sub Form_Load()
CommandBars("Menu Bar").Enabled = False 'Access2003用メニュー非表示
DoCmd.ShowToolbar "Ribbon", acToolbarNo 'Access2007用メニュー非表示
DoCmd.Close acForm, Me.Name '解除フォーム(自分自身)は速やかに閉じる
DoCmd.OpenForm "トップメニュー" '本当のメインフォーム
End Sub
シフトキーの有効/無効を切り替える
Accessアプリケーションでは、シフトキーを押しながら起動するとスタートアップ時の設定がスキップされる。
これを知っている人にはテーブルやクエリを覗かれてしまうため、普段はシフトキーを無効化しておき、パスワードを知っている管理者のみ、シフトキーの無効を解除できるようにする。
メインフォーム上に配置した「隠しラベル」をダブルクリックするとパスワードを要求される。accde（mde）形式で保存し、コードやフォームを保護しておくと尚良い。
Private Sub 隠しラベル_DblClick(Cancel As Integer)
Dim db As DAO.Database, prp As DAO.Property, s As String, bMode As Boolean
s = InputBox("コマンドを入力して下さい", TITLE)
If s = "" Then Exit Sub
Set db = CurrentDb
bMode = (s = "パスワード") 'Trueで起動時のSHIFTキー有効
On Error GoTo CATCH
db.Properties("AllowBypassKey") = bMode
Application.Quit
CATCH:
If Err <> 3270 Then Exit Sub
Set prp = db.CreateProperty("AllowBypassKey", dbBoolean, bMode)
db.Properties.Append prp
Application.Quit
End Sub
プレビュー時に印刷ボタンとPDF出力ボタンを表示する
サブフォーム上のボタンからレポートをプレビューで表示したとき、そのまま印刷やPDF出力ができると便利だ。
そのための汎用共通メソッドを定義し、再利用する。
動作イメージ
サブフォームに社員の人事台帳を表示するボタン [詳細] を置く。
プレビューウィンドウ（人事台帳）の左上にボタンが表示されている。
実装方法
DoCmd.OpenReportメソッドをそのまま置き換え可能な汎用共通メソッドを定義する。
Windows APIのSetParentを使用し、「ボタンフォーム」の親ウィンドウにレポートプレビューのウィンドウを指定している。
汎用共通メソッドを通して開かれたレポートプレビューには、印刷ボタンとPDF出力ボタンが表示される。
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Function PopupReport(ReportName, Optional FilterName, Optional WhereCondition, Optional WindowMode As AcWindowMode = acWindowNormal, Optional OpenArgs)
On Error GoTo CATCH
DoCmd.OpenReport ReportName, acViewPreview, FilterName, WhereCondition, WindowMode, OpenArgs
DoCmd.OpenForm "ボタンフォーム"
DoCmd.MoveSize 0, 0
Forms("ボタンフォーム").Tag = ReportName
SetParent Forms("ボタンフォーム").Hwnd, Reports(ReportName).Hwnd
DoCmd.SelectObject acReport, ReportName, False
Exit Function
CATCH:
MsgBox Err.Description, vbCritical, TITLE
End Function
DoCmd.OpenReport をそのまま PopupReport に変更するだけで利用できる。
Private Sub cmd詳細_Click()
DoCmd.OpenReport "人事台帳レポート", , "社員番号='" & Me.社員番号 & "'"
End Sub
Private Sub cmd詳細_Click()
PopupReport "人事台帳レポート", , "社員番号='" & Me.社員番号 & "'"
End Sub
印刷ボタンとPDF出力ボタンは、フォーム「ボタンフォーム」に並べる。
Private Sub cmd印刷_Click()
On Error Resume Next
DoCmd.SelectObject acReport, Me.Tag, False
DoCmd.RunCommand acCmdPrint
End Sub
Private Sub cmdPDF出力_Click()
DoCmd.OutputTo acOutputReport, Me.Tag, acFormatPDF, Me.Tag & "人事台帳.pdf"
End Sub
監査ログ
内部統制に対する意識の高まりから、業務アプリケーションが監査ログを記録することは一般的になっている。
ログの記録
誰が（ログオンユーザ名）、いつ、どこで（ログオン端末名）、何をしたかを、専用のテーブルにinsertする。
ユーザ名と端末名はIWshRuntimeLibrary.WshNetworkで取得できる。
Public Sub WriteLog(Message As String, Optional Category As String = "I99")
Dim db As DAO.Database
Dim wsh As IWshRuntimeLibrary.WshNetwork
Set db = CurrentDb
Set wsh = New IWshRuntimeLibrary.WshNetwork
db.Execute "insert into ログ (種類,メッセージ,ユーザ名,マシン名) values('" & Category & "','" & Message & "','" & wsh.UserName & "','" & wsh.ComputerName & "')"
End Sub
日時のフィールドは=Now()を既定値としておくこと。
古いログを削除
30日以前のログを削除する場合、アプリケーション起動時にCleanLog 30のように呼び出して使う。
Public Sub CleanLog(Day As Integer)
Dim db As DAO.Database
Dim removeDate As Date
removeDate = DateAdd("d", -Day, Now)
WriteLog Format(removeDate, "yyyy/mm/dd hh:mm") & " より前のログを消去します", "I05"
Set db = CurrentDb
db.Execute "delete from ログ where 日時<#" & removeDate & "#"
End Sub
データベース操作系汎用メソッド
テーブル存在チェック
引数で渡したテーブル名が存在したらTrueを返す
Public Function TableExists(Table As String) As Boolean
Dim db As DAO.Database, td As DAO.TableDef
Set db = CurrentDb
TableExists = True
For Each td In db.TableDefs
If td.Name = Table Then Exit Function
Next
TableExists = False
End Function
データ型の強制変更
SQLのALTER TABLEを使用。
DoCmd.TransferSpreadsheet acImportでExcelからテーブルにインポートすると、データ型が期待通りにならない場合があるので、あとから強制変更するのに使う。
Public Sub AlterFieldType(Table As String, FieldType As String, FieldName As String)
Dim db As DAO.Database
Set db = CurrentDb
db.Execute "alter table [" & Table & "] alter column [" & FieldName & "] " & FieldType
If FieldType = "long" Then
db.TableDefs(Table).Fields(FieldName).Properties("Format") = "General Number"
End If
End Sub
フィールド名の変更
前項同様、Excelからテーブルにインポートした後で修正したい場合に使う。
Public Sub AlterFieldName(Table As String, OldName As String, NewName As String)
Dim db As DAO.Database, td As DAO.TableDef
Set db = CurrentDb
Set td = db.TableDefs(Table)
td.Fields(OldName).Name = NewName
End Sub
テーブルの最終更新日時を取得
Public Function GetLastUpdate(Table As String) As Date
Dim db As DAO.Database
Set db = CurrentDb
GetLastUpdate = db.TableDefs(Table).LastUpdated
End Function