moderrormanager.bas

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

    LsErrorNum = Format(lErrNum, "00000000")
    LsVersion = Format(App.Major, "00") & Format(App.Minor, "000") & Format(App.Revision, "00")
    LsDate = Format(Now, "yyyymmdd")
    LsTime = Format(Now, "hmmss")
    If (Len(LsTime) < 6) Then LsTime = ("0" & LsTime)
    prvGetErrorUniqueID = ("E" & LsErrorNum & "-" & LsVersion & "-" & LsDate & LsTime)
End Function


Public Function prvGetMemoryStatus() As String
    Dim LrMemoryStatus As MEMORYSTATUS
    Dim LnFree As Long
    Dim LnTotal As Long
    Dim LnPercent As Single
    Dim LsBuffer As String

    With LrMemoryStatus
        .dwLength = 32
        GlobalMemoryStatus LrMemoryStatus
        LnFree = (.dwAvailPhys / 1024)
        LnTotal = (.dwTotalPhys / 1024)
    End With
    LnPercent = ((LnFree / LnTotal) * 100)
    LsBuffer = (Format(LnFree, "#,###,###,##0") & " / " & Format(LnTotal, "#,###,###,##0") & " Kb")
    LsBuffer = LsBuffer & " (" & Format(LnPercent, "##0.0#%") & " Free)"
    prvGetMemoryStatus = "RAM Memory:  " & LsBuffer
End Function


