carray.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cArray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'    CopyRight (c) 2004 Kelly Ethridge
'
'    This file is part of VBCorLib.
'
'    VBCorLib is free software; you can redistribute it and/or modify
'    it under the terms of the GNU Library General Public License as published by
'    the Free Software Foundation; either version 2.1 of the License, or
'    (at your option) any later version.
'
'    VBCorLib is distributed in the hope that it will be useful,
'    but WITHOUT ANY WARRANTY; without even the implied warranty of
'    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'    GNU Library General Public License for more details.
'
'    You should have received a copy of the GNU Library General Public License
'    along with Foobar; if not, write to the Free Software
'    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
'
'    Module: cArray
'

''
' Provides methods for manipulating, searching and sorting arrays.
'
' @remarks This class cannot be directly instantiated. To access the methods
' use the class name directly.
' <pre>
' Debug.Print cArray.GetLength(MyArray)
' </pre>
'
Option Explicit


' extended safearray descriptor the includes the 16 bytes
' preceding the array descriptor. The 16 bytes contains
' a GUID for objects and user-defined types. This is to
' help in the correct copying of those types of elements.
Private Type GuidSafeArray1d
    Guid As VBGUID
    SA As SafeArray1d
End Type

''
' Represents the available array types that can be created using
' CreateInstance. The values corrispond the vbVarType enum.
'
' @param ciLong Same as vbLong
' @param ciInteger Same as vbInteger
' @param ciByte Same as vbByte
' @param ciDouble Same as vbDouble
' @param ciSingle Same as vbSingle
' @param ciBoolean Same as vbBoolean
' @param ciDate Same as vbDate
' @param ciString Same as vbString
' @param ciCurrency Same as vbCurrency
' @param ciVariant Same as vbVariant
' @param ciObject Same as vbObject
'
Public Enum ciArrayTypes
    ciLong = vbLong
    ciInteger = vbInteger
    ciByte = vbByte
    ciDouble = vbDouble
    ciSingle = vbSingle
    ciBoolean = vbBoolean
    ciDate = vbDate
    ciString = vbString
    ciCurrency = vbCurrency
    ciVariant = vbVariant
    ciObject = vbObject
End Enum



Private mBinarySearchDelegator  As FunctionDelegator
Private mBinarySearchComparer   As ITwoArgReturnLong

Private mIndexOfDelegator       As FunctionDelegator
Private mIndexOfComparer        As ITwoArgReturnBool 'ITwoRefReturnBool

Private mAssignDelegator        As FunctionDelegator
Private mAssigner               As ITwoArgReturnVoid

Private mSortDelegator          As FunctionDelegator
Private mSorter                 As ISortRoutine

Private mFindDelegator          As FunctionDelegator
Private mFinder                 As IOneArgReturnBool

Private mForEachDelegator       As FunctionDelegator
Private mForEach                As IOneArgReturnVoid

Private CallbackSorter          As New CallbackSorter


''
' Uses a callback method to check if an element in an array exists.
'
' @param arr The array to check if an element exists according to the callback criteria.
' @param AddressOfMatch The AddressOf the callback method used to determine if
' an element matches the specified criteria.
' @return Indication of the element existing in the array.
' @remarks Each array element is passed into a user callback method. The user
' then checks the element value to determine if it matches any criteria necessary
' and returns the result. The criteria is defined outside of the
' <b>Exists</b> method. How the criteria is defined and checked is up to the
' user of the function.
' <p>The function signature for the callback has a specific format.
' <pre>
' Public Function ExistsCallback(ByRef x As [Array Datatype]) As Boolean
'     '' return True if x matches your criteria.
' End Sub
' </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 Function Exists(ByRef Arr As Variant, ByVal AddressOfMatch As Long) As Boolean
    Exists = (FindIndex(Arr, AddressOfMatch) >= LBound(Arr))
End Function

''
' Uses a callback method to search an array for the first element that matches the criteria.
'
' @param arr The array to search.
' @param AddressOfMatch The callback method address used to determine if an element
' matches the specified criteria.
' @return The element value if a match is found, otherwise a default for that element type.
' @remarks <p>The function signature for the callback has a specific format.
' <pre>
' Public Function FindCallback(ByRef x As [Array Datatype]) As Boolean
'     '' return True if x matches your criteria.
' End Sub
' </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.Find.txt"
Public Function Find(ByRef Arr As Variant, ByVal AddressOfMatch As Long) As Variant
    Dim Index As Long
    
    Index = FindIndex(Arr, AddressOfMatch)
    If Index >= LBound(Arr) Then
        Call VariantCopyInd(Find, Arr(Index))
    Else
        Call AssignDefaultElementValue(Arr, Find)
    End If
End Function

