exceptionbase.cls

来自「VB 加密----------能够加密解密控件」· CLS 代码 · 共 436 行 · 第 1/2 页

'
' @param RHS A description of the source of the exception.
' @remarks The source of an exception generally will contain the name of
' the function being called when the exception was thrown. This is to help
' narrow down exactly where the exception had occurred.
'
Public Property Let Source(ByVal RHS As String)
    mSource = RHS
End Property

''
' Gets a link to a help file associated with the exception.
'
' @return The Uniform Resource Name (URN) or Uniform Resource Locator (URL).
' @remarks The return value, which represents a help file, is a URN or URL. For example, the HelpLink value could be:<br>
' "http://www.myhelpsite.com"
'
Public Property Get HelpLink() As String
    HelpLink = mHelpLink
End Property

''
' Sets a link to a help file associated with the exception.
'
' @param RHS Set the Uniform Resource Name (URN) or Uniform Resource Locator (URL).
' @remarks The return value, which represents a help file, is a URN or URL. For example, the HelpLink value could be:<br>
' "http://www.myhelpsite.com"
'
Public Property Let HelpLink(ByVal RHS As String)
    mHelpLink = RHS
End Property

''
' Gets the original exception that caused the chain of exceptions to occur.
'
' @param Subclass The parent class that contains the <b>ExceptionBase</b> helper class.
' @return The <b>Exception</b> that caused the chain of exceptions to occur.
' @remarks If exceptions set their <b>InnerException</b> to a previously thrown
' exception, then a chain of exceptions can be created. Using this function will
' traverse that chain of exceptions until the original exception is reached. That
' exception with then be returned to the caller.
' <p>When an <b>InnerException</b> of Nothing is reached, then the Subclass is returned
' as the base exception because it did not have an inner exception, so it is assumed that
' the Subclass exception is the last in the chain and therefore the cause of the
' chain of exceptions being iterated.
'
Public Function GetBaseException() As Exception
    If mInnerException Is Nothing Then
        Set GetBaseException = Subclass
    Else
        Set GetBaseException = mInnerException.GetBaseException
    End If
End Function

''
' Returns the exception message prepended with the type name of the Subclass Exception.
'
' @param FormattedMessage This allows the Subclass to pass in a formatted version of the
' original message to be used in creating the resulting string. If the message is not
' passed in, then the internal <b>GetMessage</b> method will be used.
' @param AppTitle The name of the EXE, DLL or OCX that contains the exception Subclass.
' @param Subclass The parent Subclass object to derived the name from.
' @return A formatted message containing both the name of the parent subclass and
' the message itself.
' @remarks A general format might look like this:<br>
' VBCorLib.SystemException: An Error has occurred.
' <p>A listing of all inner exceptions will be included in the return value.</p>
'
Public Function ToString(Optional ByVal FormattedMessage As String)
    If Len(mSubclassName) > 0 Then ToString = mSubclassName & ": "
    
    If cString.IsNull(FormattedMessage) Then
        ToString = ToString & Message
    Else
        ToString = ToString & FormattedMessage
    End If
    
    If Not mInnerException Is Nothing Then ToString = ToString & vbCrLf & "---> " & mInnerException.ToString
End Function

''
' Provides a basic implementation of the Equals function of the <b>IObject</b> interface.
'
' @param Value The value to determine if is the same object instance as the Subclass exception.
' @param Subclass The Subclass exception object being compared to.
' @return Returns True if Value IS Subclass, False otherwise.
'
Public Function Equals(ByRef Value As Variant) As Boolean
    If IsObject(Value) Then
        Equals = (Value Is Subclass)
    End If
End Function

