datetimeformatinfo.cls

这是一个在vb下实现的各种加密程序,可以实现一般的文本加密和文件加密,但是很多算法都是已经被人破解过的.

    Const TICKS_PER_SECOND As Long = 10000000
    GetSecondsFraction = Ticks - (TICKS_PER_SECOND * Fix(Ticks / TICKS_PER_SECOND))
End Function

Private Sub FormatError()
    Throw Cor.NewFormatException("The string was in the incorrect format.")
End Sub

Private Sub Append1to4CountValue(ByRef sb As StringBuilder, ByVal cnt As Long, ByVal Value As Long, ByRef ThreeCountValue As String, ByRef FourCountValue As String)
    Select Case cnt
        Case 1
            Call sb.Append(Value)
        Case 2
            If Value < 10 Then Call sb.AppendChar(vbZero)
            Call sb.Append(Value)
        Case 3
            Call sb.AppendString(ThreeCountValue)
        Case Else
            Call sb.AppendString(FourCountValue)
    End Select
End Sub

Private Sub Append1or2DigitNumber(ByRef sb As StringBuilder, ByVal cnt As Long, ByVal Value As Long)
    If cnt = 1 Then
        Call sb.Append(Value)
    Else
        If Value < 10 Then Call sb.AppendChar(vbZero)
        Call sb.Append(Value)
    End If
End Sub

''
' Given an index in the mPattern, the counts the number of times
' the character at the specific index repeats starting at that index.
'
' @param Index The starting location in mPatterns to be counting repeate characters.
' @return The number of time the character repeated starting at the index.
'
Private Function GetRepeatCount(ByVal Index As Long) As Long
    Dim i As Long
    Dim Ch As Integer
    
    Ch = mPattern.Data(Index)
    i = Index + 1
    Do While i < mPattern.SA.cElements
        If mPattern.Data(i) <> Ch Then Exit Do
        i = i + 1
    Loop
    GetRepeatCount = i - Index
End Function

Private Function GetPattern(ByVal fmt As String) As String
    If Len(fmt) = 0 Then fmt = "G"
    If Len(fmt) = 1 Then
        Select Case Asc(fmt)
            Case vbLowerD:               GetPattern = mProps.ShortDatePattern
            Case vbUpperD:               GetPattern = mProps.LongDatePattern
            Case vbLowerT:               GetPattern = mProps.ShortTimePattern
            Case vbUpperT:               GetPattern = mProps.LongTimePattern
            Case vbLowerF:               GetPattern = mProps.LongDatePattern & " " & mProps.ShortTimePattern
            Case vbUpperF:               GetPattern = Me.FullDateTimePattern
            Case vbLowerG:               GetPattern = mProps.ShortDatePattern & " " & mProps.ShortTimePattern
            Case vbUpperG:               GetPattern = mProps.ShortDatePattern & " " & mProps.LongTimePattern
            Case vbLowerM, vbUpperM:     GetPattern = mProps.MonthDayPattern
            Case vbLowerR, vbUpperR:     GetPattern = C_RFC1123Pattern
            Case vbLowerS:               GetPattern = C_SORTABLEDATETIMEPATTERN
            Case vbLowerU:               GetPattern = C_UNIVERSALSORTABLEDATETIMEPATTERN
            Case vbUpperU:               GetPattern = Me.FullDateTimePattern
            Case vbLowerY, vbUpperY:     GetPattern = mProps.YearMonthPattern
            Case Else
                Throw Cor.NewFormatException("Invalid format specifier.")
        End Select
    Else
        GetPattern = fmt
    End If
End Function

''
' Returns a list of date and time patterns avaiable.
Private Function CombineAllDateTimePatterns() As String()
    Const FORMATS As String = "dDfFgGmMrRstTUuYy"
    mPattern.SA.pvData = StrPtr(FORMATS)
    
    Dim List As ArrayList
    Set List = New ArrayList
    
    Dim i As Long
    For i = 0 To Len(FORMATS) - 1
        Call List.AddRange(GetSpecificDateTimePattern(mPattern.Data(i)))
    Next i
    
    Dim Ret() As String
    ReDim Ret(List.Count - 1)
    Call List.CopyTo(Ret)
    CombineAllDateTimePatterns = Ret
End Function

