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

FormatMessage


【ファイル名】FormatMessage.xlsm
【バージョン】Ver 1.0.0.1
【作成日】2019年06月10日
【更新日】2021年04月20日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】FormatMessage.zip
【説明】Windows APIのFormatMessage関数で、エラーの番号からメッセージを表示します。
    Windows APIの最後のエラーの番号は、ErrオブジェクトのLastDllErrorプロパティで取得してください。(Windows APIのGetLastErrorはVBAではエラーを取得できない場合があります)
メニュー

【参照】Windows APIのエラーメッセージの一覧

下記のマイクロソフトのサイトを参考にしました。
【外部リンク】Windows > Apps > Win32 > API > winbase.h > FormatMessageW 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="FormatMessage">
          <box id="Box1" boxStyle="horizontal">
            <editBox id="editBox1" label="エラーの番号:" keytip="E" screentip="エラーの番号" supertip="Windows APIのエラーの番号を入力してください。"
                     maxLength="11" sizeString="-1234567890" getText="getText" onChange="onChange" />
            <button id="button1" label="エラーメッセージ" keytip="M" size="large" imageMso="Info" supertip="入力した番号のエラー メッセージを表示します。" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

ErrorMessageModule
Option Explicit

#If Win64 Then
  ' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-formatmessagew
  Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageW" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As LongPtr, ByVal nSize As Long, Arguments As LongPtr) As Long
#Else
  Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageW" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Long, ByVal nSize As Long, Arguments As Long) As Long
#End If

Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200& ' 引数のArgumentsを使わない
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
Public Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF& ' 改行コードを削除する

' Windows APIのエラーコードからエラーメッセージを取得します。
Public Function GetErrorMessage(ByVal ErrorCode As Long) As String
  Dim buf As String
  Dim ret As Long
  
  buf = String(1024, vbNullChar)
  ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0&, ErrorCode, 0&, StrPtr(buf), Len(buf), 0&)
  If ret <> 0 Then
    GetErrorMessage = StrVBA(buf)
  Else
    GetErrorMessage = vbNullString
  End If
End Function

' 指定したヌルで終わる文字列から、vbNullCharの左側の文字列を取得します。
Private Function StrVBA(ByVal EndNullString As String) As String
  Dim p As Long
  
  p = InStr(1, EndNullString, vbNullChar)
  If p > 0 Then
    StrVBA = Left(EndNullString, p - 1)
  Else
    StrVBA = EndNullString ' ■ vbNullCharがない場合は引数をそのまま返します。
'    StrVBA = vbNullString ' ■ 必要に応じて変更してください。
  End If
End Function

' 1〜10のエラー番号のメッセージをイミディエイト ウィンドウに出力します。
Private Sub Test_GetErrorMessage()
  Dim i As Long
  For i = 1 To 10
    Debug.Print Format(i, "00:") & GetErrorMessage(i)
  Next
End Sub

' 最後のエラーのメッセージをイミディエイト ウィンドウに出力します。
Private Sub Print_LastDllErrorMessage()
  Debug.Print Err.LastDllError & ":" & GetErrorMessage(Err.LastDllError)
End Sub

' エラーメッセージの一覧を作成します。時間がかかり過ぎるのであきらめました。
Private Sub CreateApiErrorMessage()
  Dim i As Long
  Dim c As Long
  Dim s As String
  Dim tmpCalculation As XlCalculation ' 計算方法のモード
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False ' イベントを無効にします。
  tmpCalculation = Application.Calculation ' 計算方法のモードを保存
  Application.Calculation = xlCalculationManual ' 計算方法のモードを手動にし、計算しない
  
  Worksheets.Add
  Cells(1, 1).Value = "10進数"
  Cells(1, 2).Value = "16進数"
  Cells(1, 3).Value = "エラーメッセージ"
  c = 2
'' ■■■ 本当はもっと多くのエラーメッセージがあります。
''  For i = 1 To 2147483647 ' Longの最大値は、2147483647
  For i = 1 To 15900 ' 15864
    s = GetErrorMessage(i)
    If Len(s) > 0 Then
      Cells(c, 1).Value = i
      Cells(c, 2).Value = "&H" & Right("00000000" & Hex(i), 8)
      Cells(c, 3).Value = Replace(s, vbNewLine, "")
      c = c + 1
    End If
  Next
'' ■■■ 本当はもっと多くのエラーメッセージがあります。
''  For i = -2147483648# To -1
'  For i = -2147483648# To -268500888
'    s = GetErrorMessage(i)
'    If Len(s) > 0 Then
'      Cells(c, 1).Value = i
'      Cells(c, 2).Value = "&H" & Right("00000000" & Hex(i), 8)
'      Cells(c, 3).Value = Replace(StrVBA(s), vbNewLine, "")
'      c = c + 1
'    End If
'  Next
  
  Columns("A:C").AutoFit
  Columns("B").HorizontalAlignment = xlRight
  
  ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "テーブル1"
  Range("テーブル1[#All]").Select
  ActiveSheet.ListObjects("テーブル1").TableStyle = "TableStyleMedium6"
  
  Application.ScreenUpdating = True
  Application.Goto Range("A1"), Scroll:=True
  Application.EnableEvents = True ' イベントを有効にします。
  Application.Calculation = tmpCalculation ' 計算方法のモードを元に戻します。
End Sub
このページの上

RibbonModule
Option Explicit

Private rbRibbon As IRibbonUI ' リボン
Private rbText As String ' editBoxの文字列

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbon = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbText = ""
  rbRibbon.Invalidate ' リボンの表示を更新する
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  returnedVal = rbText
End Sub

Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  rbText = text
End Sub

Sub onAction(control As IRibbonControl) ' ボタンの処理
  Dim code As Long
  
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  If Len(rbText) < 1 Then
    MsgBox Prompt:="エラーコードを入力してください。", Buttons:=vbCritical, Title:="エラー"
  ElseIf Not IsNumeric(rbText) Then
    MsgBox Prompt:="正しいエラーコード(整数)を入力してください。", Buttons:=vbCritical, Title:="エラー"
  Else
    code = CLng(Val(StrConv(rbText, vbNarrow)))
    MsgBox Prompt:=GetErrorMessage(code), Buttons:=vbInformation, Title:="情報"
  End If
  
  Exit Sub
'-------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub
このページの上