moderrormanager.bas

VB做的报表设计源程序,非常不错,可以自定义模版

Attribute VB_Name = "modErrorManager"
'////////////////////////////////////////////////////////
'///          Error Handling & Management Module
'///                (modErrorManager.bas)
'///_____________________________________________________
'/// Error management and handling routines. Error codes
'/// enumeration are supported here.
'/// Each Class/Control/Module must have a RaiseErr method
'/// to call this global routines.
'///_____________________________________________________
'/// Last modification  : Ago/10/2000
'/// Last modified by   : Leontti R.
'/// Modification reason: Commented
'/// Project: RamoSoft Code Foundation
'/// Author: Leontti A. Ramos M. ([e-mail])
'/// RamoSoft de Mexico S.A. de C.V.
'////////////////////////////////////////////////////////
Option Explicit

#Const EXTERNAL_PROVIDER = 1
#Const ERROR_TRAP_ENABLED = 0
#Const LOG_ENABLED_SYSTEM = 1

#If ERROR_TRAP_ENABLED Then
Public Enum ErrorTrapAction
    ERR_RESUMENEXT = 0
    ERR_RESUME = 1
    ERR_QUIT = 2
    ERR_EXITSUB = 3
End Enum
#End If
Public Enum RSErrorCode
    ' Generic errors
    ecBaseError = 1000
    ecInvalidConnectInfo
    ecInvalidValue
    ' ODBC Errors
    ecODBCDriversInitFailed = 1030
    ecODBCMemoryAllocFailed
    ecODBCConnectionFailed
    ecODBCLogOutFailed
    ecODBCDriversUnloadFailed
    ecODBCFreingEnvFailed
    ' DataSet related errors
    ecDataSetEmpty = 1039
    ecODBC_SQL_Error = 1050
    ecInvalidDataSourceType
    ecErrorImportingData
    ' Data stream related
    ecCryptWrongPassword = 1060
    ecCryptAcquirefailed
    ecCryptCreateHashfailed
    ecCryptHashDatafailed
    ecCryptDeriveKeyfailed
    ecCryptEncryptFailed
    ecCompressedDataCorrupted
    ' Object related errors
    ecInvalidObjType = 1070
    ecFormAlreadyLoaded
    ecObjectDoesNotExist
    ecInvalidPropertyName
    ecInvalidDeviceContext
    ecInvalidPropertyUsage
    ecInvalidStartUpModule
    ' System related
    ecTooManyTimers = 1080
    ecCantCreateTimer
    ecNoPrintersDefined
    ecFileDoesNotExist
    ecInvalidFileFormat
    ' Parsing and variable related
    ecSymbolAlreadyDefined = 1090
    ecSymbolNotDefined
    ecEmptyStackCall
    ' SubClass error codes
    ecBaseWindowProc = 13080 ' WindowProc
    ecCantSubclass           ' Can't subclass window
    ecAlreadyAttached        ' Message already handled by another class
    ecInvalidWindow          ' Invalid window
    ecNoExternalWindow       ' Can't modify external window
End Enum

Private m_sLogPath As String
'//////////////////////////////////////////////////
'--------------- Disk Free Space ------------------
Private Declare Function GetFreeSpace Lib "KERNEL32.dll" (ByVal wFlags As Integer) As Long
Private Declare Function GetDiskFreeSpace Lib "KERNEL32.dll" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
'--------------- Registry Access ------------------
Private Const KEY_QUERY_VALUE = &H1 ' Registry Key open mode
Private Const HKEY_LOCAL_MACHINE = &H80000002 ' The Registry section we'll be visiting
Private Const HKEY_DYN_DATA = &H80000006
Private Const RK_Processor = "HARDWARE\DESCRIPTION\System\CentralProcessor\0" ' Root to the processor information
Private Const RK_Performance = "PerfStats\StatData" ' Root to performance statistics
Private Const RK_WIN32_OS = "SOFTWARE\Microsoft\Windows\CurrentVersion" ' Root to OS information on Win machines
Private Const RK_WIN32_OS_NT = "SOFTWARE\Microsoft\Windows NT\CurrentVersion" ' Root to OS information on NT machines
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'-------------- System Information ----------------
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformID As Long
    szCSDVersion As String * 128
End Type
'------------ User & WorkStation Info -------------
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'------------ IP Address Information --------------
Private Type HOSTENT
    hName      As Long
    hAliases   As Long
    hAddrType  As Integer
    hLen       As Integer
    hAddrList  As Long
