#298
オリジナルのポップアップメッセージ（というより実際は小さなフォーム）をちょっとの時間だけ表示させる例です。
ここではフォームをあらかじめ作成してデータベースに保存しておくのではなく、このプロシージャにおいて動的に生成、そして表示後に破棄するようにしています。Accessが自動表示してくれる「ヒントテキスト」プロパティの機能とは違い、メッセージ用のフォームを自分で生成するので、背景色やフォント色・フォントサイズ、ウィンドウサイズなど、さまざまなプロパティを自由に設定することができます。
標準モジュールに次のような「ShowPopupMsg」プロシージャを作って、利用例のように呼び出して使ってください。
Public Sub ShowPopupMsg(strMsg As String, Optional ByVal varTimer As Variant)
'概要 オリジナルのポップアップメッセージフォームを表示する
'引数 strMsg : メッセージ内容
' varTimer : 表示時間（Sec） 省略時は１Sec
'返値 なし
Dim frm As Form
Dim lblMsg As Label
Dim strFrmName As String
Dim sngStart As Single
On Error GoTo Err_Handler
'フォームデザインを表示させないようにします
Echo False
'空のフォームを生成（プロパティは任意に設定してください）
Set frm = CreateForm
With frm
strFrmName = .Name
.RecordSelectors = False
.NavigationButtons = False
.BorderStyle = 0
.AutoCenter = True
.AutoResize = True
.ScrollBars = 0
End With
'メッセージ用のラベルを生成（プロパティは任意に設定してください）
Set lblMsg = CreateControl(strFrmName, acLabel)
With lblMsg
.Caption = strMsg
.Left = 50
.Top = 50
.SizeToFit
frm.Width = .Width + 100
frm.Section(acDetail).Height = .Height + 100
frm.Section(acDetail).BackColor = 13697023
End With
'フォームを一時的に保存して再オープンします
DoCmd.Close acForm, strFrmName, acSaveYes
DoCmd.OpenForm strFrmName
DoCmd.RepaintObject acForm, strFrmName
Echo True
'指定時間待機します
If IsMissing(varTimer) Then varTimer = 1
sngStart = Timer
Do
Loop Until Timer >= sngStart + varTimer
Exit_Here:
On Error Resume Next
Echo True
'フォームを閉じてデータベースより削除します
DoCmd.Close acForm, strFrmName, acSaveNo
DoCmd.DeleteObject acForm, strFrmName
Exit Sub
Err_Handler:
Resume Exit_Here:
End Sub
'概要 オリジナルのポップアップメッセージフォームを表示する
'引数 strMsg : メッセージ内容
' varTimer : 表示時間（Sec） 省略時は１Sec
'返値 なし
Dim frm As Form
Dim lblMsg As Label
Dim strFrmName As String
Dim sngStart As Single
On Error GoTo Err_Handler
'フォームデザインを表示させないようにします
Echo False
'空のフォームを生成（プロパティは任意に設定してください）
Set frm = CreateForm
With frm
strFrmName = .Name
.RecordSelectors = False
.NavigationButtons = False
.BorderStyle = 0
.AutoCenter = True
.AutoResize = True
.ScrollBars = 0
End With
'メッセージ用のラベルを生成（プロパティは任意に設定してください）
Set lblMsg = CreateControl(strFrmName, acLabel)
With lblMsg
.Caption = strMsg
.Left = 50
.Top = 50
.SizeToFit
frm.Width = .Width + 100
frm.Section(acDetail).Height = .Height + 100
frm.Section(acDetail).BackColor = 13697023
End With
'フォームを一時的に保存して再オープンします
DoCmd.Close acForm, strFrmName, acSaveYes
DoCmd.OpenForm strFrmName
DoCmd.RepaintObject acForm, strFrmName
Echo True
'指定時間待機します
If IsMissing(varTimer) Then varTimer = 1
sngStart = Timer
Do
Loop Until Timer >= sngStart + varTimer
Exit_Here:
On Error Resume Next
Echo True
'フォームを閉じてデータベースより削除します
DoCmd.Close acForm, strFrmName, acSaveNo
DoCmd.DeleteObject acForm, strFrmName
Exit Sub
Err_Handler:
Resume Exit_Here:
End Sub
利用例：
ShowPopupMsg "短いメッセージを表示します！"
ShowPopupMsg "短いメッセージを３秒間表示します！", 3
ShowPopupMsg "短いメッセージを３秒間表示します！", 3