''
' Finds the index of the first array element that matches the criteria
' specified by the callback function.
'
' @param arr The array to be searched.
' @param AddressOfMatch The address of the callback function used to match the array elements.
' @param Index The starting element of the array to beging the matching process.
' @param Count The number of elements to include in the array search.
' @return The index of the matched element, or LowerBound - 1 if none is found.
' @remarks <p>The function signature for the callback has a specific format.
' <pre>
' Public Function FindIndexCallback(ByRef x As [Array Datatype]) As Boolean
'     '' return True if x matches your criteria.
' End Sub
' </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.Find.txt"
Public Function FindIndex(ByRef Arr As Variant, ByVal AddressOfMatch As Long, Optional ByRef Index As Variant, Optional ByRef Count As Variant) As Long
    Dim pSafeArray As Long
    pSafeArray = GetArrayPointer(Arr)
    
    Dim Result      As Long
    Dim ElemIndex   As Long
    Dim ElemCount   As Long
    Result = GetOptionalArrayRange(pSafeArray, Index, ElemIndex, Count, ElemCount)
    If Result <> NO_ERROR Then Call ThrowArrayRangeException(Result, "Arr", ElemIndex, "Index", ElemCount, "Count", IsMissing(Index))
    
    Dim ElemSize As Long
    ElemSize = SafeArrayGetElemsize(pSafeArray)
    
    Dim pElem As Long
    pElem = MemLong(pSafeArray + PVDATA_OFFSET) + (ElemIndex - LBound(Arr)) * ElemSize
    
    mFindDelegator.pfn = AddressOfMatch
    
    Dim i As Long
    For i = 1 To ElemCount
        If mFinder.Call(pElem) = True Then
            FindIndex = LBound(Arr) + i - 1
            Exit Function
        End If
        pElem = pElem + ElemSize
    Next i
    FindIndex = LBound(Arr) - 1
End Function

''
' Finds all matching elements in an array, returning an array of the matched elements.
'
' @param arr The array to find all matching elements.
' @param AddressOfMatch The callback address of the matching criteria method.
' @return An array of all matched elements.
' @remarks <p>The function signature for the callback has a specific format.
' <pre>
' Public Function FindAllCallback(ByRef x As [Array Datatype]) As Boolean
'     '' return True if x matches your criteria.
' End Sub
' </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.Find.txt"
Public Function FindAll(ByRef Arr As Variant, ByVal AddressOfMatch As Long) As Variant
    mFindDelegator.pfn = AddressOfMatch
    
    Dim pSafeArray As Long
    pSafeArray = GetArrayPointer(Arr, True)
    
    Dim LowerBound As Long
    LowerBound = SafeArrayGetLBound(pSafeArray, 1)
    
    Dim Count As Long
    Count = SafeArrayGetUBound(pSafeArray, 1) - LowerBound + 1
    
    Dim ElemSize As Long
    ElemSize = SafeArrayGetElemsize(pSafeArray)
    
    Dim pElem As Long
    pElem = MemLong(pSafeArray + PVDATA_OFFSET)
    
    
    ' iterate each array element, passing the memory address
    ' to the user supplied AddressOf callback. This will appear
    ' as a ByRef parameter of the array's datatype in the callback.
    Dim i                   As Long
    Dim MatchCount          As Long
    Dim MatchedIndexes()    As Long
    
    ReDim MatchedIndexes(0 To 31)
    For i = LowerBound To LowerBound + Count - 1
        If mFinder.Call(pElem) = True Then
            If MatchCount > UBound(MatchedIndexes) Then ReDim Preserve MatchedIndexes(0 To MatchCount * 2 - 1)
            MatchedIndexes(MatchCount) = i
            MatchCount = MatchCount + 1
        End If
        pElem = pElem + ElemSize
    Next i
    
    Dim Ret         As Variant
    Dim ArrayType   As Long
    
    ArrayType = VarType(Arr) And &HFF   ' knock off the vbArray bit.
    Select Case ArrayType
        Case vbObject
            ' as an array of objects, we create a new array using the
            ' same Guid value as that of the original array.
            VariantType(Ret) = vbObject Or vbArray
            MemLong(VarPtr(Ret) + VARIANTDATA_OFFSET) = SafeArrayCreateVectorEx(vbObject, 0, MatchCount, pSafeArray - SIZEOF_GUID)
            'If MatchCount > 0 Then ReDim ret(0 To MatchCount - 1)
            
            For i = 0 To MatchCount - 1
                Set Ret(i) = Arr(MatchedIndexes(i))
            Next i
            
        Case vbUserDefinedType
            Dim UDT As IRecordInfo
            Set UDT = SafeArrayGetRecordInfo(pSafeArray)    ' gets an object used to manipulate a UDT.
            
            Dim pvData  As Long
            pvData = MemLong(pSafeArray + PVDATA_OFFSET)
            
            Dim pReturnSafeArray As Long
            pReturnSafeArray = SafeArrayCreateVectorEx(vbUserDefinedType, 0, MatchCount, ObjPtr(UDT))
            
            Dim pDstElem As Long
            pDstElem = MemLong(pReturnSafeArray + PVDATA_OFFSET)
            
            For i = 0 To MatchCount - 1
                Call UDT.RecordCopy(pvData + (MatchedIndexes(i) - LowerBound) * ElemSize, pDstElem)
                pDstElem = pDstElem + ElemSize
            Next i
            
            VariantType(Ret) = vbUserDefinedType Or vbArray
            MemLong(VarPtr(Ret) + VARIANTDATA_OFFSET) = pReturnSafeArray
            
        Case Else
            Ret = CreateInstance(ArrayType, MatchCount)
            For i = 0 To MatchCount - 1