Attribute VB_Name = "modErrorHandler" Option Explicit '============================================================================================================= ' ' modErrorHandler Module: ' ----------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Created On : July 19, 2002 ' Last Update : July 19, 2002 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : Microsoft XML, version 2.0 (or better) [MSXML.DLL] ' CDONTS.DLL (Collaboration Data Objects for Windows NT Server) version 1.2 or better ' ' Description : This class module makes it easy to trap, track, and log errors in a central location. ' ' See Also : http://msdn.microsoft.com/nhp/default.asp?contentid=28000438 ' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/xmlsdk30/htm/xmmscxmlreference.asp ' http://msdn.microsoft.com/library/en-us/cdo/html/_denali_cdo_for_nts_library.asp?frame=true ' http://msdn.microsoft.com/library/en-us/cdo/html/_denali_cdo_for_nts_object_model.asp?frame=true ' http://msdn.microsoft.com/library/en-us/cdo/html/_denali_installing_cdo_for_nts.asp?frame=true ' http://www.4guysfromrolla.com/webtech/faq/Email/faq1.shtml ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyrightİ by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' Constants - General Private Const MAX_PATH = 260 ' Constants - FormatMessage.dwFlags Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100 ' Specifies that the lpBuffer parameter is a pointer to a PVOID pointer, and that the nSize parameter specifies the minimum number of TCHARs to allocate for an output message buffer. The function allocates a buffer large enough to hold the formatted message, and places a pointer to the allocated buffer at the address specified by lpBuffer. The caller should use the LocalFree function to free the buffer when it is no longer needed. Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200 ' Specifies that insert sequences in the message definition are to be ignored and passed through to the output buffer unchanged. This flag is useful for fetching a message for later formatting. If this flag is set, the Arguments parameter is ignored. Private Const FORMAT_MESSAGE_FROM_STRING = &H400 ' Specifies that lpSource is a pointer to a null-terminated message definition. The message definition may contain insert sequences, just as the message text in a message table resource may. Cannot be used with FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM. Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800 ' Specifies that lpSource is a module handle containing the message-table resource(s) to search. If this lpSource handle is NULL, the current process's application image file will be searched. Cannot be used with FORMAT_MESSAGE_FROM_STRING. Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 ' Specifies that the function should search the system message-table resource(s) for the requested message. If this flag is specified with FORMAT_MESSAGE_FROM_HMODULE, the function searches the system message table if the message is not found in the module specified by lpSource. Cannot be used with FORMAT_MESSAGE_FROM_STRING. If this flag is specified, an application can pass the result of the GetLastError function to retrieve the message text for a system-defined error. Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000 ' Specifies that the Arguments parameter is not a va_list structure, but instead is just a pointer to an array of values that represent the arguments. ' Variable declarations Private mlngErrLine As Long ' Win32 API Function Declarations Private Declare Sub SetLastError Lib "KERNEL32" (ByVal dwErrCode As Long) Private Declare Function GetLastError Lib "KERNEL32" () As Long Private Declare Function FormatMessage Lib "KERNEL32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long Private Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long 'BOOL Private Declare Function OpenEventLog Lib "advapi32.dll" Alias "OpenEventLogA" (ByVal lpUNCServerName As String, ByVal lpSourceName As String) As Long 'HANDLE Private Declare Function CloseEventLog Lib "advapi32.dll" (ByVal hEventLog As Long) As Long 'BOOL Private Declare Function ReportEvent Lib "advapi32.dll" Alias "ReportEventA" (ByVal hEventLog As Long, ByVal EventType As Long, ByVal EventCategory As Long, ByVal EventID As Long, ByRef lpUserSid As Any, ByVal StringCount As Long, ByVal BinaryDataSize As Long, ByRef StringArray As String, ByRef BinaryData As Any) As Long 'BOOL 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX '============================================================================================================= ' CheckError ' ŻŻŻŻŻŻŻŻŻŻ ' This function makes it easy to check if an error occured in ASP with 1 function call. You pass it ' "Err.Number" and "Err.Description" and if this function returns TRUE, an error occured and the error information ' is returned. ' ' If you need a more robust function that logs the error automatically for you if detected, use the "ErrorHandler" ' function in the same way. See documentation for "ErrorHandler" for more information. ' ' Param Use ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' lngErrNumber You should pass "Err.Number" to this parameter. ' strErrSource Optional. You should pass "Err.Source" to this parameter. ' Return_ErrNum Optional. This parameter returns back the error number passed in via the ' "lngErrNumber" parameter. This allows you to easily and quickly return it. ' Return_ErrDesc Optional. This parameter returns back the error number passed in via the ' "lngErrNumber" parameter. This allows you to easily and quickly return it. ' ' Return ' ŻŻŻŻŻŻ ' Returns TRUE if an error occured ' Returns FALSE if no error occured ' ' Example Use ' ŻŻŻŻŻŻŻŻŻŻŻ ' Function MyAspFunction(MyParameter, Return_ErrNum, Return_ErrDesc) 'As Boolean ' On Error Resume Next ' MyAspFunction = False ' Call MyFunction ' If CheckError(Err.Number, Err.Description, Return_ErrNum, Return_ErrDesc) = True Then Exit Function ' MyAspFunction = True ' End Function ' '============================================================================================================= Public Function CheckError(ByVal lngErrNumber As Long, _ Optional ByVal strErrDescription As String, _ Optional ByRef Return_ErrNum As Variant, _ Optional ByRef Return_ErrDesc As Variant) As Boolean Return_ErrNum = lngErrNumber Return_ErrDesc = strErrDescription If Return_ErrNum <> 0 Then CheckError = True End If Err.Clear End Function '============================================================================================================= ' ErrorHandler ' ŻŻŻŻŻŻŻŻŻŻŻŻ ' This is the central error handling piece that is called by ALL routines of all interfaces. This makes it ' easy to manager how error handling is done because it's all consolidated into one place. ' ' NOTE: If this routine runs into an error sending an Email, logging to the Event Log, or logging to an XML file, ' it will set the "Return_ErrNum" and "Return_ErrDesc" properties and attempt to continue in spite of the error. ' ' Param Use ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' lngErrNumber The number of the error to log. Usually you should pass "Err.Number" to this parameter. ' strErrSource The source of the error to log. Usually you should pass "Err.Source" to this parameter. ' strErrDescription The description of the error to log. Usually you should pass "Err.Description" to this parameter. ' strMethodName Optional. The name of the Function, Sub, or Property that was being called when the error occured. ' strTo Optional. If the "blnSendEmail" parameter is set to true, specifies who the Email will be sent to. ' strFrom Optional. If the "blnSendEmail" parameter is set to true, specifies who the Email will be from. ' strSubject Optional. If the "blnSendEmail" parameter is set to true, specifies the subject line of the Email. ' blnSendEmail Optional. If TRUE, an Email with the error informaiton will be sent to the specified TO address. ' blnWriteToEventLog Optional. If TRUE, the error information will be logged to the "NT Event Log" of the computer ' running this DLL. If the computer running this DLL is Win95, Win98, or WinME, the error information ' will be written to the system's error log file instead. ' strFilePath Optional. If the "blnWriteToXmlFile" parameter is set to TRUE, the error information will ' be written to the file specified by this parameter. If the specified file does not exist, it will ' be created. If it is currently larger than the limit specified by the "lngFileSizeLimit" parameter, ' a new file with an incremental number at the end will be created and used. ' lngFileSizeLimit Optional. If the "blnWriteToXmlFile" parameter is set to TRUE, the error information will ' be written to the file specified by the "strFilePath" parameter. This parameter specifies how ' big the XML log file can get before starting a new file with an incremental number at the end. ' blnWriteToXmlFile Optional. If TRUE, the error information will be written to the file path specified in the ' "strFilePath" parameter. ' Return_PassedErrorNumber Optional. This will return the number passed in the "lngErrNumber" parameter so you can use this ' function to check errors as well as log them. ' Return_PassedErrorDescription Optional. This will return the description passed in the "strErrDescription" parameter so you can ' use this function to check errors as well as log them. ' Return_ErrNum Optional. If an error is encountered while sending an Email, logging the error to the NT Event Log, ' or logging the error to an XML file, this returns the number of the error that occured. The function ' will attempt to continue on even if an error occurs. ' Return_ErrDesc Optional. If an error is encountered while sending an Email, logging the error to the NT Event Log, ' or logging the error to an XML file, this returns the description of the error that occured. The ' function will attempt to continue on even if an error occurs. ' ' Return ' ŻŻŻŻŻŻ ' Returns TRUE if an error occured (the "lngErrNumber" parameter contains any number except ZERO) ' Returns FALSE if no error occured (the "lngErrNumber" parameter contains ZERO) ' '============================================================================================================= Public Function ErrorHandler(ByVal lngErrNumber As Long, _ ByVal strErrSource As String, _ ByVal strErrDescription As String, _ Optional ByVal strMethodName As String, _ Optional ByVal strTo As String = "You@Domain.com", _ Optional ByVal strFrom As String = "Program@Domain.com", _ Optional ByVal strSubject As String = "ErrorHandler - Error Report", _ Optional ByVal blnSendEmail As Boolean = True, _ Optional ByVal blnWriteToEventLog As Boolean = False, _ Optional ByVal strFilePath As String = "C:\ErrorLog.xml", _ Optional ByVal lngFileSizeLimit As Long = 5000000, _ Optional ByVal blnWriteToXmlFile As Boolean = False, _ Optional ByRef Return_PassedErrorNumber As Variant, _ Optional ByRef Return_PassedErrorDescription As Variant, _ Optional ByRef Return_ErrNum As Variant, _ Optional ByRef Return_ErrDesc As Variant) As Boolean On Error GoTo ErrorTrap Dim objEmail As CDONTS.NewMail Dim strServerName As String Dim strErrMsg As String Dim lngErrNum As Long Dim strErrDesc As String Dim strTimeStamp As String Err.Clear ' Set default values 10 Return_ErrNum = 0 20 Return_ErrDesc = "" 25 strTimeStamp = CStr(Now) ' Check if an error occured and exit if one did not 30 Return_PassedErrorNumber = lngErrNumber 40 Return_PassedErrorDescription = strErrDescription 50 If Return_PassedErrorNumber = 0 Then ' No Error occured, so exit 60 Exit Function 70 Else ' An error occured, so return TRUE to denote this. That way, this function can be used to check errors as well as log them. 80 ErrorHandler = True 90 End If ' Get the name of the server that's running this code 100 If GetThisComputersName(strServerName) = False Then strServerName = "(UNKNOWN)" ' Get the error message to log and/or Email 110 strErrMsg = "ErrorHandler Error Report:" & vbCrLf & _ "================================" & vbCrLf & _ "Date : " & strTimeStamp & vbCrLf & _ "Server : " & strServerName & vbCrLf & _ "Routine : " & strMethodName & vbCrLf & _ "Err Number : " & CStr(lngErrNumber) & vbCrLf & _ "Err Source : " & strErrSource & vbCrLf & _ "Err Description : " & vbCrLf & _ strErrDescription & vbCrLf '--------------------------------------------------------------------------------- ' Send Email to specified person/people 120 If blnSendEmail = True Then 140 If Trim(strTo) <> "" Then ' Setup the information needed to send the Email 150 Set objEmail = New CDONTS.NewMail 160 If Trim(strSubject) = "" Then strSubject = "ErrorHandler Error Report [" & strServerName & "]" 170 If Trim(strFrom) = "" Then strFrom = "Program@Domain.com" 180 If InStr(UCase(strFrom), ".COM") = 0 Then strFrom = strFrom & ".com" ' Setup the mail object 190 With objEmail 200 .to = strTo 210 .From = strFrom 220 .Subject = strSubject 230 .Body = strErrMsg 240 .Importance = CdoHigh 250 .BodyFormat = CdoBodyFormatText 260 .MailFormat = CdoMailFormatMime 270 End With ' Send the Email 280 Call objEmail.send ' Cleanup 290 Set objEmail = Nothing 300 Else 310 Return_ErrNum = -1: Return_ErrDesc = "No Email address specified to send the Email to" 320 End If 330 End If '--------------------------------------------------------------------------------- ' Log the error to the EventLog (WinNT/Win2000/WinXP) or file (Win9x/WinME) 340 If blnWriteToEventLog = True Then 350 Call LogEvent(strErrMsg, lngErrNumber, vbLogEventTypeError, Return_ErrNum, Return_ErrDesc) 360 End If '--------------------------------------------------------------------------------- ' Write out error to XML file 370 If blnWriteToXmlFile = True Then 380 strFilePath = Trim(strFilePath) 390 If strFilePath <> "" Then 400 Call LogToXML(strFilePath, lngErrNumber, strErrSource, strErrDescription, strMethodName, lngFileSizeLimit, Return_ErrNum, Return_ErrDesc) 410 Else 420 Return_ErrNum = -1: Return_ErrDesc = "No file path specified to write the XML error information to" 430 End If 440 End If '--------------------------------------------------------------------------------- ' Cleanup 450 Err.Clear 460 Set objEmail = Nothing 470 Exit Function ErrorTrap: ' Record that an error occured, and attempt to continue anyways Return_ErrNum = Err.Number Return_ErrDesc = Err.Description mlngErrLine = Erl Err.Clear Return_ErrDesc = "[Line " & mlngErrLine & "] " & Return_ErrDesc Resume Next End Function '============================================================================================================= ' GetThisComputersName ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' This function returns the name of the computer this code is running on ' ' Param Use ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' Return_ComputerName Returns the name of the computer this code is running on. ' Return_ErrNum Optional. If an error is encountered this returns the number of the error that occured. ' Return_ErrDesc Optional. If an error is encountered this returns the description of the error that occured. ' ' Return ' ŻŻŻŻŻŻ ' Returns TRUE if the routine executes without errors ' Returns FALSE if an error occured during execution ' '============================================================================================================= Public Function GetThisComputersName(ByRef Return_ComputerName As String, _ Optional ByRef Return_ErrNum As Variant, _ Optional ByRef Return_ErrDesc As Variant) As Boolean Dim strName As String Dim lngLen As Long ' Set default values Return_ComputerName = "" Return_ErrNum = 0 Return_ErrDesc = "" ' Setup the buffer to receive the name lngLen = 32 'MAX_COMPUTERNAME_LENGTH + 1 strName = String(lngLen, Chr(0)) ' Get the name and check for errors If GetComputerName(strName, lngLen) = 0 Then Call GetWin32ErrorDescription(Err.LastDllError, Return_ErrNum, Return_ErrDesc) Else Return_ComputerName = Left(strName, InStr(strName, Chr(0)) - 1) GetThisComputersName = True End If End Function '============================================================================================================= ' LogEvent ' ŻŻŻŻŻŻŻŻ ' Function that uses the Win32 API to write out to the specified information to the NT system's Event Log. If ' this code is run on a Win95, Win98, or WinME system... the information is logged to the system's event log file ' instead. ' ' Param Use ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' strEventText Specifies the text that should be written to the Event Log. ' lngErrNumber Specifies the error number. This number is stored in the Event's "EventID" field. ' EventType This specifies what type of event is to be logged. This can be "vbLogEventTypeInformation", ' "vbLogEventTypeWarning", or "vbLogEventTypeError" ' Return_ErrNum Optional. If an error is encountered this returns the number of the error that occured. ' Return_ErrDesc Optional. If an error is encountered this returns the description of the error that occured. ' ' Return ' ŻŻŻŻŻŻ ' Returns TRUE if the routine executes without errors ' Returns FALSE if an error occured during execution ' '============================================================================================================= Public Function LogEvent(ByVal strEventText As String, _ ByVal lngErrNumber As Long, _ Optional ByVal EventType As LogEventTypeConstants = vbLogEventTypeError, _ Optional ByRef Return_ErrNum As Variant, _ Optional ByRef Return_ErrDesc As Variant) As Boolean Dim strServerName As String Dim strLogLocation As String Dim hEventLog As Long Dim lngReported As Long ' Set default values Return_ErrNum = 0 Return_ErrDesc = "" ' Validate parameters strEventText = Trim(strEventText) If strEventText = "" Then Return_ErrNum = -1: Return_ErrDesc = "No text specified to log" Exit Function ElseIf GetThisComputersName(strServerName, Return_ErrNum, Return_ErrDesc) = False Then Exit Function ElseIf strServerName = "" Then Return_ErrNum = -1: Return_ErrDesc = "Could not get the name of the server to write event log to" Exit Function End If strEventText = vbCrLf & vbCrLf & strEventText & Chr(0) ' Open the event log hEventLog = OpenEventLog(strServerName & Chr(0), "ErrorHandler" & Chr(0)) If hEventLog = 0 Then Call GetWin32ErrorDescription(Err.LastDllError, Return_ErrNum, Return_ErrDesc) Exit Function End If ' Record the log event If ReportEvent(hEventLog, EventType, 1, lngErrNumber, ByVal 0, 1, 0, strEventText, ByVal 0) <> 0 Then LogEvent = True Else Call GetWin32ErrorDescription(Err.LastDllError, Return_ErrNum, Return_ErrDesc) End If If hEventLog <> 0 Then CloseEventLog hEventLog End Function '============================================================================================================= ' LogToXML ' ŻŻŻŻŻŻŻŻ ' This funciton takes the specified file path and error information and writes out the error information in XML format. ' If the specified file doesn't exist, it's created. If the file is larger than the specified maximum file size, a new ' file with the name "\." ' (where is the original path, ' is the original file's name without the file extention, ' is a numeric value that is incremented as new files are created, ' is teh original file's extention). ' ' Param Use ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' strFilePath Specifies the fully qualified file path to write out to. If the specified file ' does not exist, it is created. ' lngErrNumber Specifies the error number to write out. ' strErrSource Specifies the error source to write out. ' strErrDescription Specifies the error description to write out. ' strMethodName Optioanl. Specifies the Function, Sub, or Property which was being executed when ' the error occured. ' lngFileSizeLimit Optioanl. Specifies the largest size (in bytes) that the file can be before a new ' file is started. The default is 5 MB (5000000 bytes). ' Return_ErrNum Optional. If an error is encountered this returns the number of the error that occured. ' Return_ErrDesc Optional. If an error is encountered this returns the description of the error that occured. ' ' Return ' ŻŻŻŻŻŻ ' Returns TRUE if the routine executes without errors ' Returns FALSE if an error occured during execution ' '============================================================================================================= Public Function LogToXML(ByVal strFilePath As String, _ ByVal lngErrNumber As Long, _ ByVal strErrSource As String, _ ByVal strErrDescription As String, _ Optional ByVal strMethodName As String, _ Optional ByVal lngFileSizeLimit As Long = 5000000, _ Optional ByRef Return_ErrNum As Variant, _ Optional ByRef Return_ErrDesc As Variant) As Boolean On Error GoTo ErrorTrap Dim objXML As MSXML.DOMDocument Dim objRoot As MSXML.IXMLDOMElement Dim objNode As MSXML.IXMLDOMNode Dim objChild As MSXML.IXMLDOMNode Dim strServerName As String Dim FileNum As Integer Dim blnFileOpen As Boolean Dim intCurrentFile As Integer Dim strRealFile As String Dim strFileName As String Dim strFileExt As String Dim strTimeStamp As String ' Set default values 10 Return_ErrNum = 0 20 Return_ErrDesc = "" 25 strTimeStamp = CStr(Now) ' Validate parameters 30 strFilePath = Trim(strFilePath) 40 If strFilePath = "" Then 50 Return_ErrNum = -1 60 Return_ErrDesc = "No file specified to write to" 70 Exit Function 80 ElseIf GetThisComputersName(strServerName, Return_ErrNum, Return_ErrDesc) = False Then 90 Exit Function 100 ElseIf strServerName = "" Then 110 Return_ErrNum = -1: Return_ErrDesc = "Failed to get the name of the server" 120 Exit Function 130 End If ' If the file already exists, make sure it's not larger than the speicifed limit. If it is, start a new file. ' Files that get too big get to be unreadable and take a VERY long time to open. 140 If Dir(strFilePath, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" Then 150 strRealFile = strFilePath 160 Else 170 If FileLen(strFilePath) > lngFileSizeLimit Then 180 intCurrentFile = intCurrentFile + 1 190 strFileExt = GetFileExt(strFilePath) 200 strFileName = Left(strFilePath, Len(strFilePath) - Len(strFileExt)) 210 strRealFile = strFileName & CStr(intCurrentFile) & strFileExt 220 If Dir(strRealFile, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then 230 Do While FileLen(strRealFile) < lngFileSizeLimit 240 intCurrentFile = intCurrentFile + 1 250 strFileExt = GetFileExt(strFilePath) 260 strFileName = Left(strFilePath, Len(strFilePath) - Len(strFileExt)) 270 strRealFile = strFileName & CStr(intCurrentFile) & strFileExt 280 If Dir(strRealFile, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" Then Exit Do 290 Loop 300 End If 310 Else 320 strRealFile = strFilePath 330 End If 340 End If '--------------------------------------------------------------------- ' If the file exists, load it and add to it 350 If Dir(strRealFile, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then ' Create an XML object to work with 360 Set objXML = New MSXML.DOMDocument ' Load the file 370 If objXML.Load(strRealFile) = True Then ' Make sure we successfully loaded the file 380 If objXML Is Nothing Then 390 Err.Raise -1, "objXML.Load", "Failed to successfully load the XML error log" 400 Exit Function 410 End If ' Get the root element of the file 420 Set objRoot = objXML.documentElement 430 If objRoot Is Nothing Then 440 Err.Raise -1, "Set objRoot = objXML.documentElement", "Failed to successfully get a reference to the XML file's root node." 450 Exit Function 460 End If ' Set the "CreatedOn" attribute of the ROOT node 470 If Trim(objRoot.getAttribute("CreatedOn")) = "" Then 480 Call objRoot.setAttribute("CreatedOn", strTimeStamp) 490 End If ' Set the "LastUpdated" attribute of the ROOT node 500 Call objRoot.setAttribute("LastUpdated", strTimeStamp) ' Create a new node off of the ROOT at the end of the file 510 Set objNode = objRoot.appendChild(objXML.createNode(NODE_ELEMENT, "ErrorEvent", "")) 520 If Not objNode Is Nothing Then 530 Set objChild = objNode.appendChild(objXML.createNode(NODE_ELEMENT, "ServerName", "")) 540 objChild.Text = strServerName 550 Set objChild = objNode.appendChild(objXML.createNode(NODE_ELEMENT, "ErrorDate", "")) 560 objChild.Text = strTimeStamp 570 Set objChild = objNode.appendChild(objXML.createNode(NODE_ELEMENT, "ErrorRoutine", "")) 580 objChild.Text = strMethodName 590 Set objChild = objNode.appendChild(objXML.createNode(NODE_ELEMENT, "ErrorNumber", "")) 600 objChild.Text = CStr(lngErrNumber) 610 Set objChild = objNode.appendChild(objXML.createNode(NODE_ELEMENT, "ErrorSource", "")) 620 objChild.Text = strErrSource 630 Set objChild = objNode.appendChild(objXML.createNode(NODE_ELEMENT, "ErrorDescription", "")) 640 objChild.Text = strErrDescription 650 End If 660 objXML.Save strRealFile 670 End If '--------------------------------------------------------------------- ' File doesn't exist, so create it 680 Else 690 FileNum = FreeFile 700 Open strRealFile For Output As #FileNum 710 Print #FileNum, "" & vbCrLf 720 Print #FileNum, "" & vbCrLf 730 Print #FileNum, " " & vbCrLf 740 Print #FileNum, " " & strServerName & "" & vbCrLf 750 Print #FileNum, " " & strTimeStamp & "" & vbCrLf 760 Print #FileNum, " " & strMethodName & "" & vbCrLf 770 Print #FileNum, " " & CStr(lngErrNumber) & "" & vbCrLf 780 Print #FileNum, " " & strErrSource & "" & vbCrLf 790 Print #FileNum, " " & strErrDescription & "" & vbCrLf 800 Print #FileNum, " " & vbCrLf 810 Print #FileNum, "" & vbCrLf 820 Close #FileNum 830 End If '--------------------------------------------------------------------- ' Clean up 840 Set objXML = Nothing 850 Set objRoot = Nothing 860 Set objNode = Nothing 870 Set objChild = Nothing 880 LogToXML = True 890 Exit Function ErrorTrap: Return_ErrNum = Err.Number Return_ErrDesc = Err.Description mlngErrLine = Erl Err.Clear Return_ErrDesc = "[Line " & mlngErrLine & "] " & Return_ErrDesc Set objXML = Nothing Set objRoot = Nothing Set objNode = Nothing Set objChild = Nothing End Function '============================================================================================================= ' GetWin32ErrorDescription ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' Function that gets the description of the error that was caused by the last Win32 API that was called. ' This only works with Win32 API's that use the GetLastError function to return an error code. Not all API's do. ' ' Param Use ' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ ' Win32ErrorNumber Optional. Error number to display. You should normally pass the "Err.LastDllError" ' value to this property if not the return value of the "GetLastError" API. If this is ' set to zero, then the GetLastError API is called to see if any errors have occured. If ' no error have occured, the function exits. ' Return_ErrNum Optional. This returns the number of the error that just occured. If the "Win32ErrorNumber" ' parameter wasn't specified but an error was found by this function, the error number ' is returned here. ' Return_ErrDesc Optional. This returns the description of the last error that occured. ' ' Return ' ŻŻŻŻŻŻ ' If no error occured, no message is displayed & function returns FALSE. ' If an error occured, an error message is displayed & the function returns TRUE. '============================================================================================================= Public Function GetWin32ErrorDescription(Optional ByVal Win32ErrorNumber As Long, _ Optional ByRef Return_ErrNum As Variant, _ Optional ByRef Return_ErrDesc As Variant) As Boolean On Error Resume Next Dim strErrDesc As String ' Clear the return values first Return_ErrNum = 0 Return_ErrDesc = "" ' If no error message is specified then check for one If Win32ErrorNumber = 0 Then Win32ErrorNumber = GetLastError If Win32ErrorNumber = 0 Then GetWin32ErrorDescription = False Exit Function End If End If ' Allocate a buffer for the error description strErrDesc = String(MAX_PATH, 0) ' Get the error description If FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0, Win32ErrorNumber, 0, strErrDesc, MAX_PATH, 0) <> 0 Then Return_ErrNum = Win32ErrorNumber Return_ErrDesc = Left(strErrDesc, InStr(strErrDesc, Chr(0)) - 1) If Right(Return_ErrDesc, Len(vbCrLf)) = vbCrLf Then Return_ErrDesc = Left(Return_ErrDesc, Len(Return_ErrDesc) - Len(vbCrLf)) End If GetWin32ErrorDescription = True End If ' Set the last error to 0 (no error) so next time through it doesn't report the same error twice SetLastError 0 End Function 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ' This takes the specified file or path and strips off the extention of the file specified. Private Function GetFileExt(ByVal strFullPath As String) As String Dim lngCounter As Long Dim strLeft As String Dim strRight As String Dim strSoFar As String ' If the file has no extention, then exit If InStr(strFullPath, ".") < 1 Then Exit Function For lngCounter = 1 To Len(strFullPath) strRight = Right(strFullPath, lngCounter) strLeft = Left(strRight, 1) If strLeft = "." Then GetFileExt = "." & strSoFar Exit Function ElseIf strLeft = "/" Or strLeft = "\" Then Exit Function Else strSoFar = strLeft & strSoFar End If Next End Function