modarrayhelpers.bas

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

Attribute VB_Name = "modArrayHelpers"
'    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: modArrayHelpers
'
Option Explicit

Public Type SortItems
    SA As SafeArray1d
    Buffer As Long
End Type

Private mSortItems      As SortItems
Private mHasSortItems   As Boolean
Private mSortKeys       As SortItems
Public SortComparer     As IComparer



' This is a set of comparison routines used by function delegation calls.
' They allow a virtual comparison routine to be selected and called without
' needing to modify code. Only the address of the specific routine is needed.
Public Function CompareLongs(ByRef x As Long, ByRef y As Long) As Long
    If x > y Then CompareLongs = 1: Exit Function
    If x < y Then CompareLongs = -1
End Function
Public Function CompareIntegers(ByRef x As Integer, ByRef y As Integer) As Long
    If x > y Then CompareIntegers = 1: Exit Function
    If x < y Then CompareIntegers = -1
End Function
Public Function CompareStrings(ByRef x As String, ByRef y As String) As Long
    If x > y Then CompareStrings = 1: Exit Function
    If x < y Then CompareStrings = -1
End Function
Public Function CompareDoubles(ByRef x As Double, ByRef y As Double) As Long
    If x > y Then CompareDoubles = 1: Exit Function
    If x < y Then CompareDoubles = -1
End Function
Public Function CompareSingles(ByRef x As Single, ByRef y As Single) As Long
    If x > y Then CompareSingles = 1: Exit Function
    If x < y Then CompareSingles = -1
End Function
Public Function CompareBytes(ByRef x As Byte, ByRef y As Byte) As Long
    If x > y Then CompareBytes = 1: Exit Function
    If x < y Then CompareBytes = -1
End Function
Public Function CompareBooleans(ByRef x As Boolean, ByRef y As Boolean) As Long
    If x > y Then CompareBooleans = 1: Exit Function
    If x < y Then CompareBooleans = -1
End Function
Public Function CompareDates(ByRef x As Date, ByRef y As Date) As Long
    CompareDates = DateDiff("s", y, x)
End Function
Public Function CompareCurrencies(ByRef x As Currency, ByRef y As Currency) As Long
    If x > y Then CompareCurrencies = 1: Exit Function
    If x < y Then CompareCurrencies = -1
End Function
Public Function CompareIComparable(ByRef x As Object, ByRef y As Variant) As Long
    Dim comparableX As IComparable
    Set comparableX = x
    CompareIComparable = comparableX.CompareTo(y)
End Function
Public Function CompareVariants(ByRef x As Variant, ByRef y As Variant) As Long
    Dim comparable As IComparable
    
    Select Case VarType(x)
        Case vbNull
            If IsNull(y) Then Exit Function
            CompareVariants = -1
            Exit Function
        Case vbEmpty
            If IsEmpty(y) Then Exit Function
            CompareVariants = -1
            Exit Function
        Case vbObject, vbDataObject
            If TypeOf x Is IComparable Then
                Set comparable = x
                CompareVariants = comparable.CompareTo(y)
                Exit Function
            End If
        Case VarType(y)
            If x = y Then Exit Function
            If x < y Then
                CompareVariants = -1
            Else
                CompareVariants = 1
            End If
            Exit Function
    End Select
    Select Case VarType(y)
        Case vbNull, vbEmpty
            CompareVariants = 1
        Case vbObject, vbDataObject
            If TypeOf y Is IComparable Then
                Set comparable = y
                CompareVariants = -comparable.CompareTo(x)
                Exit Function
            Else
                Throw Cor.NewArgumentException("Object must implement IComparable interface.")
            End If
        Case Else
            Throw Cor.NewInvalidOperationException("Specified IComparer failed.")
    End Select
End Function


' This is a set of equality routines used by function delegation calls.
' They allow a virtual equality routine to be selected and called without
' needing to modify code. Only the address of the specific routine is needed.
'
Public Function EqualsLong(ByRef x As Long, ByRef y As Long) As Boolean: EqualsLong = (x = y): End Function
Public Function EqualsString(ByRef x As String, ByRef y As String) As Boolean: EqualsString = (x = y): End Function
Public Function EqualsDouble(ByRef x As Double, ByRef y As Double) As Boolean: EqualsDouble = (x = y): End Function
Public Function EqualsInteger(ByRef x As Integer, ByRef y As Integer) As Boolean: EqualsInteger = (x = y): End Function
Public Function EqualsSingle(ByRef x As Single, ByRef y As Single) As Boolean: EqualsSingle = (x = y): End Function
Public Function EqualsDate(ByRef x As Date, ByRef y As Date) As Boolean: EqualsDate = (DateDiff("s", x, y) = 0): End Function
Public Function EqualsByte(ByRef x As Byte, ByRef y As Byte) As Boolean: EqualsByte = (x = y): End Function
Public Function EqualsBoolean(ByRef x As Boolean, ByRef y As Boolean) As Boolean: EqualsBoolean = (x = y): End Function
Public Function EqualsCurrency(ByRef x As Currency, ByRef y As Currency) As Boolean: EqualsCurrency = (x = y): End Function
Public Function EqualsObject(ByRef x As Object, ByRef y As Object) As Boolean
    Dim o As IObject
    If TypeOf x Is IObject Then
        Set o = x
        EqualsObject = o.Equals(y)
    Else
        EqualsObject = x Is y
    End If
End Function

