carray.cls

VB 加密----------能够加密解密控件

'
' @param Keys The array to sort.
' @param Index The starting index in the array to start sorting.
' @param Count The number of elements to be sorted.
' @param Comparer (Optional) An IComparer object or address of a comparer callback function.
' @remarks The Comparer parameter can be an <b>IComparer</b> object or a
' callback address to a compare function using the <b>AddressOf</b> method. The
' callback method signature is defined as follows:
' <pre>
' Public Function SortCallback(ByRef x As [Array Datatype], ByRef y As [Array Datatype]) As Long
'     '' return a negative value if x is less than y.
'     '' return a positive value if x is greater than y.
'     '' return 0 if x equals y.
' End Function
' </pre>
' The [Array Datatype] must be replaced with the datatype of the array. If the
' array is an array of Variants, then [Array Datatype] would be a Variant, not
' any specific sub-type within the variants of the array.</p>
'
Public Sub SortEx(ByRef Keys As Variant, ByVal Index As Long, ByVal Count As Long, Optional ByVal Comparer As Variant)
    Call InternalSort(Keys, Empty, Index, Count, Comparer)
End Sub

''
' Sorts an entire array based on an array of keys. An optionally supplied
' comparer object can be used to compare special elements, such as userdefined values.
'
' @param keys An array the sorting is based on.
' @param items An array that is sorted based on the sorting of keys.
' @param Comparer (Optional) An IComparer object or address of a comparer callback function.
' @remarks The Comparer parameter can be an <b>IComparer</b> object or a
' callback address to a compare function using the <b>AddressOf</b> method. The
' callback method signature is defined as follows:
' <pre>
' Public Function SortCallback(ByRef x As [Array Datatype], ByRef y As [Array Datatype]) As Long
'     '' return a negative value if x is less than y.
'     '' return a positive value if x is greater than y.
'     '' return 0 if x equals y.
' End Function
' </pre>
' The [Array Datatype] must be replaced with the datatype of the array. If the
' array is an array of Variants, then [Array Datatype] would be a Variant, not
' any specific sub-type within the variants of the array.</p>
'
' @include "..\Includes\cArray.SortKey.txt"
Public Sub SortKey(ByRef Keys As Variant, ByRef Items As Variant, Optional ByVal Comparer As Variant)
    Call InternalSort(Keys, Items, , , Comparer)
End Sub