Public Sub SetLogPath(sPath As String)
    m_sLogPath = sPath
    If (Right$(m_sLogPath, 1) <> "\") Then m_sLogPath = m_sLogPath & "\"
End Sub

Public Function DirExist(sPath As String) As Boolean
    DirExist = (Dir(sPath, vbDirectory) <> "")
End Function

Private Function prvGetDiskSpace(Optional sDrive As String = "C") As String
    Dim LnSectorsPerCluster As Long
    Dim LnBytesPerSector As Long
    Dim LnFreeClustersCount As Long
    Dim LnTotalClustersCount As Long
    Dim LnRetCD As Long
    Dim LnFree As Long
    Dim LnTotal As Double
    Dim LnPercent As Single
    
    sDrive = Left$(Trim$(sDrive), 1) & ":\"    ' Ensure path is at the root.
    LnRetCD = GetDiskFreeSpace(sDrive, LnSectorsPerCluster, LnBytesPerSector, LnFreeClustersCount, LnTotalClustersCount)
    If (LnRetCD = 0) Then
        prvGetDiskSpace = "Disk Space: [Unknown]"
    Else
        LnFree = ((LnSectorsPerCluster * LnBytesPerSector * LnFreeClustersCount) / 1024)
        LnTotal = ((LnSectorsPerCluster * LnBytesPerSector * LnTotalClustersCount) / 1024)
        LnPercent = (LnFree / LnTotal)
        prvGetDiskSpace = "Disk Space:  " & (Format(LnFree, "#,###,###,##0") & " / " & _
            Format(LnTotal, "#,###,###,##0") & " Kb (" & Format(LnPercent, "##0.0#%") & " Free)")
    End If
End Function

Private Function prvGetCPUInfo() As String
    Dim LrSystemInfo As SYSTEM_INFO
    Dim LsProcessorName As String
    Dim LsBuffer As String
    Dim LsTemp As String

    GetSystemInfo LrSystemInfo
    
    LsTemp = prvGetKeyValue(HKEY_LOCAL_MACHINE, RK_Processor, "Identifier")
    If (Len(LsTemp) = 0) Then
        Select Case LrSystemInfo.dwProcessorType
            Case PROCESSOR_INTEL_386
                LsTemp = "Intel 386"
            Case PROCESSOR_INTEL_486
                LsTemp = "Intel 486"
            Case PROCESSOR_INTEL_PENTIUM
                LsTemp = "Intel Pentium"
            Case PROCESSOR_MIPS_R4000
                LsTemp = "MIPS R4000"
            Case PROCESSOR_ALPHA_21064
                LsTemp = "DEC Alpha 21064"
            Case Else
                LsTemp = "[Unknown]"
        End Select
    End If
    LsBuffer = LsTemp
    LsTemp = Trim$(prvGetKeyValue(HKEY_LOCAL_MACHINE, RK_Processor, "~MHZ"))
    If (Len(LsTemp) > 0) Then
        LsBuffer = LsBuffer & " " & LsTemp & " MHz"
    End If
    LsTemp = prvGetKeyValue(HKEY_LOCAL_MACHINE, RK_Processor, "VendorIdentifier")
    If (Len(LsTemp) > 0) Then
        LsBuffer = LsBuffer & " (" & LsTemp & ") "
    End If
    With LrSystemInfo
        If (.dwNumberOrfProcessors > 1) Then
            LsTemp = " " & .dwNumberOrfProcessors & " processors (#" & .dwActiveProcessorMask & " active)"
            LsBuffer = (LsBuffer & LsTemp)
        End If
    End With
    prvGetCPUInfo = "Processors:  " & LsBuffer
End Function

Private Function prvGetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String) As String
'==========================================================================================================='
' Returns a specified key value from the registry                                                           '
'==========================================================================================================='
    Dim LnKey As Long
    Dim LsBuffer As String
    Dim LnKeySize As Long
    Dim LnKeyType As Long
    Dim LnIdx As Integer
    
    ' Prepares data buffer
    LsBuffer = String(1024, 0)
    LnKeySize = 1024
    ' Open the registry key. Any value other than zero means something went wrong
    If (RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_QUERY_VALUE, LnKey) = 0) Then
        ' Retrieve the registry value, any value other than zero means something went wrong
        If (RegQueryValueEx(LnKey, SubKeyRef, 0, LnKeyType, LsBuffer, LnKeySize) = 0) Then
            ' Extract the useful string from the garble
            If (Asc(Mid(LsBuffer, LnKeySize, 1)) = 0) Then
                LsBuffer = Left(LsBuffer, LnKeySize - 1)
            Else
                LsBuffer = Left(LsBuffer, LnKeySize)
            End If
            ' If the returned value is a dword we need to format the value to something meaningful
            If (LnKeyType = 4) Then
                For LnIdx = Len(LsBuffer) To 1 Step -1
                    prvGetKeyValue = prvGetKeyValue + Hex(Asc(Mid(LsBuffer, LnIdx, 1)))
                Next
                prvGetKeyValue = Format("&H" & prvGetKeyValue)
            Else
                prvGetKeyValue = LsBuffer
            End If
        End If
    End If
    RegCloseKey LnKey
End Function

