Option Explicit
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, Optional saBound As Currency) As Long
Public Function GetNumbersToLong(Text As String) As Long()
' temporary safe array variables
Dim LA() As Long, LH(0 To 5) As Long, LP As Long
Dim IA() As Integer, IH(0 To 5) As Long, IP As Long
' other variables
Dim C As Long, D As Long, I As Long, N As Boolean, O() As Long, V As Long
' create a temporary Long array to replace the need for PutMem4
LP = ArrPtr(LA)
' create safe array header for Long array
LH(0&) = 1&: LH(1&) = 4&: LH(4&) = &H3FFFFFFF
' this is the only PutMem4 call we need, accessing a Long array is much faster than calling PutMem4!
PutMem4 LP, VarPtr(LH(0&))
' create a temporary Integer array to access the contents of Text
IP = ArrPtr(IA)
' create safe array header for Integer array
IH(0&) = 1&: IH(1&) = 2&: IH(3&) = StrPtr(Text): IH(4&) = Len(Text)
' does the same as the PutMem4 line above, but without calling PutMem4 :)
LH(3&) = IP: LA(0&) = VarPtr(IH(0&))
' estimate the absolute maximum amount of items
V = IH(4&) \ 2&
If V > 255& Then
' if over 256 items then limit ReDim to 256 items
ReDim O(255&)
Else
' otherwise we only ReDim what we will absolutely need
' note: if this line executes then we won't ever call ReDim Preserve within the For loop
ReDim O(V)
End If
' then we loop through all characters
For I = 0& To UBound(IA)
' convert from Integer to Long for better speed and drop highest bit (= negative indicator)
D = (CLng(IA(I)) - 48&) And &H7FFFFFFF
' are we processing numbers?
If Not N Then
' is this the first number?
If D <= 9& Then
' first number!
V = D
' enter "processing numbers" mode
N = True
End If
' we are in "processing numbers" mode, see if we need to add a new digit
ElseIf D <= 9& Then
V = V * 10 + D
' we must end "processing numbers" mode
Else
' store the final number into array
O(C) = V
' increase counter
C = C + 1&
' see if we are in danger of going out of buffer, reserve 256 new items for us if so
If (C Mod 256&) = 0& Then ReDim Preserve O(C + 255&)
' end the "processing numbers" mode
N = False
End If
Next
' if we are in "processing numbers" mode then we still must add the final item to the array
If N Then O(C) = V: C = C + 1&
' did we get any items?
If C > 0& Then
' set ubound
C = C - 1&
' do we need to resize the array?
If UBound(O&) > C Then ReDim Preserve O(C)
Else
' remove all items from the array (LBound = 0, UBound = -1)
SafeArrayRedim Not Not O
' VB6 IDE has a bug calling Not for an array, must call this to get rid of it
Debug.Assert App.hInstance
End If
' remove temporary Integer array
LH(3&) = IP: LA(0&) = 0&
' remove temporary Long array
LH(3&) = LP: LA(0&) = 0&
' return the resulting array
GetNumbersToLong = O
End Function
Public Function GetNumbersToString(Text As String) As String()
' temporary safe array variables
Dim LA() As Long, LH(0 To 5) As Long, LP As Long
Dim IA() As Integer, IH(0 To 5) As Long, IP As Long
' other variables
Dim C As Long, D As Long, I As Long, O() As String, V As Long
' create a temporary Long array to replace the need for PutMem4
LP = ArrPtr(LA)
' create safe array header for Long array
LH(0&) = 1&: LH(1&) = 4&: LH(4&) = &H3FFFFFFF
' this is the only PutMem4 call we need, accessing a Long array is much faster than calling PutMem4!
PutMem4 LP, VarPtr(LH(0&))
' create a temporary Integer array to access the contents of Text
IP = ArrPtr(IA)
' create safe array header for Integer array
IH(0&) = 1&: IH(1&) = 2&: IH(3&) = StrPtr(Text): IH(4&) = Len(Text)
' does the same as the PutMem4 line above, but without calling PutMem4 :)
LH(3&) = IP: LA(0&) = VarPtr(IH(0&))
' estimate the absolute maximum amount of items
D = IH(4&) \ 2&
If D > 255& Then
' if over 256 items then limit ReDim to 256 items
ReDim O(255&)
Else
' otherwise we only ReDim what we will absolutely need
' note: if this line executes then we won't ever call ReDim Preserve within the For loop
ReDim O(D)
End If
' then we loop through all characters
For I = 0 To UBound(IA)
' convert from Integer to Long for better speed and drop highest bit (= negative indicator)
D = (CLng(IA(I)) - 48&) And &H7FFFFFFF
' are we processing numbers?
If V = 0& Then
' if this the first number then enter "processing numbers" mode
If D <= 9& Then V = I + 1&
' do we have to end "processing numbers" mode?
ElseIf D > 9& Then
' store the string into array
If V > 1& Then
O(C) = Mid$(Text, V, I + 1& - V)
Else
O(C) = Left$(Text, I + 1& - V)
End If
' increase counter
C = C + 1&
' see if we are in danger of going out of buffer, reserve 256 new items for us if so
If (C Mod 256&) = 0& Then ReDim Preserve O(C + 255&)
' end the "processing numbers" mode
V = 0&
End If
Next
' if we are in "processing numbers" mode then we still must add the final item to the array
If V > 0& Then O(C) = Right$(Text, I + 1& - V): C = C + 1&
' did we get any items?
If C > 0& Then
' set ubound
C = C - 1&
' do we need to resize the array?
If UBound(O) > C Then ReDim Preserve O(C)
Else
' remove all items from the array (LBound = 0, UBound = -1)
SafeArrayRedim Not Not O
' VB6 IDE has a bug calling Not for an array, must call this to get rid of it
Debug.Assert App.hInstance
End If
' remove temporary Integer array
LH(3&) = IP: LA(0) = 0&
' remove temporary Long array
LH(3&) = LP: LA(0) = 0&
' return the resulting array
GetNumbersToString = O
End Function