''
' Sorts an array based on an array of keys. A subportion of the array can
' be sorted given a startindex and length. An optionally, supplied comparer
' object can be used to compare special elements, such as userdefined values.
'
' @param keys An array the sorting is based on.
' @param items An array that is sorted based on the sorting of keys.
' @param Index The starting index in the array to start sorting.
' @param Count The number of elements to be sorted.
' @param Comparer (Optional) An IComparer object or address of a comparer callback function.
' @remarks The Comparer parameter can be an <b>IComparer</b> object or a
' callback address to a compare function using the <b>AddressOf</b> method. The
' callback method signature is defined as follows:
' <pre>
' Public Function SortCallback(ByRef x As [Array Datatype], ByRef y As [Array Datatype]) As Long
'     '' return a negative value if x is less than y.
'     '' return a positive value if x is greater than y.
'     '' return 0 if x equals y.
' End Function
' </pre>
' The [Array Datatype] must be replaced with the datatype of the array. If the
' array is an array of Variants, then [Array Datatype] would be a Variant, not
' any specific sub-type within the variants of the array.</p>
'
Public Sub SortKeyEx(ByRef Keys As Variant, ByRef Items As Variant, ByVal Index As Long, ByVal Count As Long, Optional ByVal Comparer As Variant)
    Call InternalSort(Keys, Items, Index, Count, Comparer)
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Friend Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' This is Friend to allow access from the Constructors.NewArray function.
'
Friend Function InternalNewArray(ByVal ArrayType As ciArrayTypes, ByRef args() As Variant) As Variant
    Dim UpperBound  As Long
    UpperBound = UBound(args)
    
    Dim Ret As Variant
    Ret = CreateInstance(ArrayType, UpperBound + 1)
    
    If UpperBound >= 0 Then
        Call CopyEx(args, 0, Ret, 0, UpperBound + 1)
    End If
    
    InternalNewArray = Ret
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    Set mBinarySearchComparer = InitDelegator(mBinarySearchDelegator)
    Set mIndexOfComparer = InitDelegator(mIndexOfDelegator)
    Set mAssigner = InitDelegator(mAssignDelegator)
    Set mSorter = InitDelegator(mSortDelegator)
    Set mFinder = InitDelegator(mFindDelegator)
    Set mForEach = InitDelegator(mForEachDelegator)
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''
' This function assigns the default value of the specific
' datatype for the array. If the array is a vbLong, then
' a 0 of type long is assiged. This is to ensure that the
' Variant return value contains the same datatype as the array.
'
Private Sub AssignDefaultElementValue(ByRef Arr As Variant, ByRef RetVal As Variant)
    ' we use the VB conversion functions to have easier
    ' readability as to what we are assigning.
    Select Case VarType(Arr) And &HFF
        Case vbLong:        RetVal = CLng(0)
        Case vbInteger:     RetVal = CInt(0)
        Case vbByte:        RetVal = CByte(0)
        Case vbString:      RetVal = vbNullString
        Case vbObject:      Set RetVal = Nothing
        Case vbDouble:      RetVal = CDbl(0)
        Case vbSingle:      RetVal = CSng(0)
        Case vbDate:        RetVal = CDate(#12:00:00 AM#)
        Case vbCurrency:    RetVal = CCur(0)
        Case vbBoolean:     RetVal = False
        Case vbVariant:     RetVal = Empty
        Case vbUserDefinedType
            Dim rec As IRecordInfo
            Set rec = SafeArrayGetRecordInfo(GetArrayPointer(Arr))
            
            ' Set the datatype for the variant.
            VariantType(RetVal) = vbUserDefinedType
            ' Set the pointer to the new structure created.
            ' This structure is of the same type as contained in the array.
            MemLong(VarPtr(RetVal) + VARIANTDATA_OFFSET) = rec.RecordCreate
            ' Set the pointer to the IRecordInfo object so VB can
            ' inspect this variant and handle it properly.
            MemLong(VarPtr(RetVal) + VARIANTDATA_OFFSET + 4) = ObjectPtr(rec)
            ' Kill our reference to the IRecordInfo without decrementing
            ' the reference count, since we assigned it without adding a reference.
            ObjectPtr(rec) = 0
    End Select
End Sub

''
' This is the primary copy function. It determines the type of arrays
' being used as source and destination and calls the appropriate copy method
' for any possible casting between arrays.
'
Private Sub InternalCopy(ByRef SourceArray As Variant, ByRef DestinationArray As Variant, ByVal Count As Long, ByVal AddressOfCopier As Long, Optional ByRef SourceIndex As Variant, Optional ByRef DestinationIndex As Variant)
    Dim pSourceSafeArray As Long
    pSourceSafeArray = GetArrayPointer(SourceArray, True)
    
    Dim pDestinationSafeArray As Long
    pDestinationSafeArray = GetArrayPointer(DestinationArray, True)
    
    Dim SourceElemIndex         As Long
    Dim DestinationElemIndex    As Long
    If GetOptionalLongPair(SourceIndex, LBound(SourceArray), SourceElemIndex, DestinationIndex, LBound(DestinationArray), DestinationElemIndex) = Argument_ParamRequired Then _
        Throw Cor.NewArgumentException(Environment.GetResourceString(Argument_ParamRequired), IIf(IsMissing(SourceIndex), "SourceIndex", "DestinationIndex"))
    
    Dim Result As Long
    ' verify the range of the source array.
    Result = VerifyArrayRange(pSourceSafeArray, SourceElemIndex, Count)
    If Result <> NO_ERROR Then ThrowArrayRangeException Result, "SourceArray", SourceElemIndex, "SourceIndex", Count, "Count", IsMissing(SourceIndex)
    
    ' verify the range of the destination array.
    Result = VerifyArrayRange(pDestinationSafeArray, DestinationElemIndex, Count)
    If Result <> NO_ERROR Then ThrowArrayRangeException Result, "DestinationArray", DestinationElemIndex, "DestinationIndex", Count, "Count", IsMissing(DestinationIndex)
    
    Dim srcArrayType As VbVarType
    srcArrayType = VarType(SourceArray) And &HFF    ' knock off the vbArray bit.
    
    Dim dstArrayType As VbVarType
    dstArrayType = VarType(DestinationArray) And &HFF   ' knock off the vbArray bit.
    
    If AddressOfCopier = 0 Then
        If srcArrayType = dstArrayType Then
            Select Case srcArrayType
                Case vbObject, vbDataObject
                    If IsEqualGUID(ByVal pSourceSafeArray - SIZEOF_GUID, ByVal pDestinationSafeArray - SIZEOF_GUID) <> BOOL_FALSE Then
                        Call CopyReferenceTypes(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count)
                    Else
                        Call CopyObjectTypesCast(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count)
                    End If
                    
                Case vbString, vbVariant
                    Call CopyReferenceTypes(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count)
                    
                Case vbUserDefinedType
                    Dim SrcUDT As IRecordInfo
                    Dim DstUDT As IRecordInfo
                    
                    Set SrcUDT = SafeArrayGetRecordInfo(pSourceSafeArray)
                    Set DstUDT = SafeArrayGetRecordInfo(pDestinationSafeArray)
                    
                    If SrcUDT.IsMatchingType(DstUDT) Then
                        Call CopyReferenceTypes(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count)
                    Else
                        Throw Cor.NewArrayTypeMismatchException(Environment.GetResourceString(ArrayTypeMismatch_Incompatible))
                    End If
                    
                Case Else
                    Call CopyValueTypes(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count)
            End Select
        Else
            ' Attempt to copy by casting from one datatype to another.
            Dim pfn As Long
            pfn = GetAssigningFunction(srcArrayType, dstArrayType)
            If pfn = 0 Then _
                Throw Cor.NewArrayTypeMismatchException(Environment.GetResourceString(ArrayTypeMismatch_Incompatible))
            
            Call CopyWithCast(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count, pfn)
        End If
    Else
        ' Use the user callback method as the casting function.
        Call CopyWithCast(pSourceSafeArray, SourceElemIndex, pDestinationSafeArray, DestinationElemIndex, Count, AddressOfCopier)
    End If
End Sub

' Value types can be copied quickly using CopyMemory.
'
Private Sub CopyValueTypes(ByVal srcpSA As Long, ByVal SourceIndex As Long, ByVal dstpSA As Long, ByVal DestinationIndex As Long, ByVal Length As Long)
    Dim ElemSize As Long
    ElemSize = SafeArrayGetElemsize(srcpSA)
    
    Dim pSrcElem As Long
    pSrcElem = MemLong(srcpSA + PVDATA_OFFSET) + (SourceIndex - SafeArrayGetLBound(srcpSA, 1)) * ElemSize
    
    Dim pDstElem As Long
    pDstElem = MemLong(dstpSA + PVDATA_OFFSET) + (DestinationIndex - SafeArrayGetLBound(dstpSA, 1)) * ElemSize
    
    Call CopyMemory(ByVal pDstElem, ByVal pSrcElem, Length * ElemSize)
End Sub

' Copies reference types, dealing with possible overlapping source and destination regions.
'
Private Sub CopyReferenceTypes(ByVal srcpSA As Long, ByVal SourceIndex As Long, ByVal dstpSA As Long, ByVal DestinationIndex As Long, ByVal Length As Long)
    Dim srcSA       As GuidSafeArray1d
    Dim dstSA       As GuidSafeArray1d
    Dim IIDOffset   As Long
    
    Select Case SafeArrayGetVartype(srcpSA)
        Case vbObject:              IIDOffset = SIZEOF_GUID
        Case vbUserDefinedType:     IIDOffset = 4
    End Select
    
    Call CopyMemory(ByVal VarPtr(srcSA.SA) - IIDOffset, ByVal srcpSA - IIDOffset, LenB(srcSA.SA) + IIDOffset)
    Call CopyMemory(ByVal VarPtr(dstSA.SA) - IIDOffset, ByVal dstpSA - IIDOffset, LenB(dstSA.SA) + IIDOffset)
    
    If srcpSA = dstpSA Then
        ' test for overlapping source and destination portion of the same array
        If (DestinationIndex > SourceIndex) And (DestinationIndex < SourceIndex + Length) Then
            Dim ClearSA As GuidSafeArray1d
            ClearSA = srcSA
            With ClearSA.SA
                .pvData = .pvData + (SourceIndex + Length) * .cbElements
                .cElements = DestinationIndex - SourceIndex
            End With
            Call SafeArrayDestroyData(VarPtr(ClearSA.SA))
            
'            Dim ElemSize    As Long
'            Dim pvData      As Long
'            Dim lb          As Long
            With srcSA.SA
'                ElemSize = .cbElements
'                pvData = .pvData
'                lb = .lLbound

                Call CopyMemory(ByVal .pvData + (DestinationIndex - .lLbound) * .cbElements, ByVal .pvData + (SourceIndex - .lLbound) * .cbElements, Length * .cbElements)
    
                ' If we have moved reference type values, then we need to
                ' fill in the uncovered portion of the original values
                ' with copies. First we have to zero out the uncovered portion
                ' so the copy won't release any references, since we merely
                ' moved the references without making copies to objects or strings.
                ' Once the uncovered portion is set up, we can copy backwards using
                ' the standard reference copy method without stepping on ourselves.
                Call ZeroMemory(ByVal .pvData + (SourceIndex - .lLbound) * .cbElements, (DestinationIndex - SourceIndex) * .cbElements)
            End With
            
            Length = DestinationIndex - SourceIndex
            Dim t As Long
            t = SourceIndex
            SourceIndex = DestinationIndex
            DestinationIndex = t
        End If
    End If
    
    Call SetCopyArrayDescriptor(srcSA.SA, SourceIndex, Length)
    Call SetCopyArrayDescriptor(dstSA.SA, DestinationIndex, Length)
    
    Call SafeArrayCopyData(VarPtr(srcSA.SA), VarPtr(dstSA.SA))
End Sub