|
|
|
（ 2016/11/25 : 初版 , 2019/10/18 : MsgBeep2 関数に機能追加 )
１． MsgBox の Beep 音
２． MsgBox に Unicode 文字 を表示する
[ この場所への リンク ]
１． 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音はＯＳによって異なります（ファイル名も）ので、サウンドファイル名を
固定すると、実行環境によっては「鳴らない（指定のサウンドファイルが無い）」という事になります。
実は、こんな面倒なことをしなくても、Beep音の種別（警告/情報・・・）を指定するだけでシステムに登録
されているサウンドを鳴らすＡＰＩ (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
PlaySound に指定できるイベント名は他に下記の３つがあります。
2019/10/18 : MsgBeep2 関数に機能追加 ( １回/連続再生 指定の引数を追加 , メール着信音 の指定を追加 )
#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
Public Const cstMailBeep As Long = 80 ' [101 0000] Binary
Public Sub MsgBeep2(ByVal BeepType As VbMsgBoxStyle , Optional ByVal SoundLoop As Integer = 0)
' SoundLoop ⇒ 0: １回再生(既定値) , 1: ループ再生 , 他: ループ再生を停止
Const SND_ASYNC = &H1& '非同期で再生
Const SND_LOOP = &H8& 'ループ再生
Const SND_PURGE = &H40& 'ループ再生を中止する
Const SND_ALIAS = &H10000 'lpszNameはシステムイベント名
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 cstMailBeep
strEventName = "MailBeep" 'メール着信音
Case Else
strEventName = "SystemDefault"
End Select
Select Case SoundLoop
Case 0 ' １回だけ再生
Call PlaySound(strEventName, 0&, SND_ASYNC Or SND_ALIAS)
Case 1 ' ループ再生
Call PlaySound(strEventName, 0&, SND_ASYNC Or SND_LOOP Or SND_ALIAS)
Case Else ' 再生停止
Call PlaySound(vbNullString, 0&, SND_PURGE)
End Select
End Sub
'(補) vbCritical = 16 = [001 0000] Binary
' vbQuestion = 32 = [010 0000]
' vbExclamation = 48 = [011 0000]
' vbInformation = 64 = [100 0000]
' cstMailBeep = 80 = [101 0000]
' cstIconMask = 112 = [111 0000]
Call MsgBeep2(vbCritical)
Call MsgBeep2(vbQuestion)
Call MsgBeep2(vbExclamation)
Call MsgBeep2(vbInformation)
Call MsgBeep2(vbOKOnly) 'アイコン無しのBeep音
Call MsgBeep2(cstMailBeep , 1) 'メール着信音を連続再生
Call MsgBeep2(0 , 9) '連続再生を停止
"SystemStart" ⇒ Windowsの起動
"SystemExit" ⇒ Windowsの終了
"SystemWelcome" ⇒ 対象となる音源は判りませんでした。
VBAの Beep だけでは物足りない、もう少し変化が欲しいという方は、一度試してみては・・・ ？
[ この場所への リンク ]
２． MsgBoxにUnicode文字を表示する
2016/11/20 に 海外から 『VBA の MsgBox で、 Unicode にある ハートマーク を表示する方法はないか？』
という質問を受けて、それに回答するために調べた内容を整理したものです。前述の MessageBeep は、その
過程で見つけました。
-- VBAにおける Unicode のサポート状況 --
(1) VBAにおける文字列は、内部的にUnicodeで管理(保存)されています。
(2) VBAのUserFormではUnicodeをサポートしています。
(3) 開発環境のVBEはUnicodeをサポートしていません（日本ではShift-JISベースです）。
その為、
(a) マクロで
とすれば、問題なくハートマークが表示されますが、プロパティウィンドウの Caption に直接ハート
Label1.Caption = ChrW(&H2661) 'x2661:ハートマーク
マーク等を指定することはできません。
(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 )
の２種類があります。
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 以前 ( ＡＰＩ が必要 )
#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 定義は前記と同じ
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()
 |
 |
|
|
|
||
| 角田 桂一 Mail:addinbox@h4.dion.ne.jp CopyRight(C) 2016 Allrights Reserved. | ||