End Type
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
'--------- Version information constants -----------
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
'--------- System information constants -----------
Private Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
End Type
Private Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type
Private Const PROCESSOR_INTEL_386 = 386
Private Const PROCESSOR_INTEL_486 = 486
Private Const PROCESSOR_INTEL_PENTIUM = 586
Private Const PROCESSOR_MIPS_R4000 = 4000
Private Const PROCESSOR_ALPHA_21064 = 21064
Private Declare Sub GlobalMemoryStatus Lib "KERNEL32.dll" (lpBuffer As MEMORYSTATUS)
Private Declare Sub GetSystemInfo Lib "KERNEL32.dll" (lpSystemInfo As SYSTEM_INFO)

Public Function GetSysInfo() As String
    GetSysInfo = prvGetUserInfo & vbCrLf
    GetSysInfo = GetSysInfo & prvGetWSInfo & vbCrLf
    GetSysInfo = GetSysInfo & prvGetOSInfo & vbCrLf
    GetSysInfo = GetSysInfo & prvGetCPUInfo & vbCrLf
    GetSysInfo = GetSysInfo & prvGetMemoryStatus & vbCrLf
    GetSysInfo = GetSysInfo & prvGetDiskSpace
End Function

Public Function prvGetLocalIP() As String
    'Resolves the LrHost-name (or current machine if balnk) to an IP address
    Dim LsHostName As String * 256
    Dim LnHostIP As Long
    Dim LrHost As HOSTENT
    Dim dwIPAddr As Long
    Dim tmpIPAddr() As Byte
    Dim LnIdx As Integer
    Dim LsIPAddress As String

    Call GetComputerName(LsHostName, 255)
    LnHostIP = gethostbyname(LsHostName)
    If (LnHostIP <> 0) Then
        CopyMemory LrHost, LnHostIP, Len(LrHost)
        CopyMemory dwIPAddr, LrHost.hAddrList, 4
        ReDim tmpIPAddr(1 To LrHost.hLen)
        CopyMemory tmpIPAddr(1), dwIPAddr, LrHost.hLen
        For LnIdx = 1 To LrHost.hLen
            LsIPAddress = LsIPAddress & tmpIPAddr(LnIdx) & "."
        Next
        prvGetLocalIP = Mid$(LsIPAddress, 1, Len(LsIPAddress) - 1)
    End If
End Function


#If ERROR_TRAP_ENABLED Then
Public Function ErrorTrap(sModuleName As String) As ErrorTrapAction
    Dim LnErrorCD As Long
    Dim LsErrorSrc As String
    Dim LsErrorDescr As String
    Dim LsCaption As String
    Dim LsLogID As String
    Dim LnLastCursor As Long
    ' Retrieve Error information as soon as posible
    ' to avoid Err object to be cleared
    LnErrorCD = Err.Number
    LsErrorSrc = Err.Source
    LsErrorDescr = Err.Description
    ' Ok, now you can safely clear Err object to avoid
    ' Some system confusion with then previous error
    Err.Clear
    ' Obtain a unique log identifier to report pourposes
    LsLogID = prvLogError(LnErrorCD, LsErrorDescr, LsErrorSrc)
    ' Stores old cursos state, sets a default one
    LnLastCursor = Screen.MousePointer
    Screen.MousePointer = vbDefault
    ' Build a descriptive form caption
    With App
        LsCaption = .EXEName & " v" & .Major & "." & .Minor & " (Rev. " & .Revision & ") "
    End With
    ' Fill in form values
    On Error GoTo ERROR_HANDLER
    With frmErrorTrap
        .TimeStamp = Now
        .SerialNumber = "Log ID: " & LsLogID
        .SystemInfo = GetSysInfo
        .ErrorNumber = LnErrorCD
        ' Description must be very informative
        .ErrorDescription = Format(Now, "Mmmm dd yyyy, h:mm") & " Hrs" & vbCrLf & _
            LsErrorDescr & vbCrLf & String(50, "-") & vbCrLf & .SystemInfo
        .ErrorSource = LsErrorSrc
        .Caption = LsCaption
        .ModuleName = sModuleName
        .Show vbModal
        ErrorTrap = .UserSelection
    End With
    Screen.MousePointer = LnLastCursor
ERROR_HANDLER:
    Unload frmErrorTrap
