Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Dst As Any, Src As Any, ByVal iLen&)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
(dst As Any, ByVal iLen&)
Public Function SplitA02( _
Expression As String, _
Optional Delimiter As String = " ", _
Optional Count As Long = -1, _
Optional Compare As VbCompareMethod = vbBinaryCompare)
' by G.Beckmann, G.Beckmann@NikoCity.de
Const ARR_CHUNK& = 1024
Dim pArr&, pResult&, asResult$()
Dim iLen&, cHits&, iLast&, iCur&
If Count <> 0 Then
iLen = Len(Delimiter)
ReDim asResult(ARR_CHUNK)
If iLen <> 0 Then
iLast = 1
iCur = InStr(iLast, Expression, Delimiter, Compare)
Do While iCur
If cHits + 1 = Count Then Exit Do
asResult(cHits) = Mid$(Expression, iLast, iCur - iLast)
iLast = iCur + iLen: cHits = cHits + 1
iCur = InStr(iLast, Expression, Delimiter, Compare)
If cHits > UBound(asResult) Then
ReDim Preserve asResult(cHits + ARR_CHUNK - 1)
End If
Loop
asResult(cHits) = Mid$(Expression, iLast)
Else
asResult(0) = Expression
End If
End If
ReDim Preserve asResult(cHits) ' shrink to actual size
'/ delivery an array without duplication
pResult = VarPtr(SplitA02)
CopyMemory ByVal pResult, &H2008, 2 ' initialize (Variant/String())
pArr = StrArrPtr(asResult) ' get array-pointer
CopyMemory ByVal pResult + 8, ByVal pArr, 4 ' copy safearray-pointer
ZeroMemory ByVal pArr, 4 ' delete safearray-pointer
End Function
Private Function StrArrPtr&(v)
CopyMemory StrArrPtr, ByVal VarPtr(v) + 8, 4
End Function
|