Public Function QSortCompare( _
V1 As Variant, _
V2 As Variant, _
Optional CompareMode As VbCompareMethod = vbTextCompare) As Long
Dim D1 As Double
Dim D2 As Double
Dim S1 As String
Dim S2 As String
Dim Compare As VbCompareMethod
If CompareMode = vbBinaryCompare Or CompareMode = vbTextCompare Then
Compare = CompareMode
Else
Compare = vbTextCompare
End If
If IsArray(V1) = True Or IsArray(V2) = True Then
Err.Raise 13
Exit Function
End If
If IsObject(V1) = True Or IsObject(V2) = True Then
Err.Raise 13
Exit Function
End If
If IsSimpleNumericType(V1) = True Then
If IsSimpleNumericType(V2) = True Then
D1 = CDbl(V1)
D2 = CDbl(V2)
If D1 = D2 Then
QSortCompare = 0
Exit Function
End If
If D1 < D2 Then
QSortCompare = -1
Exit Function
End If
If D1 > D2 Then
QSortCompare = 1
Exit Function
End If
End If
End If
If IsNumeric(V1) = True And IsNumeric(V2) = True Then
D1 = CDbl(V1)
D2 = CDbl(V2)
If D1 = D2 Then
QSortCompare = 0
Exit Function
End If
If D1 < D2 Then
QSortCompare = -1
Exit Function
End If
If D1 > D2 Then
QSortCompare = 1
Exit Function
End If
End If
S1 = CStr(V1)
S2 = CStr(V2)
QSortCompare = StrComp(S1, S2, Compare)
End Function
Public Function NumberOfArrayDimensions(Arr As Variant) As Long
Dim Ndx As Long
Dim Res As Long
On Error Resume Next
Do
Ndx = Ndx + 1
Res = UBound(Arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Public Function ReverseArrayInPlace(InputArray As Variant, _
Optional NoAlerts As Boolean = False) As Boolean
Dim Temp As Variant
Dim Ndx As Long
Dim Ndx2 As Long
Dim OrigN As Long
Dim NewN As Long
Dim NewArr() As Variant
ReverseArrayInPlace = False
If IsArray(InputArray) = False Then
If NoAlerts = False Then
MsgBox "The InputArray parameter is not an array."
End If
Exit Function
End If
Select Case NumberOfArrayDimensions(InputArray)
Case 0
If NoAlerts = False Then
MsgBox "The input array is an empty, unallocated array."
End If
Exit Function
Case 1
Case Else
If NoAlerts = False Then
MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _
"on single-dimensional arrays."
End If
Exit Function
End Select
If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then
If NoAlerts = False Then
MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _
"ReverseArrayInPlace can reverse only arrays of simple data types."
Exit Function
End If
End If
ReDim NewArr(LBound(InputArray) To UBound(InputArray))
NewN = UBound(NewArr)
For OrigN = LBound(InputArray) To UBound(InputArray)
NewArr(NewN) = InputArray(OrigN)
NewN = NewN - 1
Next OrigN
For NewN = LBound(NewArr) To UBound(NewArr)
InputArray(NewN) = NewArr(NewN)
Next NewN
ReverseArrayInPlace = True
End Function
Public Function ReverseArrayInPlace2(InputArray As Variant, _
Optional LB As Long = -1, Optional UB As Long = -1, _
Optional NoAlerts As Boolean = False) As Boolean
Dim N As Long
Dim Temp As Variant
Dim Ndx As Long
Dim Ndx2 As Long
Dim OrigN As Long
Dim NewN As Long
Dim NewArr() As Variant
ReverseArrayInPlace2 = False
If IsArray(InputArray) = False Then
If NoAlerts = False Then
MsgBox "The InputArray parameter is not an array."
End If
Exit Function
End If
Select Case NumberOfArrayDimensions(InputArray)
Case 0
If NoAlerts = False Then
MsgBox "The input array is an empty, unallocated array."
End If
Exit Function
Case 1
Case Else
If NoAlerts = False Then
MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _
"on single-dimensional arrays."
End If
Exit Function
End Select
If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then
If NoAlerts = False Then
MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _
"ReverseArrayInPlace can reverse only arrays of simple data types."
Exit Function
End If
End If
ReDim NewArr(LBound(InputArray) To UBound(InputArray))
NewN = UBound(NewArr)
If LB < 0 Then
LB = LBound(InputArray)
End If
If UB < 0 Then
UB = UBound(InputArray)
End If
For OrigN = LBound(InputArray) To UBound(InputArray)
If OrigN < LB Then
NewArr(OrigN) = InputArray(OrigN)
ElseIf OrigN > UB Then
NewArr(OrigN) = InputArray(OrigN)
Else
NewArr(NewN) = InputArray(OrigN)
End If
NewN = NewN - 1
Next OrigN
For NewN = LBound(NewArr) To UBound(NewArr)
InputArray(NewN) = NewArr(NewN)
Next NewN
ReverseArrayInPlace2 = True
End Function
Public Function IsSimpleNumericType(V As Variant) As Boolean
If IsSimpleDataType(V) = True Then
Select Case VarType(V)
Case vbBoolean, _
vbByte, _
vbCurrency, _
vbDate, _
vbDecimal, _
vbDouble, _
vbInteger, _
vbLong, _
vbSingle
IsSimpleNumericType = True
Case vbVariant
If IsNumeric(V) = True Then
IsSimpleNumericType = True
Else
IsSimpleNumericType = False
End If
Case Else
IsSimpleNumericType = False
End Select
Else
IsSimpleNumericType = False
End If
End Function
Public Function IsSimpleDataType(V As Variant) As Boolean
On Error Resume Next
If IsArray(V) = True Then
IsSimpleDataType = False
Exit Function
End If
If IsObject(V) = True Then
IsSimpleDataType = False
Exit Function
End If
Select Case VarType(V)
Case vbArray, vbDataObject, vbObject, vbUserDefinedType
IsSimpleDataType = False
Case Else
IsSimpleDataType = True
End Select
End Function
Public Function IsArrayAllocated(Arr As Variant) As Boolean
Dim N As Long
If IsArray(Arr) = False Then
IsArrayAllocated = False
Exit Function
End If
On Error Resume Next
N = UBound(Arr, 1)
If Err.Number = 0 Then
IsArrayAllocated = True
Else
IsArrayAllocated = False
End If
End Function