Option Explicit
Private Const ArraySize = 99999
Private Const Delimiter = vbNewLine
Public Function FilterArray(pstrArray() As String, pstrFilter As String, pstrDelimiter As String)
Dim strDest() As String
Dim lngPos As Long
Dim i As Long
Dim iMin As Long
Dim iMax As Long
iMin = LBound(pstrArray)
iMax = UBound(pstrArray)
ReDim strDest(iMin To iMax)
lngPos = iMin
For i = iMin To iMax
If InStr(pstrArray(i), pstrFilter) <> 0 Then
strDest(lngPos) = pstrArray(i)
lngPos = lngPos + 1
End If
Next
ReDim Preserve strDest(iMin To lngPos - 1)
FilterArray = Join(strDest, pstrDelimiter)
Erase strDest
End Function
Public Function EllisBufferMethod(pstrArray() As String, pstrFilter As String, pstrDelimiter As String)
Dim strBuffer As String
Dim lngLen As Long
Dim lngPos As Long
Dim blnMatch() As Boolean
Dim i As Long
Dim iMin As Long
Dim iMax As Long
iMin = LBound(pstrArray)
iMax = UBound(pstrArray)
ReDim blnMatch(iMin To iMax)
For i = iMin To iMax
If InStr(pstrArray(i), pstrFilter) Then
lngLen = lngLen + Len(pstrArray(i)) + Len(pstrDelimiter)
blnMatch(i) = True
End If
Next
strBuffer = Space(lngLen + 1)
lngPos = 1
For i = iMin To iMax
If blnMatch(i) Then
Mid$(strBuffer, lngPos, Len(pstrArray(i))) = pstrArray(i)
lngPos = lngPos + Len(pstrArray(i))
Mid$(strBuffer, lngPos, Len(pstrDelimiter)) = pstrDelimiter
lngPos = lngPos + Len(pstrDelimiter)
End If
Next
EllisBufferMethod = Left$(strBuffer, lngLen - Len(pstrDelimiter))
strBuffer = ""
Erase blnMatch
End Function
Public Function LogoBufferMethod(pstrArray() As String, pstrFilter As String, pstrDelimiter As String)
Dim strBuffer As String ' The buffer
Dim lngBuffSize As Long ' Amount of space to buffer
Dim lngPos As Long ' Position within the buffer
Dim lngLen As Long ' Lenght of string to copy to buffer
Dim i As Long
Dim lngDelimiterLen As Long
' Try to pick a length that is 20% to 60% of the length of the final string.
' Too long wastes memory. Too short slows it down with extra extensions.
lngBuffSize = 80000 ' ~40%
' Set the initial size of the buffer
strBuffer = Space(lngBuffSize)
lngPos = 1
lngDelimiterLen = Len(pstrDelimiter)
For i = 0 To UBound(pstrArray) - 1
If InStr(pstrArray(i), pstrFilter) > 0 Then
lngLen = Len(pstrArray(i))
' Extend the length of the buffer for more space, if needed.
If lngPos + lngLen + lngDelimiterLen > Len(strBuffer) Then
strBuffer = strBuffer & Space(lngBuffSize + lngLen + lngDelimiterLen)
End If
' Copy the array element to the buffer.
Mid(strBuffer, lngPos, lngLen) = pstrArray(i)
lngPos = lngPos + lngLen
' Copy delimiter to the buffer.
Mid(strBuffer, lngPos, lngDelimiterLen) = pstrDelimiter
lngPos = lngPos + lngDelimiterLen
End If
Next i
' Copy the buffer to strMyString
LogoBufferMethod = Left$(strBuffer, lngPos - lngDelimiterLen - 1)
' Clear the buffer
strBuffer = ""
End Function
Private Sub Command1_Click()
Me.MousePointer = vbHourglass
Me.Text1.Text = Sample()
Me.MousePointer = vbNormal
End Sub
Public Function Sample() As String
Dim strArray(ArraySize) As String
Dim i As Long
Dim strOutput As String
Dim sngStart As Single
Dim strMessage As String
For i = 0 To ArraySize
strArray(i) = i
Next
' String concatenation
sngStart = Timer
For i = 0 To ArraySize
If InStr(strArray(i), "1") <> 0 Then strOutput = strOutput & strArray(i) & Delimiter
Next
strMessage = strMessage & "Concatenation: " & Format(Timer - sngStart, "0.000") & " seconds (" & Len(strOutput) & " characters)" & vbCrLf
strOutput = ""
' Logo's string buffer method
sngStart = Timer
strOutput = LogoBufferMethod(strArray, "1", Delimiter)
strMessage = strMessage & "Logo's buffer method: " & Format(Timer - sngStart, "0.000") & " seconds (" & Len(strOutput) & " characters)" & vbCrLf
strOutput = ""
' Ellis's string buffer method
sngStart = Timer
strOutput = EllisBufferMethod(strArray, "1", Delimiter)
strMessage = strMessage & "Ellis's buffer method: " & Format(Timer - sngStart, "0.000") & " seconds (" & Len(strOutput) & " characters)" & vbCrLf
strOutput = ""
' Join
sngStart = Timer
strOutput = FilterArray(strArray, "1", Delimiter)
strMessage = strMessage & "Join(): " & Format(Timer - sngStart, "0.000") & " seconds (" & Len(strOutput) & " characters)" & vbCrLf
strOutput = ""
' FIlter
sngStart = Timer
strOutput = Join(Filter(strArray, "1"), Delimiter)
strMessage = strMessage & "Filter(): " & Format(Timer - sngStart, "0.000") & " seconds (" & Len(strOutput) & " characters)" & vbCrLf
Sample = strMessage
End Function