Where are the COM error numbers for Err.Raise registered?

user_6609896 0
Viewed 99

Err.Raise supports a load of errors clearly nothing to do with VBA:

enter image description here

Where are these error numbers defined? How can I register an error so that running Err.Raise my_number will have a description I specify globally.

I'd like to dump all error codes and descriptions into a file as well - I've tried looping through them:

Sub GenerateErrorCodes()
    Application.ScreenUpdating = False
    OutputSheet.UsedRange.Clear
    Dim rng As Range
    Set rng = OutputSheet.Range("A1", "B1")
    Dim i As Long
    For i = -2147483647# To 2147483647
        If Abs(i) Mod 100000 = 1 Then Debug.Print (CDbl(i) + 2147483647#) / (2147483647# * 2) * 100; "%": DoEvents
        On Error Resume Next
        Err.Raise i
        msg = Err.Description
        On Error GoTo 0
        Select Case msg
        Case "Application-defined or object-defined error"
        Case "Automation error"
        Case "Invalid procedure call or argument"
        Case Else
            rng = Array(i, msg)
            Set rng = rng.Offset(1)
        End Select
    Next i

    Application.ScreenUpdating = True
    Debug.Print "Done"

End Sub

But that's pretty slow!

runtime-error vb6 ole vba com
1 Answers

In addition to my comments, this is a different way. By asking Windows for the error message, and translate NTStatus to Win32 and COM Win32 to Win32.

Public Declare Function RtlNtStatusToDosError Lib "ntdll.dll" (ByVal status As Long) As Long
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Public Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Sub Main()
    Dim x  As Long
    Dim hNtdll As Long
    Dim WinError As Long
    Dim NTSTatus As Long
    Dim Ret As Long
    Dim RetStr As String
    RetStr = Space(1020)
    Dim RetStr1 As String
    RetStr1 = Space(1020)
    InpStr = InputBox("Enter NTStatus code", "", "&hc0000005")
    
    If InpStr <> "" Then
        InpStr = Replace(InpStr, "0x", "&h")
        InpStr = Replace(InpStr, "0X", "&h")
        errnum = CLng(InpStr)
        If errnum = 0 Then InpStr = "&h" & InpStr
        errnum = CLng(InpStr)
        If errnum <> 0 Then NTSTatus = errnum
        If NTSTatus > &HC0000000 And NTSTatus < &HD0000000 Then
                WinError = RtlNtStatusToDosError(NTSTatus)
                Ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_IGNORE_INSERTS, 0, WinError, 0, RetStr, 1020, 0)
                RetStr = Left(RetStr, Ret)
                hNtdll = LoadLibrary("C:\Windows\System32\en-US\ntdll.dll.mui")
                Ret = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS + FORMAT_MESSAGE_FROM_HMODULE, hNtdll, NTSTatus, 0, RetStr1, 1020, 0)
                RetStr = "NT Status Message:" & vbCrLf & Left(RetStr1, Ret) & vbCrLf & vbCrLf & "Windows Error Message:" & vbCrLf & RetStr
                MsgBox "NT Status 0x" & Hex(NTSTatus) & " (" & NTSTatus & ")" & vbCrLf & "Windows Error 0x" & Hex(WinError) & " (" & WinError & ")" & vbCrLf & vbCrLf & RetStr
        ElseIf NTSTatus > &H80070000 And NTSTatus < &H80080000 Then
                WinError = NTSTatus - &H80070000
                Ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_IGNORE_INSERTS, 0, WinError, 0, RetStr, 1020, 0)
                RetStr = Left(RetStr, Ret)
                MsgBox "Windows Error 0x" & Hex(WinError) & " (" & WinError & ")" & vbCrLf & vbCrLf & RetStr
        ElseIf NTSTatus And &HFFFF Then
                WinError = NTSTatus
                Ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_IGNORE_INSERTS, 0, WinError, 0, RetStr, 1020, 0)
                RetStr = Left(RetStr, Ret)
                MsgBox "Windows Error 0x" & Hex(WinError) & " (" & WinError & ")" & vbCrLf & vbCrLf & RetStr
        End If
    End If
End Sub

Edit

PS: Those error numbers date from the first MS Basic and were developed by Bill Gates and Paul Allen.

user_185219180
Related