carray.cls

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

Private Sub CopyWithCast(ByVal srcpSA As Long, ByVal SourceIndex As Long, ByVal dstpSA As Long, ByVal DestinationIndex As Long, ByVal Length As Long, ByVal pfn As Long)
    Dim srcSize As Long
    srcSize = SafeArrayGetElemsize(srcpSA)
    
    Dim srcLb   As Long
    srcLb = SafeArrayGetLBound(srcpSA, 1)
    
    Dim src     As Long
    src = MemLong(srcpSA + PVDATA_OFFSET) + (SourceIndex - srcLb) * srcSize
    
    Dim dstSize As Long
    dstSize = SafeArrayGetElemsize(dstpSA)
    
    Dim dstLb   As Long
    dstLb = SafeArrayGetLBound(dstpSA, 1)
    
    Dim dst     As Long
    dst = MemLong(dstpSA + PVDATA_OFFSET) + (DestinationIndex - dstLb) * dstSize
    
    mAssignDelegator.pfn = pfn
    
    Do While Length > 0
        Call mAssigner.Call(dst, src)
        src = src + srcSize
        dst = dst + dstSize
        Length = Length - 1
    Loop
End Sub

' Copies objects and checks for compatible interfaces during the copy.
'
Private Sub CopyObjectTypesCast(ByVal srcpSA As Long, ByVal SourceIndex As Long, ByVal dstpSA As Long, ByVal DestinationIndex As Long, ByVal Length As Long)
    Dim srcLowerBound As Long
    srcLowerBound = SafeArrayGetLBound(srcpSA, 1)
    
    Dim dstLowerBound As Long
    dstLowerBound = SafeArrayGetLBound(dstpSA, 1)
    
    Dim pSrcElem As Long
    pSrcElem = MemLong(srcpSA + PVDATA_OFFSET) + (SourceIndex - srcLowerBound) * 4
    
    Dim pDstElem As Long
    pDstElem = MemLong(dstpSA + PVDATA_OFFSET) + (DestinationIndex - dstLowerBound) * 4
    
    Dim pDstGuid As Long
    pDstGuid = dstpSA - SIZEOF_GUID
    
    Dim pObj    As Long
    Dim srcObj  As IVBUnknown
    Dim dstObj  As IVBUnknown
    Do While Length > 0
        ObjectPtr(srcObj) = MemLong(pSrcElem)
        pObj = 0
        If Not srcObj Is Nothing Then
            If srcObj.QueryInterface(ByVal pDstGuid, pObj) = E_NOINTERFACE Then
                ObjectPtr(srcObj) = 0
                ObjectPtr(dstObj) = 0
                Throw Cor.NewArrayTypeMismatchException(Environment.GetResourceString(ArrayTypeMismatch_Incompatible))
            End If
        End If
        
        ObjectPtr(dstObj) = MemLong(pDstElem)
        If Not dstObj Is Nothing Then Call dstObj.Release
        MemLong(pDstElem) = pObj
        
        pSrcElem = pSrcElem + 4
        pDstElem = pDstElem + 4
        Length = Length - 1
    Loop
    
    ObjectPtr(srcObj) = 0
    ObjectPtr(dstObj) = 0
End Sub

