直接從系統得到錯誤描述 (轉)

直接從系統得到錯誤描述 (轉)[@more@]

'作者: Thierry Waty
'作者主頁:
'這是一個根據錯誤程式碼直接從中得到錯誤描述的，你可以不要用硬編碼了

'使用舉例:

'  Call Error

  ' *** Or
 '  De.Print ReturnAPIError(53)
  ' *** Return : 介面卡出錯。

' #VBUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Site  :
' * E-  : ">waty.thierry@usa.net
' * Date  : 12/10/1998
' * Time  : 20:20
' * Module Name  : APIError_Module
' * Module Filename  : APIError.bas
' **********************************************************************
' * Comments  :
' * 這是一個根據錯誤程式碼直接從系統中得到錯誤描述的程式，你可以不要用硬編碼
' *
' *
' **********************************************************************

Option Explicit

Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
  (ByVal dwFlags As Long, lp As Any, ByVal dwMessageId As Long, _
  ByVal dguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _
  Arguments As Long) As Long

' *** Status Codes
Private Const INVALID_HANDLE_VALUE = -1&
Private Const ERROR_SUCCESS = 0&

Public Function ReturnAPIError(ErrorCode As Long) As String
  ' #VBIDEUtils#************************************************************
  ' * Programmer Name  : Waty Thierry
  ' * Web Site  :
  ' *   :
  ' * Date  : 12/10/1998
  ' * Time  : 20:21
  ' * Module Name  : APIError_Module
  ' * Module Filename  : APIError.bas
  ' * Procedure Name  : ReturnAPIError
  ' * Parameters  :
  ' *  ErrorCode As Long
  ' **********************************************************************
  ' * Comments  :
  ' * Takes an API error number, and returns
  ' * a descriptive text string of the error
  ' *
  ' **********************************************************************

  Dim sBuffer  As String

  ' *** Allocate the string, then get the system to
  ' *** tell us the error message associated with
  ' *** this error number
 
  sBuffer = String(256, 0)
  FormatMessage FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0&, ErrorCode, 0&, sBuffer, Len(sBuffer), 0&

  ' *** Strthe last null, then the last CrLf pair if it exists
 
  sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  If Right$(sBuffer, 2) = Chr$(13) & Chr$(10) Then
  sBuffer = Mid$(sBuffer, 1, Len(sBuffer) - 2)
  End If

  ReturnAPIError = sBuffer

End Function

Public Sub ApiError()
  ' #VBIDEUtils#************************************************************
  ' * Programmer Name  : Waty Thierry
  ' * Web Site  :
  ' * E-Mail  :
  ' * Date  : 12/10/1998
  ' * Time  : 20:35
  ' * Module Name  : APIError_Module
  ' * Module Filename  : APIError.bas
  ' * Procedure Name  : APIError
  ' * Parameters  :
  ' **********************************************************************
  ' * Comments  :
  ' * Takes an API error number, and returns
  ' * a descriptive text string of the error
  ' *
  ' **********************************************************************

  Dim sError  As String
 
  On Error GoTo ERROR_APIError
 
  sError = InputBox("Enter the error number", "Returns API error")
 
  If IsNumeric(sError) = False Then Exit Sub
 
  MsgBox ReturnAPIError(CLng(sError)), vbInformation + vbOKOnly, "Error n " & sError
 
  Exit Sub
 
ERROR_APIError:
  MsgBox "Error n " & sError & vbCrLf & " Invalid error number" & vbCrLf & "You have to give another one", vbCritical + vbOKOnly, "Error n " & sError
 
End Sub