''
' Provides a basic implementation of the GetHashcode function of the <b>IObject</b> interface.
'
' @param Subclass The parent Subclass object to derive the hashcode from.
' @return A 32-bit value used to help identify the Subclass object.
' @remarks The value generated is not unique across all hashcodes. Additional
' measures must be taken to find a unique value that happens to have the same
' hashcode as the Subclass object.
'
Public Function GetHashCode() As Long
    GetHashCode = ObjPtr(Subclass)
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Friend Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Friend Sub Init(ByVal Subclass As Object, ByVal AppTitle As String, ByVal Message As String, ByVal InnerException As Exception, ByVal HResult As Long, ByVal Source As String, ByVal HelpLink As String)
    Call SetClassName(AppTitle, TypeName(Subclass))
    mSubclass = ObjPtr(CUnk(Subclass))
    mMessage = Message
    Set mInnerException = InnerException
    mHResult = HResult
    mSource = Source
    mHelpLink = HelpLink
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub LoadDefaults()
    mHResult = DEF_HRESULT
End Sub

''
' This will attempt to build a string containing the application title
' and class name in a {AppTitle}.{Subclass} format.
'
' @param AppTitle The name of the component that contains the Subclass class.
' @param Subclass The exception class.
' @return A formatted string containing the applicationg title and class name.
' @remarks Possible formatted values are:
'
' {AppTitle}.{Subclass} - When AppTitle and Subclass are valid.
' {Subclass}            - When AppTitle is empty and Subclass is valid.
' {AppTitle}            - When Subclass is Nothing and AppTitle is valid.
' {Unknown}             - When AppTitle and Subclass are invalid.
'
Private Sub SetClassName(ByVal AppTitle As String, ByVal SubclassName As String)
    mSubclassName = AppTitle
    
    If Len(mSubclassName) > 0 Then
        mSubclassName = mSubclassName & "." & SubclassName
    Else
        mSubclassName = SubclassName
    End If
    
    If Len(mSubclassName) = 0 Then mSubclassName = "Unknown"
End Sub

''
' The mValues variable is only initialized upon first usage.
' We don't need to create a new Hashtable for exceptions that
' don't even store values.
'
' @return An initalized Hashtable used to store values.
'
Private Property Get values() As Hashtable
    If mValues Is Nothing Then Set mValues = New Hashtable
    Set values = mValues
End Property


Private Property Get Subclass() As Object
    Dim Unk As IUnknown
    ObjectPtr(Unk) = mSubclass
    Set Subclass = Unk
    ObjectPtr(Unk) = 0
End Property


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_InitProperties()
    Call LoadDefaults
End Sub

Private Sub Class_ReadProperties(PropBag As PropertyBag)
    With PropBag
        ' The PropertyBag does not persist vbNullString. It is converted to an empty string "".
        If Not CBool(.ReadProperty(PROP_ISNULLMESSAGE)) Then
            mMessage = .ReadProperty(PROP_MESSAGE)
        End If
        
        mHResult = .ReadProperty(PROP_HRESULT)
        mSource = .ReadProperty(PROP_SOURCE)
        mHelpLink = .ReadProperty(PROP_HELPLINK)
        Set mInnerException = .ReadProperty(PROP_INNEREXCEPTION, Nothing)   ' A default is actually required when an object might be Nothing.
        Set mValues = .ReadProperty(PROP_VALUES, Nothing)
        Set mData = .ReadProperty(PROP_DATA, Nothing)
    End With
End Sub

Private Sub Class_WriteProperties(PropBag As PropertyBag)
    With PropBag
        Call .WriteProperty(PROP_MESSAGE, mMessage)
        Call .WriteProperty(PROP_ISNULLMESSAGE, cString.IsNull(mMessage))
        Call .WriteProperty(PROP_HRESULT, mHResult)
        Call .WriteProperty(PROP_SOURCE, mSource)
        Call .WriteProperty(PROP_HELPLINK, mHelpLink)
        Call .WriteProperty(PROP_INNEREXCEPTION, mInnerException)
        
        ' Save the Hashtable only if it has been used.
        If Not mValues Is Nothing Then
            Call .WriteProperty(PROP_VALUES, mValues)
        End If
        
        If Not mData Is Nothing Then
            Call .WriteProperty(PROP_DATA, mData)
        End If
    End With
End Sub