直接从系统得到错误描述 (转)-优快云博客

直接从系统得到错误描述 (转)[@more@]

'作者: Thierry Waty
'作者主页: http://www.geocities.com/ResearchTriangle/6311/
'这是一个根据错误代码直接从系统中得到错误描述的程序，你可以不要用硬编码了

'使用举例:

' Call apiError

' *** Or
' Debug.Print ReturnAPIError(53)
' *** Return : 网络适配器硬件出错。

' #VBideUtils#************************************************************
' * Programmer Name : Waty Thierry
' * web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : .NET">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, lpsource As Any, ByVal dwMessageId As Long, _
ByVal dWlanguageId 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 : www.geocities.com/ResearchTriangle/6311/
' * E-mail : waty.thierry@usa.net
' * 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&

' *** Strip the 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 : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * 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

来自 “ ITPUB博客 ” ，链接：http://blog.itpub.net/10752043/viewspace-988483/，如需转载，请注明出处，否则将追究法律责任。

转载于:http://blog.itpub.net/10752043/viewspace-988483/