HOME > エクセルVBA > サンプル > MessageBox

MessageBox


【ファイル名】MessageBox.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2021年04月22日
【更新日】2021年04月23日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】MessageBox.zip
【説明】Windows APIのMessageBoxW関数でメッセージ ダイアログを表示します。

Windows APIのMessageBoxA関数やVBAのMsgBoxは、Shift-JISにないユニコードは文字化けします。例えば「森鷗外」が「森?外」に、「麴町」が「?町」になります。「鴎」、「麹」は表示できます。
画面

Windows APIのMessageBoxW関数で文字化けしないように表示します。
画面

このサンプルでは下記のShow関数でメッセージのダイアログを表示します。
Show(メッセージ、タイトル、ボタンとアイコン)

ボタンとアイコンは、MsgBoxのVbMsgBoxStyleと同じだと思います。
戻り値は、MsgBoxのVbMsgBoxResultと同じだと思います。

Show "ファイルを上書き保存しますか?", "確認", vbQuestion + vbYesNo
画面

【外部リンク】Windows > Apps > Win32 > API > Dialog Boxes > Winuser.h > MessageBoxW function
【外部リンク】Windows > Apps > Win32 > API > Dialog Boxes > Winuser.h > MessageBoxA function
【外部リンク】Windows > Apps > Win32 > API > Keyboard and Mouse Input > Winuser.h > GetFocus function

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="メッセージの表示">
          <box id="Box1" boxStyle="vertical">
            <editBox id="MessageEditBox" label="メッセージ:" keytip="M" screentip="メッセージ"
                     supertip="メッセージを入力してください。" sizeString="WWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
            <editBox id="TitleEditBox"   label="タイトル:"   keytip="T" screentip="タイトル"
                     supertip="タイトルを入力してください。"   sizeString="WWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
          </box>

            <separator id="separator1" />

          <button id="MessageBoxWButton" label="MessageBoxW" keytip="W" imageMso="HappyFace" size="large"
                  screentip="Windows APIのMessageBoxW" supertip="Windows APIのMessageBoxWでメッセージを表示します。" onAction="onAction" />
          <button id="MessageBoxAButton" label="MessageBoxA" keytip="W" imageMso="SadFace" size="large"
                  screentip="Windows APIのMessageBoxA" supertip="Windows APIのMessageBoxAでメッセージを表示します。
Shift-JISにないユニコードは文字化けします。" onAction="onAction" />
          <button id="MsgBoxButton"     label="MsgBox"      keytip="V" imageMso="SadFace" size="large"
                  screentip="VBAのMsgBox" supertip="VBAのMsgBoxでメッセージを表示します。
Shift-JISにないユニコードは文字化けします。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

MessageBoxModule
Option Explicit

#If Win64 Then
' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-messageboxw
  Private Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxW" (ByVal hwnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal wType As Long) As Long

' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-messageboxa
  Private Declare PtrSafe Function MessageBoxA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getfocus
  Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
#Else
  Private 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
  Private Declare Function MessageBoxA Lib "user32" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
  Private Declare Function GetFocus Lib "user32" () As Long
#End If

' MessageBoxWでメッセージ ダイアログを表示します。
Public Function Show(ByVal Prompt As String, Optional ByVal Title As String = "", Optional ByVal wType As VbMsgBoxStyle = 0) As VbMsgBoxResult ' メッセージ ダイアログを表示する
  If Prompt = "" Then
    Show = MessageBox(GetFocus(), StrPtr(vbNullString), StrPtr(Title), wType)
  Else
    Show = MessageBox(GetFocus(), StrPtr(Prompt), StrPtr(Title), wType)
  End If
End Function

' MessageBoxAでメッセージ ダイアログを表示します。Shift-JISにないユニコードは文字化けします。
Public Function Show_MessageBoxA(ByVal Prompt As String, Optional ByVal Title As String = "", Optional ByVal wType As VbMsgBoxStyle = 0) As VbMsgBoxResult ' メッセージ ダイアログを表示する
  If Prompt = "" Then
    Show_MessageBoxA = MessageBoxA(GetFocus(), vbNullString, Title, wType)
  Else
    Show_MessageBoxA = MessageBoxA(GetFocus(), Prompt, Title, wType)
  End If
End Function
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI ' リボン
Private rbMessageText As String ' メッセージのeditBoxの文字列
Private rbTitleEText As String  ' タイトルのeditBoxの文字列

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbMessageText = "森" & ChrW(-25129) & "外"
  rbTitleEText = "情報"
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "MessageBoxWButton" ' MessageBoxW
      If rbMessageText = "" Then
        MsgBox Prompt:="メッセージを入力してください!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Else
        MessageBoxModule.Show rbMessageText, rbTitleEText, vbInformation
      End If
    Case "MessageBoxAButton" ' MessageBoxA
      If rbMessageText = "" Then
        MsgBox Prompt:="メッセージを入力してください!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Else
        MessageBoxModule.Show_MessageBoxA rbMessageText, rbTitleEText, vbInformation
      End If
    Case "MsgBoxButton" ' MsgBox
      MsgBox Prompt:=rbMessageText, Buttons:=vbInformation, Title:=rbTitleEText
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'-------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  Select Case control.ID
    Case "MessageEditBox"
      returnedVal = rbMessageText
    Case "TitleEditBox"
      returnedVal = rbTitleEText
  End Select
End Sub

Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  Select Case control.ID
    Case "MessageEditBox"
      rbMessageText = text
    Case "TitleEditBox"
      rbTitleEText = text
  End Select
End Sub
このページの上