''
' Get the Date&Time pattern(s) based on the requested type.
'
' @param Pattern The requested pattern.
' @return An array of all Date&Time patterns of the requested type.
'
Private Function GetSpecificDateTimePattern(ByVal Pattern As Long) As String()
    Dim Ret() As String
    
    ' We'll redim here and take the hit if the client
    ' requests one of the multi-pattern types.
    ' It will be rare that a multi-pattern is requested.
    ReDim Ret(0)
    Select Case Pattern
        Case vbLowerD
            Ret(0) = mProps.ShortDatePattern
        Case vbUpperD
            Ret(0) = mProps.LongDatePattern
        Case vbLowerT
            Ret = mProps.AllShortTimePatterns
        Case vbUpperT
            Ret(0) = mProps.LongTimePattern
        Case vbUpperF, vbUpperU
            Ret(0) = Me.FullDateTimePattern
        Case vbLowerF
            Ret = CreateDateTimePatterns(mProps.AllLongDatePatterns, mProps.AllShortTimePatterns)
        Case vbLowerG
            Ret = CreateDateTimePatterns(mProps.AllShortDatePatterns, mProps.AllShortTimePatterns)
        Case vbUpperG
            Ret = CreateDateTimePatterns(mProps.AllShortDatePatterns, mProps.AllLongTimePatterns)
        Case vbUpperM, vbLowerM
            Ret(0) = mProps.MonthDayPattern
        Case vbUpperR, vbLowerR
            Ret(0) = C_RFC1123Pattern
        Case vbLowerS
            Ret(0) = C_SORTABLEDATETIMEPATTERN
        Case vbLowerU
            Ret(0) = C_UNIVERSALSORTABLEDATETIMEPATTERN
        Case vbLowerY, vbUpperY
            Ret(0) = mProps.YearMonthPattern
        Case Else
            Throw Cor.NewArgumentException("Invalid format specifier.")
    End Select
    GetSpecificDateTimePattern = Ret
End Function

''
' This creates Date&Time patterns by combining all the date patterns
' with all time patterns in all possible combinations.
'
' @param DatePatterns The date patterns to combine with time patterns.
' @param TimePatterns The time patterns to combine with date patterns.
' @return An array of Date&Time pattern combinations.
'
Private Function CreateDateTimePatterns(ByRef DatePatterns() As String, ByRef TimePatterns() As String) As String()
    Dim TimePatternsUpperBound As Long
    TimePatternsUpperBound = UBound(TimePatterns)
    
    Dim DatePatternsUpperBound As Long
    DatePatternsUpperBound = UBound(DatePatterns)
    
    Dim Ret() As String
    ReDim Ret(0 To (DatePatternsUpperBound + 1) * (TimePatternsUpperBound + 1) - 1)
    
    Dim DatePatternIndex As Long
    For DatePatternIndex = 0 To DatePatternsUpperBound
        Dim TimePatternIndex As Long
        For TimePatternIndex = 0 To TimePatternsUpperBound
            Dim i As Long
            Ret(i) = DatePatterns(DatePatternIndex) & " " & TimePatterns(TimePatternIndex)
            i = i + 1
        Next TimePatternIndex
    Next DatePatternIndex
    CreateDateTimePatterns = Ret
End Function

Private Sub VerifyWritable()
    If mProps.IsReadOnly Then Throw Cor.NewInvalidOperationException(Environment.GetResourceString(InvalidOperation_ReadOnly))
End Sub

Private Sub ReadStringArray(ByRef a() As String, ByVal Name As String, ByVal bag As PropertyBag)
    With bag
        Dim Count As Long
        Count = .ReadProperty(Name & "_Count", 0)
        a = cArray.CreateInstance(ciString, Count)
        
        Dim i As Long
        For i = 0 To Count - 1
            a(i) = .ReadProperty(Name & "_" & i)
        Next i
    End With
End Sub

Private Sub WriteStringArray(ByRef a() As String, ByVal Name As String, ByVal bag As PropertyBag)
    With bag
        Call .WriteProperty(Name & "_Count", UBound(a) + 1)
        Dim i As Long
        For i = 0 To UBound(a)
            Call .WriteProperty(Name & "_" & i, a(i))
        Next i
    End With
End Sub

Private Sub VerifyLoaded()
    If mLoaded Then Exit Sub
    Call Load(INVARIANT_LCID, False)
End Sub

Private Sub AssignDayNames(ByRef Source() As String, ByRef DayNames() As String)
    Call VerifyWritable
    Call VerifyLoaded

    If cArray.GetRank(Source) <> 1 Then _
        Throw Cor.NewRankException(Environment.GetResourceString(Rank_MultiDimension))
    If cArray.GetLength(Source) <> 7 Then _
        Throw Cor.NewArgumentException("Array must contain exactly 7 elements.")
    
    ReDim DayNames(0 To 6)
    Call cArray.CopyEx(Source, LBound(Source), DayNames, 0, 7)
End Sub

Private Sub AssignMonthNames(ByRef Source() As String, ByRef MonthNames() As String)
    Call VerifyWritable
    Call VerifyLoaded
    If cArray.GetRank(Source) <> 1 Then _
        Throw Cor.NewRankException(Environment.GetResourceString(Rank_MultiDimension))
    If cArray.GetLength(Source) <> 13 Then _
        Throw Cor.NewArgumentException("Array must contain exactly 13 elements.")
        
    ReDim MonthNames(0 To 12)
    Call cArray.CopyEx(Source, LBound(Source), MonthNames, 0, 13)
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    Call InitWordBuffer(mPattern, 0, &H7FFFFFFF)
End Sub