Public Function MkDirNested(sFullPath As String) As Boolean
    On Error GoTo ErrHandler
    Dim LnNextSlash As Integer
    Dim LnStartPos As Integer
    Dim LsCurDir As String
    ' Set first char
    LnStartPos = 1
    ' validates path syntax
    If (Right$(sFullPath, 1) <> "\") Then sFullPath = (sFullPath & "\")
    Do
        LnNextSlash = InStr(LnStartPos, sFullPath, "\")
        If (LnNextSlash >= LnStartPos) Then
            LsCurDir = Left$(sFullPath, LnNextSlash)
            If (Not DirExist(LsCurDir)) Then
               ' Create the dir
               MkDir LsCurDir
            End If
             ' Check if it's the last char and exit if true
             LnStartPos = (LnNextSlash + 1)
             If (LnStartPos >= Len(sFullPath)) Then Exit Do
        End If
    Loop
    MkDirNested = True
    Exit Function
ErrHandler:
    MkDirNested = False
End Function

Public Function GetLogPath() As String
    GetLogPath = m_sLogPath
End Function

Public Sub RaiseError(ByVal lErrNum As RSErrorCode, sModuleName As String, _
    Optional sRoutineName As String, Optional sDescription As String, _
    Optional lLineNumber As Long)
    Dim LsSource As String
    
    LsSource = App.EXEName & "." & sModuleName
    If Len(sRoutineName) Then LsSource = LsSource & "." & sRoutineName
    If (lLineNumber <> 0) Then LsSource = LsSource & "." & CStr(lLineNumber)
    If (lErrNum > ecBaseError) And (Len(sDescription) = 0) Then _
        sDescription = prvGetErrorDescription(lErrNum)
    #If LOG_ENABLED_SYSTEM Then
    Trace sDescription, LsSource, lErrNum, vbLogEventTypeError
    #Else
    prvLogError lErrNum, sDescription, LsSource
    #End If
    Err.Clear
    On Error GoTo 0
    If Len(sDescription) Then
        Err.Raise lErrNum, LsSource, sDescription
    Else
        Err.Raise lErrNum, LsSource
    End If
End Sub

Private Function prvGetErrorDescription(lErrCD As RSErrorCode) As String
    Select Case lErrCD
        Case ecInvalidConnectInfo
            prvGetErrorDescription = "Invalid connection info."
        Case ecInvalidValue
            prvGetErrorDescription = "Invalid value."
        Case ecODBCDriversInitFailed
            prvGetErrorDescription = "Unable to initialize ODBC API drivers!."
        Case ecODBCMemoryAllocFailed
            prvGetErrorDescription = "Could not allocate memory for connection\statement Handle!."
        Case ecODBCFreingEnvFailed
            prvGetErrorDescription = "Error Freeing Environment From ODBC Drivers."
        Case ecODBCConnectionFailed
            prvGetErrorDescription = "Could not establish connection to ODBC driver!."
        Case ecODBCLogOutFailed
            prvGetErrorDescription "Error logging out of data source!."
        Case ecODBCDriversUnloadFailed
            prvGetErrorDescription = "Error unloading ODBC drivers!."
        Case ecDataSetEmpty
            prvGetErrorDescription = "No data returned."
        Case ecODBC_SQL_Error
            prvGetErrorDescription = "SQL driver error."
        Case ecInvalidDataSourceType
            prvGetErrorDescription = "Invalid Data Source Type."
        Case ecErrorImportingData
            prvGetErrorDescription = "Error importing data."
        Case ecCryptWrongPassword
            prvGetErrorDescription = "Invalid decryption password was passed."
        Case ecInvalidObjType
            prvGetErrorDescription = "Invalid Object Type."
        Case ecFormAlreadyLoaded
            prvGetErrorDescription = "Form already loaded."
        Case ecObjectDoesNotExist
            prvGetErrorDescription = "Object does not exist."
        Case ecInvalidPropertyName
            prvGetErrorDescription = "Invalid property name."
        Case ecInvalidDeviceContext
            prvGetErrorDescription = "Invalid Device Context."
        Case ecInvalidPropertyUsage
            prvGetErrorDescription = "Invalid property usage at this time."
        Case ecInvalidStartUpModule
            prvGetErrorDescription = "Invalid StartUp module."
        Case ecTooManyTimers
            prvGetErrorDescription = "No more than 10 timers allowed per class."
        Case ecCantCreateTimer
            prvGetErrorDescription = "Can't create system timer."
        Case ecNoPrintersDefined
            prvGetErrorDescription = "No printers defined."
        Case ecFileDoesNotExist
            prvGetErrorDescription = "File does not exist."
        Case ecInvalidFileFormat
            prvGetErrorDescription = "Invalid file format or signature."
        Case ecSymbolAlreadyDefined
            prvGetErrorDescription = "Symbol already defined."
        Case ecSymbolNotDefined
            prvGetErrorDescription = "Symbol not defined."
        Case ecEmptyStackCall
            prvGetErrorDescription = "Invalid Empty Stack Call."
        Case ecCryptAcquirefailed
            prvGetErrorDescription = "Function CryptoAcquireContext failed"
        Case ecCryptCreateHashfailed
            prvGetErrorDescription = "Function CryptCreateHash failed"
        Case ecCryptHashDatafailed
            prvGetErrorDescription = "Function CryptHashData failed"
        Case ecCryptDeriveKeyfailed
            prvGetErrorDescription = "Function CryptDeriveKey failed"
        Case ecCryptEncryptFailed
            prvGetErrorDescription = "Function CryptEncrypt failed"
        Case ecCompressedDataCorrupted
            prvGetErrorDescription = "Data might be corrupted (Invalid Checksum)."
        Case ecBaseWindowProc
            prvGetErrorDescription = "Base Window Procedure (SubClass)."
        Case ecCantSubclass           ' Can't subclass window
            prvGetErrorDescription = "Can't subclass window"
        Case ecAlreadyAttached        ' Message already handled by another class
            prvGetErrorDescription = "Message already handled by another class"
        Case ecInvalidWindow          ' Invalid window
            prvGetErrorDescription = "Invalid window"
        Case ecNoExternalWindow       ' Can't modify external window
            prvGetErrorDescription = "Can't modify external window"
        Case Else
            prvGetErrorDescription = "Unknown error."
    End Select
End Function

Public Sub Trace(sMessage As String, Optional sSource As String, _
    Optional lEventCD As Long, Optional iEventType _
    As LogEventTypeConstants = vbLogEventTypeInformation)
    Dim LsMsg As String
    Dim LsHdr As String
    Dim LsSrc As String
    
    Select Case iEventType
        Case vbLogEventTypeError
            LsHdr = "Error ["
        Case vbLogEventTypeInformation
            LsHdr = "Info ["
        Case vbLogEventTypeWarning
            LsHdr = "Warning ["
        Case Else
            LsHdr = "Event ["
    End Select
    LsHdr = LsHdr & Format(Now, "mm-dd-yyyy h:mm] ")
    If (lEventCD <> 0) Then
        LsMsg = "[CD 0x" & Hex(lEventCD) & "] "
    End If
    LsMsg = LsMsg & sMessage
    If (Len(sSource) = 0) Then
        LsSrc = "Unknown Source"
    Else
        LsSrc = "Source: " & sSource
    End If
    App.LogEvent LsHdr & LsMsg & ", " & LsSrc, iEventType
    WriteLog String(50, "-")
    WriteLog LsHdr
    WriteLog LsMsg
    WriteLog sSource
    WriteLog String(50, "-")
End Sub

Private Function prvLogError(lErrorNum As Long, sDescription As String, sSource As String) As String
    Dim LsFile As String
    Dim LnFileHandler As Integer

    On Error GoTo prvLogError_EH
    LsFile = App.Path & "\" & App.EXEName & ".err"
    prvLogError = prvGetErrorUniqueID(lErrorNum)
    LnFileHandler = FreeFile
    Open LsFile For Append As #LnFileHandler
    Print #LnFileHandler, String(60, "=")
    Print #LnFileHandler, "Event ID: " & prvLogError
    Print #LnFileHandler, String(60, "-")
    Print #LnFileHandler, "Error number " & CStr(lErrorNum) & ", ocurred on " & Format(Now, "Mmmm dd yyyy, h:mm") & " Hrs"
    Print #LnFileHandler, App.EXEName & " version " & CStr(App.Major) & "." & CStr(App.Minor) & "." & CStr(App.Revision)
    Print #LnFileHandler, "Source: " & sSource
    Print #LnFileHandler, "Description: " & sDescription
    Print #LnFileHandler, String(60, "-")
    Print #LnFileHandler, GetSysInfo
    Print #LnFileHandler, String(60, "_")
prvLogError_EH:
    Close #LnFileHandler
End Function