End Function
#End If

Private Function prvGetOSInfo() As String
    Dim LrOSVersion As OSVERSIONINFO
    
    With LrOSVersion
        .dwOSVersionInfoSize = 148
        GetVersionEx LrOSVersion
        If (.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) Then
            If (.dwMinorVersion = 0) Then
                prvGetOSInfo = "Microsoft Windows 95"
            Else
                prvGetOSInfo = "Microsoft Windows 98"
            End If
        ElseIf (.dwPlatformID = VER_PLATFORM_WIN32_NT) Then
            If (.dwMajorVersion = 4) Then
                prvGetOSInfo = "Microsoft Windows NT"
            Else
                prvGetOSInfo = "Microsoft Windows 2000"
            End If
        End If
        prvGetOSInfo = "Op. System:  " & prvGetOSInfo & " v" & .dwMajorVersion & "." & _
            Format(.dwMinorVersion, "00") & "." & .dwBuildNumber & _
            Left$(.szCSDVersion, (InStr(1, .szCSDVersion, Chr(0)) - 1))
    End With
End Function

Private Function prvGetUserInfo() As String
    Dim LsBuffer As String
    Dim LnRetCD As Long
    
    LsBuffer = String(255, 0)
    LnRetCD = GetUserName(LsBuffer, 255)
    LsBuffer = Left$(LsBuffer, (InStr(1, LsBuffer, Chr(0)) - 1))
    prvGetUserInfo = "Logged User: " & IIf((Len(LsBuffer) = 0), "[No Logged]", "lsbuffer")
End Function

Private Function prvGetWSInfo() As String
    Dim LsBuffer As String * 256
    Dim LnRetCD As Long
    
    LnRetCD = GetComputerName(LsBuffer, 255)
    LsBuffer = Left$(LsBuffer, (InStr(1, LsBuffer, Chr(0)) - 1))
    prvGetWSInfo = "Workstation: " & RTrim$(LsBuffer) & " (IP " & prvGetLocalIP & ")"
End Function

Public Sub WriteLog(sText As String)
    On Error Resume Next
    Dim LsPath As String
    Dim LhFile As Integer
    Dim LsData As String
    
    ' Creates the log file path
    If (Len(m_sLogPath) = 0) Then
        LsPath = App.Path
    Else
        LsPath = m_sLogPath
    End If
    If (Right$(LsPath, 1) <> "\") Then LsPath = LsPath & "\"
    LsPath = LsPath & App.EXEName & "Log" & Format(Year(Now), "00") & "\" & Format(Month(Now), "00") & "\"
    ' Esure directory exists
    If (Not DirExist(LsPath)) Then
        MkDirNested LsPath
    End If
    LsPath = LsPath & Format(Day(Now), "00.log")
    ' Build log string
    If (Right$(sText, 2) = vbCrLf) Then
        sText = Left$(sText, (Len(sText) - 2))
    End If
    LsData = "[" & Format(Now, "YYYY-MM-DD ") & Format(Now, "H:MM.SS") & "] " & sText
    Debug.Print LsData
    ' Open log file to write in
    LhFile = FreeFile
    ' If the file was just created, write down a descriptive header
    If (Dir(LsPath) = "") Then
        Open LsPath For Append As LhFile
        With App
            Dim LsDescr As String
            Print #LhFile, String(50, "=")
            #If EXTERNAL_PROVIDER Then
            LsDescr = .EXEName
            #Else
            LsDescr = IIf((.ProductName = ""), ("RamoSoft " & .EXEName), .ProductName)
            #End If
            LsDescr = LsDescr & " v" & .Major & "." & .Minor & IIf((.Revision > 0), (" (Rev. " & .Revision & ")"), "")
            Print #LhFile, LsDescr
            Print #LhFile, "Aplication log file for " & Format(Now, "Mmm dd, yyyy")
            Print #LhFile, String(50, "-")
            Print #LhFile, GetSysInfo
            Print #LhFile, String(50, "=")
        End With
    Else
        Open LsPath For Append As LhFile
    End If
    Print #LhFile, LsData
    Close #LhFile
End Sub

Private Function prvGetErrorUniqueID(lErrNum As Long) As String
    Dim LsErrorNum As String
    Dim LsVersion As String
    Dim LsDate As String
    Dim LsTime As String
    Dim LnLen As Integer
    
    On Error Resume Next