R
RB Smissaert
This is a bit of a complex question, but let me try.
Firstly, I picked up a really neat trick from Jim Mack to alter the lBound
of an array.
Maybe one for Alan Beban, but I suppose the knows this already.
This is the Sub I use now as the result of this tip:
Private Declare Function VarPtrAry _
Lib "msvbvm60" _
Alias "VarPtr" (Ary() As Any) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Dest As Any, Src As Any, _
ByVal cBytes As Long)
Function GetArrayDims(arr As Variant) As Integer
'---------------------------------------'
'copied from Francesco Balena at: '
'http://www.devx.com/vb2themax/Tip/18265'
'---------------------------------------'
Dim ptr As Long
Dim VType As Integer
Const VT_BYREF = &H4000&
' get the real VarType of the argument
' this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory VType, arr, 2
' exit if not an array
If (VType And vbArray) = 0 Then
Exit Function
End If
' get the address of the SAFEARRAY descriptor
' this is stored in the second half of the
' Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
' see whether the routine was passed a Variant
' that contains an array, rather than directly an array
' in the former case ptr already points to the SA structure.
' Thanks to Monte Hansen for this fix
If (VType And VT_BYREF) Then
' ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
' get the address of the SAFEARRAY structure
' this is stored in the descriptor
' get the first word of the SAFEARRAY structure
' which holds the number of dimensions
' ...but first check that saAddr is non-zero, otherwise
' this routine bombs when the array is uninitialized
' (Thanks to VB2TheMax aficionado Thomas Eyde for
' suggesting this edit to the original routine.)
If ptr Then
CopyMemory GetArrayDims, ByVal ptr, 2
End If
End Function
Sub SetLBound(Ary() As Double, lNewLBound As Long)
'
' "As Double" for example only -- use your specific type
'
' Note that this won't work for string() or UDT() with strings
'
' Sets Ary's LBound to NewBound, returns previous LBound.
Dim i As Integer
Dim AryPtr As Long
Dim PrevLBound As Long
Dim iDims As Integer
iDims = GetArrayDims(Ary)
If iDims = 0 Then
Exit Sub
End If
AryPtr = VarPtrAry(Ary) ' address of address of safearray struct
CopyMemory AryPtr, ByVal AryPtr, 4
AryPtr = AryPtr + 20 ' pointer to safearray.bounds.lLbound
CopyMemory PrevLBound, ByVal AryPtr, 4
'no point altering lBound to the existing lBound
If PrevLBound = lNewLBound Then
Exit Sub
End If
For i = 1 To iDims
CopyMemory ByVal AryPtr + (i - 1) * 8, lNewLBound, 4
Next
End Sub
The last Sub needs to be specific for a specific datatype, so if you gave it
an array of longs it would be:
Sub SetLBound(Ary() As Long, lNewLBound As Long)
Now I thought I could use this trick (altering the lBound of an array much
faster than by any other method)
to handle a little problem with the VSort function in Laurent Longre's .xll
MoreFunc.
This is that it alters 0-based arrays in 1-based arrays.
This is the wrapper function for this VSort as I have it now:
Function VSORTArray(ByRef arr As Variant, _
ByVal btCol1 As Byte, _
ByVal strSortType1 As String, _
Optional ByVal btCol2 As Byte = 0, _
Optional ByVal strSortType2 As String = "", _
Optional ByVal btCol3 As Byte = 0, _
Optional ByVal strSortType3 As String = "") As Variant
'------------------------------------------------------------------
'http://longre.free.fr/english/
'Uses Laurent Longre's VSort function in the .xll add-in MoreFunc
'Will be about 4 to 5 times faster than a quicksort and can sort
'on multiple columns.
'Done up to 3 columns here, but can be done up to 14 columns
'------------------------------------------------------------------
'will sort an 0-based or 1-based 2-D array with up to 3 sort keys
'the field key has to be supplied as a byte, where the first column
'of the array is 1, even if it is an 0-based array
'the sort type has to be given as "a", "A" , "b" or "B"
'examples:
'sorting on 1 field: arr2 = VSORTArray(arr, 1, "A")
'sorting on 2 fields: arr2 = VSORTArray(arr, 2, "D", 5, "A")
'------------------------------------------------------------------
Dim i As Long
Dim c As Long
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim arrKey1
Dim arrKey2
Dim arrKey3
Dim btSortType1 As Byte
Dim btSortType2 As Byte
Dim btSortType3 As Byte
Dim arrFinal
Dim arrFinal2
LB1 = LBound(arr)
UB1 = UBound(arr)
LB2 = LBound(arr, 2)
UB2 = UBound(arr, 2)
'make the array for key 1
'------------------------
ReDim arrKey1(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey1(i, LB1) = arr(i, btCol1 - (1 - LB1))
Next
'set the sort type for key 1
'---------------------------
If UCase(strSortType1) = "A" Then
btSortType1 = 1
Else
btSortType1 = 0
End If
If Not btCol2 = 0 Then
'make the array for key 2
'------------------------
ReDim arrKey2(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey2(i, LB1) = arr(i, btCol2 - (1 - LB1))
Next
'set the sort type for key 2
'---------------------------
If UCase(strSortType2) = "A" Then
btSortType2 = 1
Else
btSortType2 = 0
End If
End If
If Not btCol3 = 0 Then
'make the array for key 3
'------------------------
ReDim arrKey3(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey3(i, LB1) = arr(i, btCol3 - (1 - LB1))
Next
'set the sort type for key 3
'---------------------------
If UCase(strSortType3) = "A" Then
btSortType3 = 1
Else
btSortType3 = 0
End If
End If
If Not strSortType3 = "" Then
'3 fields to sort on
'-------------------
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2, _
arrKey3, btSortType3)
Else
'2 fields to sort on
'-------------------
If Not strSortType2 = "" Then
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2)
Else
'1 field to sort on
'------------------
arrFinal = Application.Run([VSORT], _
arr, arrKey1, btSortType1)
End If
End If
If LB1 = 0 Then
'to revert back to an 0-based array
'----------------------------------
ReDim arrFinal2(LB1 To UB1, LB2 To UB2)
For i = LBound(arrFinal) To UBound(arrFinal)
For c = LBound(arrFinal, 2) To UBound(arrFinal, 2)
arrFinal2(i - (1 - LB1), c - (1 - LB2)) = arrFinal(i, c)
Next
Next
VSORTArray = arrFinal2
Else
VSORTArray = arrFinal
End If
End Function
This works fine, but to be able to use the above lBound altering code when
giving it an array of longs,
arrFinal needs to be declared as an array of longs.
This now is the trouble. Tried all sorts of constructions, but sofar haven't
managed it yet.
It looks VSort needs to be used as a function, so with the sorted array as
the function result.
Running it as a Sub doesn't work.
Any suggestions how to do this?
RBS
Firstly, I picked up a really neat trick from Jim Mack to alter the lBound
of an array.
Maybe one for Alan Beban, but I suppose the knows this already.
This is the Sub I use now as the result of this tip:
Private Declare Function VarPtrAry _
Lib "msvbvm60" _
Alias "VarPtr" (Ary() As Any) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Dest As Any, Src As Any, _
ByVal cBytes As Long)
Function GetArrayDims(arr As Variant) As Integer
'---------------------------------------'
'copied from Francesco Balena at: '
'http://www.devx.com/vb2themax/Tip/18265'
'---------------------------------------'
Dim ptr As Long
Dim VType As Integer
Const VT_BYREF = &H4000&
' get the real VarType of the argument
' this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory VType, arr, 2
' exit if not an array
If (VType And vbArray) = 0 Then
Exit Function
End If
' get the address of the SAFEARRAY descriptor
' this is stored in the second half of the
' Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
' see whether the routine was passed a Variant
' that contains an array, rather than directly an array
' in the former case ptr already points to the SA structure.
' Thanks to Monte Hansen for this fix
If (VType And VT_BYREF) Then
' ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
' get the address of the SAFEARRAY structure
' this is stored in the descriptor
' get the first word of the SAFEARRAY structure
' which holds the number of dimensions
' ...but first check that saAddr is non-zero, otherwise
' this routine bombs when the array is uninitialized
' (Thanks to VB2TheMax aficionado Thomas Eyde for
' suggesting this edit to the original routine.)
If ptr Then
CopyMemory GetArrayDims, ByVal ptr, 2
End If
End Function
Sub SetLBound(Ary() As Double, lNewLBound As Long)
'
' "As Double" for example only -- use your specific type
'
' Note that this won't work for string() or UDT() with strings
'
' Sets Ary's LBound to NewBound, returns previous LBound.
Dim i As Integer
Dim AryPtr As Long
Dim PrevLBound As Long
Dim iDims As Integer
iDims = GetArrayDims(Ary)
If iDims = 0 Then
Exit Sub
End If
AryPtr = VarPtrAry(Ary) ' address of address of safearray struct
CopyMemory AryPtr, ByVal AryPtr, 4
AryPtr = AryPtr + 20 ' pointer to safearray.bounds.lLbound
CopyMemory PrevLBound, ByVal AryPtr, 4
'no point altering lBound to the existing lBound
If PrevLBound = lNewLBound Then
Exit Sub
End If
For i = 1 To iDims
CopyMemory ByVal AryPtr + (i - 1) * 8, lNewLBound, 4
Next
End Sub
The last Sub needs to be specific for a specific datatype, so if you gave it
an array of longs it would be:
Sub SetLBound(Ary() As Long, lNewLBound As Long)
Now I thought I could use this trick (altering the lBound of an array much
faster than by any other method)
to handle a little problem with the VSort function in Laurent Longre's .xll
MoreFunc.
This is that it alters 0-based arrays in 1-based arrays.
This is the wrapper function for this VSort as I have it now:
Function VSORTArray(ByRef arr As Variant, _
ByVal btCol1 As Byte, _
ByVal strSortType1 As String, _
Optional ByVal btCol2 As Byte = 0, _
Optional ByVal strSortType2 As String = "", _
Optional ByVal btCol3 As Byte = 0, _
Optional ByVal strSortType3 As String = "") As Variant
'------------------------------------------------------------------
'http://longre.free.fr/english/
'Uses Laurent Longre's VSort function in the .xll add-in MoreFunc
'Will be about 4 to 5 times faster than a quicksort and can sort
'on multiple columns.
'Done up to 3 columns here, but can be done up to 14 columns
'------------------------------------------------------------------
'will sort an 0-based or 1-based 2-D array with up to 3 sort keys
'the field key has to be supplied as a byte, where the first column
'of the array is 1, even if it is an 0-based array
'the sort type has to be given as "a", "A" , "b" or "B"
'examples:
'sorting on 1 field: arr2 = VSORTArray(arr, 1, "A")
'sorting on 2 fields: arr2 = VSORTArray(arr, 2, "D", 5, "A")
'------------------------------------------------------------------
Dim i As Long
Dim c As Long
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim arrKey1
Dim arrKey2
Dim arrKey3
Dim btSortType1 As Byte
Dim btSortType2 As Byte
Dim btSortType3 As Byte
Dim arrFinal
Dim arrFinal2
LB1 = LBound(arr)
UB1 = UBound(arr)
LB2 = LBound(arr, 2)
UB2 = UBound(arr, 2)
'make the array for key 1
'------------------------
ReDim arrKey1(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey1(i, LB1) = arr(i, btCol1 - (1 - LB1))
Next
'set the sort type for key 1
'---------------------------
If UCase(strSortType1) = "A" Then
btSortType1 = 1
Else
btSortType1 = 0
End If
If Not btCol2 = 0 Then
'make the array for key 2
'------------------------
ReDim arrKey2(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey2(i, LB1) = arr(i, btCol2 - (1 - LB1))
Next
'set the sort type for key 2
'---------------------------
If UCase(strSortType2) = "A" Then
btSortType2 = 1
Else
btSortType2 = 0
End If
End If
If Not btCol3 = 0 Then
'make the array for key 3
'------------------------
ReDim arrKey3(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey3(i, LB1) = arr(i, btCol3 - (1 - LB1))
Next
'set the sort type for key 3
'---------------------------
If UCase(strSortType3) = "A" Then
btSortType3 = 1
Else
btSortType3 = 0
End If
End If
If Not strSortType3 = "" Then
'3 fields to sort on
'-------------------
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2, _
arrKey3, btSortType3)
Else
'2 fields to sort on
'-------------------
If Not strSortType2 = "" Then
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2)
Else
'1 field to sort on
'------------------
arrFinal = Application.Run([VSORT], _
arr, arrKey1, btSortType1)
End If
End If
If LB1 = 0 Then
'to revert back to an 0-based array
'----------------------------------
ReDim arrFinal2(LB1 To UB1, LB2 To UB2)
For i = LBound(arrFinal) To UBound(arrFinal)
For c = LBound(arrFinal, 2) To UBound(arrFinal, 2)
arrFinal2(i - (1 - LB1), c - (1 - LB2)) = arrFinal(i, c)
Next
Next
VSORTArray = arrFinal2
Else
VSORTArray = arrFinal
End If
End Function
This works fine, but to be able to use the above lBound altering code when
giving it an array of longs,
arrFinal needs to be declared as an array of longs.
This now is the trouble. Tried all sorts of constructions, but sofar haven't
managed it yet.
It looks VSort needs to be used as a function, so with the sorted array as
the function result.
Running it as a Sub doesn't work.
Any suggestions how to do this?
RBS