Public Function EqualsVariants(ByRef x As Variant, ByRef y As Variant) As Boolean
    Dim o As IObject
    Select Case VarType(x)
        Case vbObject
            If x Is Nothing Then
                If IsObject(y) Then
                    EqualsVariants = (y Is Nothing)
                End If
            ElseIf TypeOf x Is IObject Then
                Set o = x
                EqualsVariants = o.Equals(y)
            ElseIf IsObject(y) Then
                If y Is Nothing Then Exit Function
                If TypeOf y Is IObject Then
                    Set o = y
                    EqualsVariants = o.Equals(x)
                Else
                    EqualsVariants = (x Is y)
                End If
            End If
        Case vbNull
            EqualsVariants = IsNull(y)
        Case VarType(y)
            EqualsVariants = (x = y)
    End Select
End Function

' This is a set of casting routines used by function delegation calls.
' They allow a virtual casting routine to be selected and called without
' needing to modify code. Only the address of the specific routine is needed.
'
Public Sub WidenLongToDouble(ByRef x As Double, ByRef y As Long): x = y: End Sub
Public Sub WidenLongToString(ByRef x As String, ByRef y As Long): x = y: End Sub
Public Sub WidenLongToCurrency(ByRef x As Currency, ByRef y As Long): x = y: End Sub
Public Sub WidenLongToVariant(ByRef x As Variant, ByRef y As Long): x = y: End Sub
Public Sub WidenIntegerToLong(ByRef x As Long, ByRef y As Integer): x = y: End Sub
Public Sub WidenIntegerToSingle(ByRef x As Single, ByRef y As Integer): x = y: End Sub
Public Sub WidenIntegerToDouble(ByRef x As Double, ByRef y As Integer): x = y: End Sub
Public Sub WidenIntegerToString(ByRef x As String, ByRef y As Integer): x = y: End Sub
Public Sub WidenIntegerToCurrency(ByRef x As Currency, ByRef y As Integer): x = y: End Sub
Public Sub WidenIntegerToVariant(ByRef x As Variant, ByRef y As Integer): x = y: End Sub
Public Sub WidenByteToInteger(ByRef x As Integer, ByRef y As Byte): x = y: End Sub
Public Sub WidenByteToLong(ByRef x As Long, ByRef y As Byte): x = y: End Sub
Public Sub WidenByteToSingle(ByRef x As Single, ByRef y As Byte): x = y: End Sub
Public Sub WidenByteToDouble(ByRef x As Double, ByRef y As Byte): x = y: End Sub
Public Sub WidenByteToString(ByRef x As String, ByRef y As Byte): x = y: End Sub
Public Sub WidenByteToCurrency(ByRef x As Currency, ByRef y As Byte): x = y: End Sub
Public Sub WidenByteToVariant(ByRef x As Variant, ByRef y As Byte): x = y: End Sub
Public Sub WidenSingleToDouble(ByRef x As Double, ByRef y As Single): x = y: End Sub
Public Sub WidenSingleToString(ByRef x As String, ByRef y As Single): x = y: End Sub
Public Sub WidenSingleToVariant(ByRef x As Variant, ByRef y As Single): x = y: End Sub
Public Sub WidenDateToDouble(ByRef x As Double, ByRef y As Date): x = y: End Sub
Public Sub WidenDateToString(ByRef x As String, ByRef y As Date): x = y: End Sub
Public Sub WidenDateToVariant(ByRef x As Variant, ByRef y As Date): x = y: End Sub
Public Sub WidenObjectToVariant(ByRef x As Variant, ByRef y As Object): Set x = y: End Sub
Public Sub WidenCurrencyToString(ByRef x As String, ByRef y As Currency): x = y: End Sub
Public Sub WidenCurrencyToVariant(ByRef x As Variant, ByRef y As Currency): x = y: End Sub
Public Sub WidenStringToVariant(ByRef x As Variant, ByRef y As String): x = y: End Sub

' Functions used to assign variants to narrower variables.
Public Sub NarrowVariantToLong(ByRef x As Long, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToInteger(ByRef x As Integer, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToDouble(ByRef x As Double, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToString(ByRef x As String, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToSingle(ByRef x As Single, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToByte(ByRef x As Byte, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToDate(ByRef x As Date, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToBoolean(ByRef x As Boolean, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToCurrency(ByRef x As Currency, ByRef y As Variant): x = y: End Sub
Public Sub NarrowVariantToObject(ByRef x As Object, ByRef y As Variant): Set x = y: End Sub



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Optimized sort routines. There could have been one
'   all-purpose sort routine, but it would be too slow.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub SetSortKeys(ByVal pSA As Long)
    Call CopyMemory(mSortKeys.SA, ByVal pSA, SIZEOF_SAFEARRAY1D)
    Select Case mSortKeys.SA.cbElements
        Case 1, 2, 4, 8, 16
        Case Else: mSortKeys.Buffer = CoTaskMemAlloc(mSortKeys.SA.cbElements)
    End Select
End Sub
Public Sub ClearSortKeys()
    If mSortKeys.Buffer Then Call CoTaskMemFree(mSortKeys.Buffer)
    mSortKeys.Buffer = 0
End Sub
Public Sub SetSortItems(ByVal pSA As Long)
    Call CopyMemory(mSortItems.SA, ByVal pSA, SIZEOF_SAFEARRAY1D)
    Select Case mSortItems.SA.cbElements
        Case 1, 2, 4, 8, 16
        Case Else: mSortItems.Buffer = CoTaskMemAlloc(mSortItems.SA.cbElements)
    End Select
    mHasSortItems = True
End Sub
Public Sub ClearSortItems()
    If mHasSortItems Then
        Call CoTaskMemFree(mSortItems.Buffer)