Access業務アプリで最初に仕込む汎用的なVBAコード

自分が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 に変更するだけで利用できる。

変更前_OpenReport

Private Sub cmd詳細_Click()
    DoCmd.OpenReport "人事台帳レポート", , "社員番号='" & Me.社員番号 & "'"
End Sub

変更後_PopupReport

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