' Returns the address to a function that can assign one
' datatype to another datatype. If the datatypes are not
' compatible then 0 is returned.
'
Private Function GetAssigningFunction(ByVal srcType As VbVarType, ByVal dstType As VbVarType) As Long
    Dim Ret As Long
    Select Case srcType
        Case vbLong
            Select Case dstType
                Case vbDouble:      Ret = FuncAddr(AddressOf WidenLongToDouble)
                Case vbString:      Ret = FuncAddr(AddressOf WidenLongToString)
                Case vbCurrency:    Ret = FuncAddr(AddressOf WidenLongToCurrency)
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenLongToVariant)
            End Select
        Case vbInteger, vbBoolean
            Select Case dstType
                Case vbLong:        Ret = FuncAddr(AddressOf WidenIntegerToLong)
                Case vbDouble:      Ret = FuncAddr(AddressOf WidenIntegerToDouble)
                Case vbString:      Ret = FuncAddr(AddressOf WidenIntegerToString)
                Case vbSingle:      Ret = FuncAddr(AddressOf WidenIntegerToSingle)
                Case vbCurrency:    Ret = FuncAddr(AddressOf WidenIntegerToCurrency)
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenIntegerToVariant)
            End Select
        Case vbByte
            Select Case dstType
                Case vbLong:        Ret = FuncAddr(AddressOf WidenByteToLong)
                Case vbInteger:     Ret = FuncAddr(AddressOf WidenByteToInteger)
                Case vbDouble:      Ret = FuncAddr(AddressOf WidenByteToDouble)
                Case vbString:      Ret = FuncAddr(AddressOf WidenByteToString)
                Case vbSingle:      Ret = FuncAddr(AddressOf WidenByteToSingle)
                Case vbCurrency:    Ret = FuncAddr(AddressOf WidenByteToCurrency)
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenByteToVariant)
            End Select
        Case vbSingle
            Select Case dstType
                Case vbDouble:      Ret = FuncAddr(AddressOf WidenSingleToDouble)
                Case vbString:      Ret = FuncAddr(AddressOf WidenSingleToString)
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenSingleToVariant)
            End Select
        Case vbDate
            Select Case dstType
                Case vbDouble:      Ret = FuncAddr(AddressOf WidenDateToDouble)
                Case vbString:      Ret = FuncAddr(AddressOf WidenDateToString)
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenDateToVariant)
            End Select
        Case vbObject, vbDataObject
            Select Case dstType
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenObjectToVariant)
            End Select
        Case vbCurrency
            Select Case dstType
                Case vbString:      Ret = FuncAddr(AddressOf WidenCurrencyToString)
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenCurrencyToVariant)
            End Select
        Case vbString
            Select Case dstType
                Case vbVariant:     Ret = FuncAddr(AddressOf WidenStringToVariant)
            End Select
        Case vbVariant
            Select Case dstType
                Case vbLong:                    Ret = FuncAddr(AddressOf NarrowVariantToLong)
                Case vbInteger:                 Ret = FuncAddr(AddressOf NarrowVariantToInteger)
                Case vbString:                  Ret = FuncAddr(AddressOf NarrowVariantToString)
                Case vbDouble:                  Ret = FuncAddr(AddressOf NarrowVariantToDouble)
                Case vbObject, vbDataObject:    Ret = FuncAddr(AddressOf NarrowVariantToObject)
                Case vbSingle:                  Ret = FuncAddr(AddressOf NarrowVariantToSingle)
                Case vbByte:                    Ret = FuncAddr(AddressOf NarrowVariantToByte)
                Case vbDate:                    Ret = FuncAddr(AddressOf NarrowVariantToDate)
                Case vbBoolean:                 Ret = FuncAddr(AddressOf NarrowVariantToBoolean)
                Case vbCurrency:                Ret = FuncAddr(AddressOf NarrowVariantToCurrency)
            End Select
    End Select
    GetAssigningFunction = Ret
End Function

''
' Perform the sorting. If no comparer is supplied, then optimized sorting routines
' will be attempted, otherwise, the general routine will be used with the comparer.
Private Sub InternalSort(ByRef Keys As Variant, ByRef Items As Variant, Optional ByRef Index As Variant, Optional ByRef Count As Variant, Optional ByRef Comparer As Variant)
    Dim pKeysSafeArray  As Long
    Dim pItemsSafeArray As Long
    Dim ElemIndex       As Long
    Dim ElemCount       As Long
    
    pKeysSafeArray = GetArrayPointer(Keys)
    
    Dim Result As Long
    Result = GetOptionalArrayRange(pKeysSafeArray, Index, ElemIndex, Count, ElemCount)
    If Result <> NO_ERROR Then Call ThrowArrayRangeException(Result, "Keys", ElemIndex, "Index", ElemCount, "Count", IsMissing(Index))
    
    ' set up items to be sorted with keys
    If IsArray(Items) Then
        pItemsSafeArray = GetArrayPointer(Items)
        If pItemsSafeArray = 0 Then _
            Throw Cor.NewArgumentNullException(Environment.GetResourceString(ArgumentNull_Array), "Items")
        
        ' Items array must match the Keys array in size and bounds.
        If (LBound(Keys) <> LBound(Items)) Or _
           (UBound(Keys) <> UBound(Items)) Then _
            Throw Cor.NewArgumentException(Environment.GetResourceString(Argument_MatchingBounds))
        
        Call SetSortItems(pItemsSafeArray)
    End If
    
    On Error GoTo errTrap
    Call ClearException
    Do
        Select Case VarType(Comparer)
            ' use an IComparer object to sort with.
            Case vbObject
                Call SetSortKeys(pKeysSafeArray)
                
                If Comparer Is Nothing Then
                    Set SortComparer = VBCorLib.Comparer.Default
                Else
                    Set SortComparer = Comparer
                End If
                
                Call QuickSortGeneral(Keys, ElemIndex, ElemIndex + ElemCount - 1)
                Exit Do
                
            ' Use a callback method to sort with.
            ' This allows a user to supply a highspeed comarison
            ' routine to compare two elements of the array.
            Case vbLong
                Call CallbackSorter.Sort(pKeysSafeArray, pItemsSafeArray, ElemIndex, ElemIndex + ElemCount - 1, Comparer)
                Exit Do
                
            ' try optimized routines first, then fallback to the default IComparer object.
            Case vbError
                If TrySZSort(pKeysSafeArray, ElemIndex, ElemIndex + ElemCount - 1) Then Exit Do
                
                ' If we get here, then no optimized routine existed,
                ' so we'll set our comparer to the default and loop
                ' around again, letting this case statement fall
                ' into the QuickSortGeneral routine.
                Set Comparer = VBCorLib.Comparer.Default
            
            Case Else
                Throw Cor.NewArgumentException("Invalid Comparer.", "Comparer")
        End Select
    Loop
    
