[VB6] Faster Split & Join (development)

[Merri]

Ellis Dee: These are the short versions updated to the even shorter code. I did a minor logical change: I made the loop code run via a True condition, instead of only checking whether to exit the loop, switching that to be the slightly slower False condition. I think this kind of improves readibility too, but that is a matter of opinion.

I also did some further optimization that gives 0 to 4 % of performance boost, depends on the usage (how often called, how big input data, how many possible output results).

Option Explicit

Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, saBound As Long) As Long

' Short, commented & fully VB5 compatible version of QuickSplit at http://www.vbforums.com/showthread.php?t=540323
Public Sub QuickSplit(Expression As String, ResultSplit() As String, Optional Delimiter As String = " ", Optional ByVal Limit As Long = -1)
    Static lngResults() As Long
    ' general variables that we need
    Dim lngA As Long, lngCount As Long, lngDelLen As Long, lngExpLen As Long
    ' some dummy variables that we happen to need
    Dim Compare As VbCompareMethod, SafeArrayBound(1) As Long
    ' length information
    lngExpLen = LenB(Expression)
    lngDelLen = LenB(Delimiter)
    ' validate lengths and limit (limit must be larger than 0 or it must be unlimited)
    If lngExpLen > 0 And lngDelLen > 0 And (Limit > 0 Or Limit = -1&) Then
        ' unlimited or limited?
        If Limit = -1& Then
            ' unlimited, reserve space for maximum possible amount of returned items
            lngCount = lngExpLen \ lngDelLen
        Else
            ' limited, reserve space for maximum wanted amount of returned items
            lngCount = Limit - 1
        End If
        ' data of found positions
        ReDim Preserve lngResults(0 To lngCount)
        ' now look up for the first position
        lngA = InStrB(1, Expression, Delimiter, Compare)
        ' InStrB is very fast, but it may give "between characters" results
        Do Until (lngA And 1) Or (lngA = 0)
            ' this is why we look for odd positions (1, 3, 5, 7 etc. are a valid position)
            lngA = InStrB(lngA + 1, Expression, Delimiter, Compare)
        Loop
        ' now work until maximum limit
        For lngCount = 0 To lngCount
            ' did we find anything?
            If lngA > 0 Then
                ' remember this position
                lngResults(lngCount) = lngA
                ' look for the next one
                lngA = InStrB(lngA + lngDelLen, Expression, Delimiter, Compare)
                Do Until (lngA And 1) Or (lngA = 0)
                    lngA = InStrB(lngA + 1, Expression, Delimiter, Compare)
                Loop
            Else
                ' we did not find the next string, we are done
                Exit For
            End If
        Next lngCount
        ' set results to actual findings
        ReDim Preserve ResultSplit(0 To lngCount)
        ' see if we found any results
        If lngCount = 0 Then
            ' nope, just set the only item to be the whole string
            ResultSplit(0) = Expression
        Else
            ' get the first item
            ResultSplit(0) = LeftB$(Expression, lngResults(0) - 1)
            ' get the other items except the last one
            For lngCount = 0 To lngCount - 2
                ResultSplit(lngCount + 1) = MidB$(Expression, lngResults(lngCount) + lngDelLen, lngResults(lngCount + 1) - lngResults(lngCount) - lngDelLen)
            Next lngCount
            ' get the last item
            ResultSplit(lngCount + 1) = RightB$(Expression, lngExpLen - lngResults(lngCount) - lngDelLen + 1)
        End If
    Else
        ' clean any possible data that exists in the passed string array (like if it is multidimensional)
        If Not Not ResultSplit Then Erase ResultSplit
        ' mysterious IDE error fix
        Debug.Assert App.hInstance
        ' reset to one element, one dimension
        ReDim ResultSplit(0 To 0)
        ' remove the item (this duplicates the VB6 Split behavior)
        SafeArrayRedim Not Not ResultSplit, SafeArrayBound(0)
    End If
End Sub

' Short, commented & fully VB5 compatible version of QuickSplitB at http://www.vbforums.com/showthread.php?t=540323
Public Sub QuickSplitB(Expression As String, ResultSplit() As String, Optional Delimiter As String = " ", Optional ByVal Limit As Long = -1)
    Static lngResults() As Long
    ' general variables that we need
    Dim lngA As Long, lngCount As Long, lngDelLen As Long, lngExpLen As Long
    ' some dummy variables that we happen to need
    Dim Compare As VbCompareMethod, SafeArrayBound(1) As Long
    ' length information
    lngExpLen = LenB(Expression)
    lngDelLen = LenB(Delimiter)
    ' validate lengths and limit (limit must be larger than 0 or it must be unlimited)
    If lngExpLen > 0 And lngDelLen > 0 And (Limit > 0 Or Limit = -1&) Then
        ' unlimited or limited?
        If Limit = -1& Then
            ' unlimited, reserve space for maximum possible amount of returned items
            lngCount = lngExpLen \ lngDelLen
        Else
            ' limited, reserve space for maximum wanted amount of returned items
            lngCount = Limit - 1
        End If
        ' data of found positions
        ReDim Preserve lngResults(0 To lngCount)
        ' now look up for the first position
        lngA = InStrB(1, Expression, Delimiter, Compare)
        ' now work until maximum limit
        For lngCount = 0 To lngCount
            ' did we find anything?
            If lngA > 0 Then
                ' remember this position
                lngResults(lngCount) = lngA
                ' look for the next one
                lngA = InStrB(lngA + lngDelLen, Expression, Delimiter, Compare)
            Else
                ' we did not find the next string, we are done
                Exit For
            End If
        Next lngCount
        ' set results to actual findings
        ReDim Preserve ResultSplit(0 To lngCount)
        ' see if we found any results
        If lngCount = 0 Then
            ' nope, just set the only item to be the whole string
            ResultSplit(0) = Expression
        Else
            ' get the first item
            ResultSplit(0) = LeftB$(Expression, lngResults(0) - 1)
            ' get the other items except the last one
            For lngCount = 0 To lngCount - 2
                ResultSplit(lngCount + 1) = MidB$(Expression, lngResults(lngCount) + lngDelLen, lngResults(lngCount + 1) - lngResults(lngCount) - lngDelLen)
            Next lngCount
            ' get the last item
            ResultSplit(lngCount + 1) = RightB$(Expression, lngExpLen - lngResults(lngCount) - lngDelLen + 1)
        End If
    Else
        ' clean any possible data that exists in the passed string array (like if it is multidimensional)
        If Not Not ResultSplit Then Erase ResultSplit
        ' mysterious IDE error fix
        Debug.Assert App.hInstance
        ' reset to one element, one dimension
        ReDim ResultSplit(0 To 0)
        ' remove the item (this duplicates the VB6 Split behavior)
        SafeArrayRedim Not Not ResultSplit, SafeArrayBound(0)
    End If
End Sub

I haven't perfectly tested these codes, but they appear to work the same.


Edit!
A screenshot showing some of the performance difference against Splits available over at VBspeed:




Edit #2!
One final addition... the longer the output strings in the array, the better QuickSplit does against what is available over at VBspeed: