きなこSHOW

VBAと日々の戯言

Accessで「お待ちください」メッセージフォームを表示するサンプル

Accessで長い処理を実行している間、なんの音沙汰もないと不安になります。
その対策として、実行中に「お待ちください」みたいなメッセージを表示すれば、ユーザーに少し安心してもらえるかなと思います。
そんな時のためのお待ちくださいフォームを作りました。
コピーしてそのまま使えるサンプルを紹介します。

職場でAccessのちょっとしたツールを作って使っているのですが、
自分が使う分には、あー、このクエリ時間かかるやつだったよなー、
しゃーないタバコでも吸いに行くか、で済むのですが、
他の人に使ってもらうときは、けっこう気を使います。

そもそもクエリの書き方に気を付けて、遅くならないようにするのはもちろんですが、それでも処理に時間がかかってしまう時の対策として、実行中はメッセージを表示して、終わったら消す、みたいなユーザーフォームを使っています。
進行状況をプログレスバーで表示したりとか複雑なことは一切しません。
クエリを実行する前にメッセージを表示して、終わったら閉じるだけの
シンプルなフォームです。

お待ちくださいメッセージフォーム

今回は、Accessのフォーム1本と、標準モジュール1本の構成です。
まずは、フォームオブジェクトの設定から。

完成図

完成図
フォーム名:F_PleaseWait

フォーム名はご自分の命名規則に合わせて変えてくださいませ。
詳細セクションにラベルコントロールをひとつ配置しておきます。

フォームデザイン

フォームデザイン

[書式]
標題 (空白)
既定のビュー 単票フォーム
レコードセレクタ いいえ
移動ボタン いいえ
区切り線 いいえ
スクロールバー いいえ
コントロールボックス はい
閉じるボタン はい
最小化/最大化ボタン なし
[データ]
レコードソース (空白)
[イベント]
開く時 [イベント プロシージャ]
[その他]
ポップアップ はい
作業ウィンドウ固定 はい

フォームのサイズはお好きにどうぞ。

ラベルのプロパティ

名前 lblMsg
標題 ="実行中..." & CHR(13) & CHR(13) & "しばらくお待ちください"

ラベル名もご自分の命名規則に合わせて変更可能。
フォーム名やコントロール名を変更した場合、
以下のソースコード内のコントロール名もそれに合わせて読みかえてください。

フォームモジュール

フォームモジュールに以下を記述します。

Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
    If IsNull(cgs_ToolTitle) = False Then
        Me.Caption = cgs_ToolTitle
    End If
    If IsNull(Me.OpenArgs) = False Then
        Me.lblMsg.Caption = Me.OpenArgs
    End If
End Sub

Public Sub gDispMessage(ByVal vsMsg As String)
On Error Resume Next
    If IsNull(vsMsg) = False Then
        Me.lblMsg.Caption = vsMsg
        Me.Repaint
    End If
End Sub

フォームを開く時のイベント「Form_Open」では、
まずフォームの標題=タイトルバー文字列にツールのタイトルをセットしているのと、
開く時に引数が渡された場合、それをラベル「lblMsg」の標題にセットします。
引数が渡されない場合は、フォームデザイン時に設定した標題のままフォームを表示します。

Publicプロシージャの「gDispMessage」では、
引数で受け取ったメッセージの内容をラベルの標題にセットし、フォームを再描画します。

フォームの設定は以上です。

標準モジュール側のソースコード

メッセージを渡してフォームを開いたり閉じたりするためのプロシージャは、標準モジュールに記述します。
これをフォームモジュールに書いてしまうと動かないので、必ず標準モジュールに書いてください。

Option Explicit

'--- ツールのタイトル ---
Public Const cgs_ToolTitle  As String = "Sample Tool"

'***************************************************************************
'名称 :gWaitMsg
'機能 :お待ちくださいメッセージフォームを表示する
'引数 :
'   :vbShow   (I )    Boolean        True:表示
'戻り値:True = OK, False = NG
'作成 :2016/08/24 kinaccco
'更新 :
'***************************************************************************
Public Function gWaitMsg(Optional ByVal vbShow As Boolean = False _
                       , Optional ByVal vsOpenArgs As String = "") As Boolean
On Error GoTo Exit_Sec
Const C_WAITFORM_NAME   As String = "F_PleaseWait"
Dim lbHit   As Boolean
Dim lbIsLoaded As Boolean
Dim dbs As Object, obj As AccessObject

    '--- オブジェクト存在チェック ---
    Set dbs = Application.CurrentProject
    
    lbHit = False
    lbIsLoaded = False
    For Each obj In dbs.AllForms
        If obj.Name = C_WAITFORM_NAME Then
            lbHit = True
            lbIsLoaded = obj.IsLoaded
            Exit For
        End If
    Next obj
    
    If lbHit = False Then GoTo Exit_Sec

    '--- パラメータの値に従ってフォームを開く/閉じる ---
    If vbShow Then
        If IsMissing(vsOpenArgs) Then
            If lbIsLoaded = False Then
                DoCmd.OpenForm FormName:=C_WAITFORM_NAME, View:=acNormal
            Else
                Call Form_F_PleaseWait.gDispMessage(vsOpenArgs)
            End If
        Else
            If lbIsLoaded = False Then
                DoCmd.OpenForm FormName:=C_WAITFORM_NAME, View:=acNormal, OpenArgs:=vsOpenArgs
            Else
                Call Form_F_PleaseWait.gDispMessage(vsOpenArgs)
            End If
        End If
        DoCmd.RepaintObject ObjectType:=acForm, ObjectName:=C_WAITFORM_NAME
        Application.Screen.MousePointer = 11
    Else
        Application.Screen.MousePointer = 0
        DoCmd.Close acForm, C_WAITFORM_NAME
    End If

Exit_Sec:
On Error Resume Next

    Set obj = Nothing
    Set dbs = Nothing

    gWaitMsg = True

End Function

まずツールのタイトルとして、宣言セクションにグローバル定数「cgs_ToolTitle」を定義しています。
この定数の文言は任意で、ご自分のツールのタイトルを入力したり、「実行中」など、適宜変更してください。

次にPublicプロシージャの「gWaitMsg」では、
CurrentProject内のすべてのフォームからローカル定数「C_WAITFORM_NAME」に指定したフォーム名が存在するかチェックして、存在しなかった場合このプロシージャを抜けます。
フォームが存在する場合、第1引数が「True」だったらフォームを表示する方に、「False」だったらフォームを閉じる方に分岐します。

フォームを表示する方の処理でやっている事は、
フォームがまだ読み込まれていない場合、フォームの引数に当プロシージャの第2引数であるメッセージを渡してフォームをOpenします。
フォームがすでに読み込まれている場合、フォーム側の「gDispMessage」にメッセージを渡して呼び出します。
どちらの場合も、マウスポインタに砂時計ポインタを表示します。

フォームを閉じる方の処理では、マウスポインタを標準に戻し、フォームを閉じています。

呼び出し例

クエリ名「q_nageee」を実行するときはこんな感じに記述します。

Dim sWaitMsg As String

'--- 月次更新 開始 ---
sWaitMsg = "月次更新 実行中..." & vbCrLf & vbCrLf & "しばらくお待ちください"
Call gWaitMsg(True, sWaitMsg)

'--- 時間のかかる処理 ---
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("q_nageee")
qdf.Execute

'--- 月次更新 終了 ---
Call gWaitMsg(False)

MsgBox "正常終了しました!"

フォームを開くのも閉じるのも、メッセージを設定するのもすべてグローバルプロシージャ「gWaitMsg」を使います。
下図のように、Accessのマクロからも呼び出すことができます。

Accessマクロからも呼び出しOK

注意したいのは、クエリの実行を「DoCmd.OpenQuery」で記述しちゃうと、たしか非同期(だったと思う...)のため、クエリがまだ終わっていなくても終了メッセージまでいっきに進んでしまうかもしれないので気を付けて。

...とまあこんな感じで、お役に立てれば嬉しいです。