errTrap:
    Call ClearSortKeys
    Call ClearSortItems
    Set SortComparer = Nothing
    
    Dim Ex As Exception
    If Catch(Ex) Then Throw Ex
End Sub

Private Sub SetCopyArrayDescriptor(ByRef desc As SafeArray1d, ByVal Index As Long, ByVal Length As Long)
    With desc
        .pvData = .pvData + (Index - .lLbound) * .cbElements
        .cElements = Length
    End With
End Sub

''
' This is an optimized search routine that uses a function pointer
' to call a specific comparison routine.
Private Function SZBinarySearch(ByVal pSA As Long, ByVal pValue As Long, ByVal Index As Long, ByVal Count As Long, ByVal pfn As Long) As Long
    mBinarySearchDelegator.pfn = pfn
    
    Dim ElemSize As Long
    ElemSize = SafeArrayGetElemsize(pSA)
    
    Dim pvData As Long
    pvData = MemLong(pSA + PVDATA_OFFSET)
    
    Dim pLowElem As Long
    pLowElem = Index - SafeArrayGetLBound(pSA, 1)
    
    Dim pHighElem As Long
    pHighElem = pLowElem + Count - 1
    
    Dim pMiddleElem As Long
    Do While pLowElem <= pHighElem
        pMiddleElem = (pLowElem + pHighElem) \ 2
        Select Case mBinarySearchComparer.Call(pvData + pMiddleElem * ElemSize, pValue)
            Case 0
                SZBinarySearch = pMiddleElem + SafeArrayGetLBound(pSA, 1)
                Exit Function
            Case Is > 0
                pHighElem = pMiddleElem - 1
            Case Else
                pLowElem = pMiddleElem + 1
        End Select
    Loop
    
    SZBinarySearch = (Not pLowElem) + SafeArrayGetLBound(pSA, 1)
End Function

Private Function SZIndexOf(ByVal pSA As Long, ByVal pValue As Long, ByVal Index As Long, ByVal Count As Long, ByVal pfn As Long) As Long
    mIndexOfDelegator.pfn = pfn
    
    Dim ElemSize As Long
    ElemSize = SafeArrayGetElemsize(pSA)
    
    Dim pvData As Long
    pvData = MemLong(pSA + PVDATA_OFFSET)
    
    Index = Index - SafeArrayGetLBound(pSA, 1)
    Do While Count > 0
        If mIndexOfComparer.Call(pvData + Index * ElemSize, pValue) Then
            SZIndexOf = Index + SafeArrayGetLBound(pSA, 1)
            Exit Function
        End If
        Count = Count - 1
        Index = Index + 1
    Loop

    SZIndexOf = SafeArrayGetLBound(pSA, 1) - 1
End Function

Private Function SZLastIndexOf(ByVal pSA As Long, ByVal pValue As Long, ByVal Index As Long, ByVal Count As Long, ByVal pfn As Long) As Long
    mIndexOfDelegator.pfn = pfn
    
    Dim ElemSize As Long
    ElemSize = SafeArrayGetElemsize(pSA)
    
    Dim pvData As Long
    pvData = MemLong(pSA + PVDATA_OFFSET)
    
    Index = Index - SafeArrayGetLBound(pSA, 1)
    Do While Count > 0
        If mIndexOfComparer.Call(pvData + Index * ElemSize, pValue) Then
            SZLa