Private Sub Class_ReadProperties(PropBag As PropertyBag)
    With mProps
        Set .Calendar = PropBag.ReadProperty(PROP_CALENDAR, Nothing)
        .CalendarWeekRule = PropBag.ReadProperty(PROP_CALENDARWEEKRULE)
        .AMDesignator = PropBag.ReadProperty(PROP_AMDESIGNATOR)
        .DateSeparator = PropBag.ReadProperty(PROP_DATESEPARATOR)
        .FirstDayOfWeek = PropBag.ReadProperty(PROP_FIRSTDAYOFWEEK)
        .FullDateTimePattern = PropBag.ReadProperty(PROP_FULLDATETIMEPATTERN)
        .LongDatePattern = PropBag.ReadProperty(PROP_LONGDATEPATTERN)
        .LongTimePattern = PropBag.ReadProperty(PROP_LONGTIMEPATTERN)
        .MonthDayPattern = PropBag.ReadProperty(PROP_MONTHDAYPATTERN)
        .PMDesignator = PropBag.ReadProperty(PROP_PMDESIGNATOR)
        .ShortDatePattern = PropBag.ReadProperty(PROP_SHORTDATEPATTERN)
        .ShortTimePattern = PropBag.ReadProperty(PROP_SHORTTIMEPATTERN)
        .TimeSeparator = PropBag.ReadProperty(PROP_TIMESEPARATOR)
        .YearMonthPattern = PropBag.ReadProperty(PROP_YEARMONTHPATTERN)
        .IsReadOnly = PropBag.ReadProperty(PROP_ISREADONLY)
        Call ReadStringArray(.AbbreviatedDayNames, PROP_ABBREVIATEDDAYNAMES, PropBag)
        Call ReadStringArray(.AbbreviatedMonthNames, PROP_ABBREVIATEDMONTHNAMES, PropBag)
        Call ReadStringArray(.MonthNames, PROP_MONTHNAMES, PropBag)
        Call ReadStringArray(.DayNames, PROP_DAYNAMES, PropBag)
    End With
    mLoaded = True
End Sub

Private Sub Class_WriteProperties(PropBag As PropertyBag)
    With mProps
        Call PropBag.WriteProperty(PROP_CALENDAR, .Calendar)
        Call PropBag.WriteProperty(PROP_CALENDARWEEKRULE, .CalendarWeekRule)
        Call WriteStringArray(.AbbreviatedDayNames, PROP_ABBREVIATEDDAYNAMES, PropBag)
        Call WriteStringArray(.AbbreviatedMonthNames, PROP_ABBREVIATEDMONTHNAMES, PropBag)
        Call PropBag.WriteProperty(PROP_AMDESIGNATOR, .AMDesignator)
        Call PropBag.WriteProperty(PROP_DATESEPARATOR, .DateSeparator)
        Call WriteStringArray(.DayNames, PROP_DAYNAMES, PropBag)
        Call PropBag.WriteProperty(PROP_FIRSTDAYOFWEEK, .FirstDayOfWeek)
        Call PropBag.WriteProperty(PROP_FULLDATETIMEPATTERN, .FullDateTimePattern)
        Call PropBag.WriteProperty(PROP_LONGDATEPATTERN, .LongDatePattern)
        Call PropBag.WriteProperty(PROP_LONGTIMEPATTERN, .LongTimePattern)
        Call PropBag.WriteProperty(PROP_MONTHDAYPATTERN, .MonthDayPattern)
        Call WriteStringArray(.MonthNames, PROP_MONTHNAMES, PropBag)
        Call PropBag.WriteProperty(PROP_PMDESIGNATOR, .PMDesignator)
        Call PropBag.WriteProperty(PROP_SHORTDATEPATTERN, .ShortDatePattern)
        Call PropBag.WriteProperty(PROP_SHORTTIMEPATTERN, .ShortTimePattern)
        Call PropBag.WriteProperty(PROP_TIMESEPARATOR, .TimeSeparator)
        Call PropBag.WriteProperty(PROP_YEARMONTHPATTERN, .YearMonthPattern)
        Call PropBag.WriteProperty(PROP_ISREADONLY, .IsReadOnly)
    End With
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IObject Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function IObject_Equals(Value As Variant) As Boolean
    IObject_Equals = Equals(Value)
End Function

Private Function IObject_GetHashcode() As Long
    IObject_GetHashcode = GetHashCode
End Function

Private Function IObject_ToString() As String
    IObject_ToString = ToString
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   ICloneable Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function ICloneable_Clone() As Object
    Set ICloneable_Clone = Clone
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IFormatProvider Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function IFormatProvider_GetFormat(ByVal FormatType As String) As Object
    Set IFormatProvider_GetFormat = GetFormat(FormatType)
End Function