Excel VBA メッセージ表示用UserForm

　VBAではちょっとしたメッセージを表示するためにメッセージボックスMsgBoxが用意されています。その都度のメッセージならこれで十分なのですが、処理が中断しますし、追記もできません。
　また、ステータスバーに表示させれば処理は中断しませんが、表示量はとても短いです。メッセージボックスとステータスバーの表示は以下です。

'参考
Msgbox  "テストメッセージを表示しています"
Application.StatusBar = "テストメッセージを表示しています"

　そこで、メッセージ表示用のユーザーフォームとそれを利用するための簡単なコードを作りました。ユーザーフォーム自体は同時に何個でも表示できますのでメッセージの内容ごとに振り分けるなども可能です。

使い方
１．ユーザーフォームを新規に追加して、プロパティウィンドウでオブジェクト名を"ufMsg"に変更してください。サイズは適当で問題ありません。（名前に深い意味はありませんが、コード中でもこの名前を使っています。一致していれば何でも構いません。）
２．ユーザーフォームにテキストボックスとコマンドボタンを配置して、それぞれのオブジェクト名を"TextBoxMsg"、"CmdBtnClose"に変更してください。サイズや位置は適当で問題ありません。（これらも名前に深い意味はありませんが、コード中でこの名前を使っています。）

ユーザーフォーム

オブジェクト名の変更

３．ユーザーフォームのコードに以下を入力してください。

Option Explicit
Private Sub CmdBtnClose_Click()
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  CmdBtnClose.Caption = "Close"
End Sub

'フォームのサイズにあわせてテキストボックスの大きさと
'コマンドボタンの位置を変える
Private Sub UserForm_Resize()
  Dim wd As Double
  Dim ht As Double
  wd = Me.Width
  ht = Me.Height
  TextBoxMsg.Width = wd - 24
  TextBoxMsg.Height = ht - 40
  CmdBtnClose.Left = wd - 93.75
  CmdBtnClose.Top = ht - 57.75
End Sub

'表示フォームの操作

'新規にフォームを作る
Public Sub InitMsg(ttl As String,  _
  Optional wdth As Double = 250, Optional hght As Double = 340, _
  Optional lf As Double = -1, Optional tp As Double = -1)
  With Me
    .Caption = ttl
    .Width = wdth
    .Height = hght
    .TextBoxMsg.MultiLine = True
    .TextBoxMsg.WordWrap = False
    .TextBoxMsg.ScrollBars = fmScrollBarsBoth
    .Show vbModeless

    '指定の位置に移動
    If tp > 0 Then .Top = tp
    If lf > 0 Then .Left = lf
    .CmdBtnClose.Visible = False
  End With
End Sub

'表示されているフォームを取得する。なければ新規に作る。
Public Function GetUfMsg(ttl As String, _
  Optional wdth As Double = 250, Optional hght As Double = 340) _
  As UserForm
  Dim uf As Object
  For Each uf In UserForms
    If uf.Name = "ufMsg" Then
      If uf.Visible Then
          Set GetUfMsg = uf
       Exit For
      End If
    End If
  Next
  If uf Is Nothing Then
    Set uf = New ufMsg
    uf.InitMsg ttl, wdth, hght
    Set GetUfMsg = uf
  Else
    uf.CmdBtnClose.Visible = False
  End If
End Function

'テキストボックスに表示する
Public Sub DispMsg(msg As String, Optional flgClose As Boolean = False)
  TextBoxMsg.text = msg
  If flgClose Then
    CmdBtnClose.Visible = True
  End If
End Sub

'テキストボックスに追記表示する
Public Sub AppendMsg(msg As String, Optional flgClose As Boolean = False)
  Dim OrgMsg As String
  OrgMsg = TextBoxMsg.text
  TextBoxMsg.text = OrgMsg & msg
  If flgClose Then
    CmdBtnClose.Visible = True
  End If
End Sub

'表示されているフォームをすべて閉じる。最後に閉じたものの位置を返す。
Public Function CloseAllUfMsg() As Variant
  Dim uf As Object
  Dim lf As Double, tp As Double
  For Each uf In UserForms
    lf = uf.Left
    tp = uf.Top
    Unload uf
  Next
  Set uf = Nothing
  CloseAllUfMsg = Array(lf, tp)
End Function

４．準備は以上です。以下は使い方のテスト用のコードです。標準モジュールに入力してください。
主な命令は次の通りです。
・Dim uf As New ufMsg　でユーザーフォームのいインスタンスを作ります。
・uf.InitMsg ("test ufmsg uf1")　でユーザーフォームを表示しキャプション（タイトル）を"test ufmsg uf1"と設定します。
・uf.DispMsg "DispMsg uf1" & vbCrLf　でテキストを表示します。
・uf.AppendMsg "AppendMsg uf1 - 1" & vbCrLf　でテキストを追記します。
・Set uf2 = ufMsg.GetUfMsg("test GetUfMsg", 400, 100)　は既に開いているユーザーフォームがあれば、それを取得し、存在しなければ新たにインスタンスを作成します。
・uf3.CloseAllUfMsg　　は開いているフォームをすべて閉じます。

'使用例。標準モジュールに書く
Private Sub testufA()
Dim uf As New ufMsg 'userformを作る
uf.InitMsg ("test ufmsg uf1")
uf.DispMsg "DispMsg uf1" & vbCrLf
uf.AppendMsg "AppendMsg uf1 - 1" & vbCrLf
uf.AppendMsg "AppendMsg uf1 - 2" & vbCrLf, flgClose:=True
Set uf = Nothing

Dim uf2 As ufMsg '今開いているフォームを取得する
Set uf2 = ufMsg.GetUfMsg("test GetUfMsg", 400, 100)
uf2.DispMsg "Set uf2 = ufMsg.GetUfMsg(""test GetUfMsg"", 400, 100)" & vbCrLf
uf2.AppendMsg "AppendMsg uf2 - 1" & vbCrLf
uf2.AppendMsg "AppendMsg uf2 - 2" & vbCrLf
Set uf2 = Nothing

Dim uf3 As New ufMsg '別のuserformを作る
uf3.InitMsg "test ufmsg 3", 300, 100, 100, 400
uf3.DispMsg "Duf3.InitMsg ""test ufmsg 3"", 300, 100, 100, 400" & vbCrLf
uf3.AppendMsg "AppendMsg uf3 - 1" & vbCrLf
uf3.AppendMsg "AppendMsg uf3 - 2" & vbCrLf, flgClose:=True

Dim s As String
s = MsgBox("消去しますか", vbOKCancel)
If s = vbOK Then
    uf3.CloseAllUfMsg
End If
Set uf3 = Nothing

End Sub

テスト用コードの実行結果

以上です。

#Excel , #VBA , #ユーザーフォーム