ロゴ(青) Excel/VBA Tips ロゴ(緑)

Tips26: MsgBox / Beep音 と Unicode文字列

        ( 2016/11/25 : 初版 )

1.  MsgBox の Beep 音
2.  MsgBox に Unicode 文字 を表示する


[ この場所への リンク ]

1. MsgBoxのBeep音

VBAで用意されているBeep音は [ Beep ステートメント ] だけですが、MsgBoxのBeep音はButton
引数(アイコン種類)に応じて変化します。 
      vbCritical (16) , vbQuestion (32)
      vbExclamation (48) , vbInformation (64)
各々は [ コントロールパネル > サウンド ] で指定されている下記の音源が鳴ります。
      vbCritical    ⇒    システムエラー
      vbQuestion    ⇒    メッセージ(問い合わせ)
      vbExclamation    ⇒    メッセージ(警告)
      vbInformation    ⇒    メッセージ(情報)
      アイコン無し    ⇒    一般の警告音

音源のファイル名が判っている(固定)場合には、システムフォルダのMediaフォルダから
該当ファイルを直接指定する下記マクロで鳴らすことができます。
 
  #If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetWindowsDirectory _
              Lib "kernel32" Alias "GetWindowsDirectoryA" _
              (ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function PlaySound _
              Lib "winmm.dll" Alias "PlaySoundA" _
              (ByVal lpszName As String, ByVal hModule As LongPtr, _
               ByVal dwFlags As Long) As Long
  #Else
    Private Declare Function GetWindowsDirectory _
              Lib "kernel32" Alias "GetWindowsDirectoryA" _
              (ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function PlaySound _
              Lib "winmm.dll" Alias "PlaySoundA" _
              (ByVal lpszName As String, ByVal hModule As Long, _
               ByVal dwFlags As Long) As Long
  #End If

  Private Const SND_ASYNC = &H1&          '非同期で再生
  Private Const SND_FILENAME = &H20000    'lpszNameはファイル名



  Sub Beep_Ding()  'Ding.wav の例
    Dim strBuffer As String * 260
    Dim strPath As String
    Dim rc As Long

    'Windowsディレクトリのパス名を取得
    rc = GetWindowsDirectory(strBuffer, Len(strBuffer))
    strPath = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)

    'Wave音を鳴らす
    rc = PlaySound(strPath & "\Media\" & "Ding.wav", 0&, SND_ASYNC Or SND_FILENAME)
  End Sub


ただし、メッセージの既定のBeep音はOSによって異なります(ファイル名も)ので、サウンドファイル名を
固定すると、実行環境によっては「鳴らない(指定のサウンドファイルが無い)」という事になります。



実は、こんな面倒なことをしなくても、Beep音の種別(警告/情報・・・)を指定するだけでシステムに登録
されているサウンドを鳴らすAPI (MessageBeep) が用意されています。
    [ MSDN / MessageBeep ]
    https://msdn.microsoft.com/ja-jp/library/cc429002.aspx

MessageBeepを直接呼び出しても良いのですが、コーディングの際にBeep音の種別がインテリセンスで
指定できれば楽ですので、以下のように MsgBeep サブルーチンを作成しました。
 
  #If VBA7 And Win64 Then
    Private Declare PtrSafe Function MessageBeep Lib "user32" Alias "MessageBeep" _
              (ByVal wType As Long) As Long
  #Else
    Private Declare Function MessageBeep Lib "user32" Alias "MessageBeep" _
              (ByVal wType As Long) As Long
  #End If

  Public Sub MsgBeep(ByVal BeepType As VbMsgBoxStyle)
  Const cstIconMask As Long = 112
      Call MessageBeep(CLng(BeepType And cstIconMask))
  End Sub

  '(補) vbCritical    =  16 = [001 0000] Binary
  '     vbQuestion    =  32 = [010 0000]
  '     vbExclamation =  48 = [011 0000]
  '     vbInformation =  64 = [100 0000]
  '     cstIconMask   = 112 = [111 0000]



  Call MsgBeep(vbCritical)
  Call MsgBeep(vbQuestion)
  Call MsgBeep(vbExclamation)
  Call MsgBeep(vbInformation)
  Call MsgBeep(vbOKOnly)      'アイコン無しのBeep音



(補) PlaySound でも、「イベント名」の指定でBeep音(警告/情報・・・)を簡単に行える事が判りました。
      [ MSDN / PlaySound ]
      https://msdn.microsoft.com/ja-jp/library/windows/desktop/dd743680(v=vs.85).aspx
 
  #If VBA7 And Win64 Then
    Private Declare PtrSafe Function PlaySound _
              Lib "winmm.dll" Alias "PlaySoundA" _
              (ByVal lpszName As String, ByVal hModule As LongPtr, _
               ByVal dwFlags As Long) As Long
  #Else
    Private Declare Function PlaySound _
              Lib "winmm.dll" Alias "PlaySoundA" _
              (ByVal lpszName As String, ByVal hModule As Long, _
               ByVal dwFlags As Long) As Long
  #End If

  Private Const SND_ASYNC = &H1&       '非同期で再生
  Private Const SND_ALIAS = &H10000    'lpszNameはシステムイベント名

  Public Sub MsgBeep2(ByVal BeepType As VbMsgBoxStyle)
  Dim strEventName As String
  Const cstIconMask As Long = 112

      Select Case CLng(BeepType And cstIconMask)
        Case vbCritical
          strEventName = "SystemHand"
        Case vbQuestion
          strEventName = "SystemQuestion"
        Case vbExclamation
          strEventName = "SystemExclamation"
        Case vbInformation
          strEventName = "SystemAsterisk"
        Case Else
          strEventName = "SystemDefault"
      End Select

      Call PlaySound(strEventName, 0&, SND_ASYNC Or SND_ALIAS)
  End Sub

  '(補) vbCritical    =  16 = [001 0000] Binary
  '     vbQuestion    =  32 = [010 0000]
  '     vbExclamation =  48 = [011 0000]
  '     vbInformation =  64 = [100 0000]
  '     cstIconMask   = 112 = [111 0000]


  Call MsgBeep2(vbCritical)
  Call MsgBeep2(vbQuestion)
  Call MsgBeep2(vbExclamation)
  Call MsgBeep2(vbInformation)
  Call MsgBeep2(vbOKOnly)      'アイコン無しのBeep音

PlaySound に指定できるイベント名は他に下記の3つがあります。
    "SystemStart"  ⇒  Windowsの起動
    "SystemExit"  ⇒  Windowsの終了
    "SystemWelcome"  ⇒  対象となる音源は判りませんでした。

VBAの Beep だけでは物足りない、もう少し変化が欲しいという方は、一度試してみては・・・ ?




[ この場所への リンク ]

2. MsgBoxにUnicode文字を表示する
      2016/11/20 に 海外から 『VBA の MsgBox で、 Unicode にある ハートマーク を表示する方法はないか?』
      という質問を受けて、それに回答するために調べた内容を整理したものです。前述の MessageBeep は、その
      過程で見つけました。

-- VBAにおける Unicode のサポート状況 --
(1) VBAにおける文字列は、内部的にUnicodeで管理(保存)されています。
(2) VBAのUserFormではUnicodeをサポートしています。
(3) 開発環境のVBEはUnicodeをサポートしていません(日本ではShift-JISベースです)。

その為、
(a) マクロで
   Label1.Caption = ChrW(&H2661)    'x2661:ハートマーク
    とすれば、問題なくハートマークが表示されますが、プロパティウィンドウの Caption に直接ハート
    マーク等を指定することはできません。
(b) イミディエイトウィンドウに [ ?ChrW(&H2661) ] と打ち込んでも、結果は [ ? ] と表示されます。
(c) Shift-JISに定義されていない文字を含む文字列データ(Unicode)をクリップボード経由でVBEの
    モジュールウィンドウに貼り付けてると [ ? or 文字化け ] で表示されます。
(d) MsgBox関数の引数( Prompt , Title )にUnicode 文字列を指定すると、Shift-JISに無い文字は
    [ ? ] で表示されます。

 
  Sub Test1()
  Dim MsgText As String
  Dim Unicode As Long
  Dim rc As Long

    '[x3020:郵便顔マーク] [x2668:温泉マーク] [ x265E:チェス(ナイト)]
    MsgText = ChrW(&H3020) & Space(2) & ChrW(&H2668) & Space(2) & ChrW(&H265E)
    MsgText = MsgText & " ABCDE" & vbCrLf & vbCrLf

    For Unicode = &H2660 To &H2667    'トランプマーク
        MsgText = MsgText & ChrW(Unicode) & Space(1)
    Next
    MsgText = MsgText & " 12345" & vbCrLf & vbCrLf

    For Unicode = &H2600 To &H2603    '天気マーク
        MsgText = MsgText & ChrW(Unicode) & Space(1)
    Next
    MsgText = MsgText & " あいうえお" & vbCrLf & vbCrLf

    rc = MsgBox(MsgText, vbYesNoCancel + vbInformation, _
                ChrW(&H2661) & " Unicode MsgBox " & ChrW(&H2661))    'x2661:ハートマーク
  End Sub

  '(補) ChrW 関数に指定しているのは Unicode による文字コードです。


上記マクロ (VBA標準のMsgBox) を実行すると下図の右側の結果になります。



VBAのMsgBox 関数は内部的には Windows-API ( MessageBox ) によって処理されていますが、
このMessageBoxには
    ・ MessageBoxA ( ANSI )
    ・ MessageBoxW ( Unicode )
の2種類があります。

 
  Declare Function MessageBox Lib "user32" Alias "MessageBoxA" _
                    (ByVal hwnd As Long, ByVal lpText As Long, _
                     ByVal lpCaption As Long, ByVal wType As Long) As Long

  Declare Function MessageBox Lib "user32" Alias "MessageBoxW" _
                    (ByVal hwnd As Long, ByVal lpText As Long, _
                     ByVal lpCaption As Long, ByVal wType As Long) As Long


VBAのMsgBox関数は MessageBoxA で実行されている為、引数 ( Prompt , Title ) に、
      Shift-JISに定義されていない文字を含む文字列データ(Unicode)
を指定すると、定義されていない文字は [ ? ] になります(String型引数の引き渡しの際にShift-JIS
への文字コード変換が介入します)。

ということは、逆に Unicodeに対応している API:MessageBoxW を直接使えば、Unicode文字をメッ
セージボックスに表示できるということです(下記マクロの結果は上図の左側)。

 
  #If VBA7 And Win64 Then
    Private Declare PtrSafe Function MessageBoxW Lib "user32" Alias "MessageBoxW" _
              (ByVal hwnd As LongPtr, ByVal lpText As LongPtr, _
               ByVal lpCaption As LongPtr, ByVal wType As Long) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" Alias "GetFocus" () As LongPtr
  #Else
    Private Declare Function MessageBoxW Lib "user32" Alias "MessageBoxW" _
              (ByVal hwnd As Long, ByVal lpText As Long, _
               ByVal lpCaption As Long, ByVal wType As Long) As Long
    Private Declare Function GetFocus Lib "user32" Alias "GetFocus" () As Long
  #End If



  Public Function MsgBoxUnicode(ByVal Prompt As String, _
                                  Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
                                  Optional ByVal Title As String = "Microsoft Excel") As Long

    MsgBoxUnicode = MessageBoxW(GetFocus(), StrPtr(Prompt), StrPtr(Title), Buttons)
    ' MsgBoxUnicode = MessageBoxW(0, StrPtr(Prompt), StrPtr(Title), Buttons)
  End Function



  Sub Test2()
  Dim MsgText As String
  Dim Unicode As Long
  Dim rc As Long

    '[x3020:郵便顔マーク] [x2668:温泉マーク] [ x265E:チェス(ナイト)]
    MsgText = ChrW(&H3020) & Space(2) & ChrW(&H2668) & Space(2) & ChrW(&H265E)
    MsgText = MsgText & " ABCDE" & vbCrLf & vbCrLf

    For Unicode = &H2660 To &H2667      'トランプマーク
        MsgText = MsgText & ChrW(Unicode) & Space(1)
    Next
    MsgText = MsgText & " 12345" & vbCrLf & vbCrLf

    For Unicode = &H2600 To &H2603      '天気マーク
        MsgText = MsgText & ChrW(Unicode) & Space(1)
    Next
    MsgText = MsgText & " あいうえお" & vbCrLf & vbCrLf

    rc = MsgBoxUnicode(MsgText, vbYesNoCancel + vbInformation, _
                       ChrW(&H2661) & " Unicode MsgBox " & ChrW(&H2661))    'x2661:ハートマーク
  End Sub

  '(補) ChrW 関数に指定しているのは Unicode による文字コードです。
        親ウィンドウハンドルは後述の「キーボードフォーカスを持つウィンドウのハンドル」
        で対処しています。

 

[ MSDNライブラリ / MessageBox ]
https://msdn.microsoft.com/ja-jp/library/cc410914.aspx



API:MessageBox の第一引数には、親ウィンドウの「ウィンドウハンドル(hWnd)」を指定します。
(ゼロを指定すると独立ウィンドウになります)
      ・ ワークシート画面    ⇒    Excel ウィンドウのウィンドウハンドル
      ・ UserForm から表示    ⇒    そのUserForm ウィンドウのウィンドウハンドル
このウィンドウハンドルは以下の方法で取得できます。

-- Excel ウィンドウ --
・ Excel2000 以前 ( API が必要 )
   
  #If VBA7 And Win64 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
            (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
  #Else
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
            (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  #End If

  hWnd = FindWindow("XLMAIN", Application.Caption)
 

・ Excel2002 以降 ( プロパティで取得可 )
   
  hWnd = Application.HWnd
 

-- UserForm --
( API が必要 )
   
  'API 定義は前記と同じ

  hWnd = FindWindow("ThunderDFrame", Me.Caption) 'Excel97以前は"ThunderXFrame"


  尚、Frame と MultiPage では 隠しプロパティの _GethWnd で取得可
      hWnd = Frame1.[_GethWnd]
      hWnd = MultiPage1.[_GethWnd]


-- キーボードフォーカスを持つウィンドウのハンドル --
[ MSDNライブラリ / GetFocus ]
https://msdn.microsoft.com/ja-jp/library/cc364641.aspx

   
  #If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetFocus Lib "user32" Alias "GetFocus" () As LongPtr
  #Else
    Private Declare Function GetFocus Lib "user32" Alias "GetFocus" () As Long
  #End If

  hWnd = GetFocus()





Home   Back Page   Next Page

ロゴ(ゴールド)   ロゴ(ピンク)

角田 桂一 Mail:addinbox@h4.dion.ne.jp CopyRight(C) 2016 Allrights Reserved.