Attribute VB_Name = "Strings" ' Strings.bas Option Explicit Public Enum SplitCompareMethod [Split BinaryCompare] = VbCompareMethod.vbBinaryCompare ' InStrB ' [Split TextCompare] = VbCompareMethod.vbTextCompare ' InStr(TextCompare) [Split CharacterCompare] = VbCompareMethod.vbDatabaseCompare ' InStr(BinaryCompare) End Enum Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long Private Declare Function InitStringArray Lib "oleaut32" Alias "SafeArrayCreate" (Optional ByVal VarType As VbVarType = vbString, Optional ByVal Dims As Integer = 1, Optional saBound As Currency) As Long Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal Ptr As Long, ByVal Length As Long) As Long Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long) ' API Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long ' Property Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Ptr As Long, Value As Long) Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long Private m_A() As Long Private m_AP As Long Private m_H(0 To 6) As Long Private m_HP As Long Public Function AllocString(ByVal Ptr As Long, ByVal Length As Long) As String Procedure(AddressOf Strings.AllocString) = API("oleaut32", "SysAllocStringByteLen") AllocString = Strings.AllocString(Ptr, Length) End Function Private Property Get API(Module As String, Procedure As String) As Long Dim Handle As Long Handle = GetModuleHandle(Module) If Handle = 0 Then Handle = LoadLibrary(Module) If Handle Then API = GetProcAddress(Handle, Procedure) End Property Private Function InIDE(Optional IDE) As Boolean If IsMissing(IDE) Then Debug.Assert Not InIDE(InIDE) Else IDE = True End Function Private Property Get Procedure(ByVal AddressOfDest As Long) As Long ' get correct pointer to procedure in IDE If Not InIDE Then Procedure = AddressOfDest Else GetMem4 AddressOfDest + &H16&, Procedure End Property Private Property Let Procedure(ByVal AddressOfDest As Long, ByVal AddressOfSrc As Long) Dim JMP As Currency, PID As Long ' get process handle PID = OpenProcess(&H1F0FFF, 0&, GetCurrentProcessId) If PID Then ' get correct pointer to procedure in IDE If InIDE Then GetMem4 AddressOfDest + &H16&, AddressOfDest Debug.Assert App.hInstance ' ASM JMP (0xE9) followed by bytes to jump in memory JMP = (&HE9& * 0.0001@) + (AddressOfSrc - AddressOfDest - 5@) * 0.0256@ ' write the JMP over the destination procedure WriteProcessMemory PID, ByVal AddressOfDest, JMP, 5 ' close process handle CloseHandle PID End If End Property Public Function Join(SourceArray() As String, Optional Delimiter As String = " ") As String ' is it possible to use too many safe array hacks? Static HI1(0 To 6) As Long, HPI1 As Long Static HI2(0 To 6) As Long, HPI2 As Long Static HL1(0 To 6) As Long, HPL1 As Long Static HL2(0 To 6) As Long, HPL2 As Long Static HL3(0 To 6) As Long, HPL3 As Long Static HL4(0 To 6) As Long, HPL4 As Long Static HS(0 To 6) As Long, HPS As Long Static HSI(0 To 6) As Long, HPSI As Long Static HSL(0 To 6) As Long, HPSL As Long ' it looks like not! Dim I1() As Integer, API1 As Long Dim I2() As Integer, API2 As Long Dim L1() As Long, APL1 As Long Dim L2() As Long, APL2 As Long Dim L3() As Long, APL3 As Long Dim L4() As Long, APL4 As Long Dim S() As Long, APS As Long Dim SI() As Integer, APSI As Long Dim SL() As Long, APSL As Long ' delimiter optimizations Dim DI1 As Integer, DL1 As Long, DL2 As Long, DL3 As Long, DL4 As Long ' regular variables are nice too Dim J As Long, L As Long, LD As Long, PC As Long, PD As Long, T As Long, US As Long Dim P As Long, PI As Long, PL As Long, PS As Long, Ptr As Long ' Goto... Dim ReturnTo As Long ' has the array been initialized in the first place? P = Not Not SourceArray Debug.Assert App.hInstance If P Then ' must be zero base If LBound(SourceArray) Then Exit Function ' upper bound check... US = UBound(SourceArray) Select Case US ' must have at least one element! Case -1: Exit Function ' only one element? Case 0: Join = SourceArray(0): Exit Function End Select ' calculate total length For J = 0 To US T = T + LenB(SourceArray(J)) Next J ' get delimiter length LD = LenB(Delimiter) ' because you can be crazy on optimizing performance... including rare special cases If T Then ' add delimiters' length to total length If LD Then T = T + LD * US ElseIf LD = 2 Then ' single character replicate Join = String$(US, Delimiter) ElseIf LD Then ' half character or multicharacter replicate Join = AllocString(0, LD * US) P = 1 ' join the first four bytes and until we have even length Do MidB$(Join, P, LD) = Delimiter P = P + LD ' make also sure we do not run out of the string space Loop While (P <= LenB(Join)) And ((P < 4) Or (P And 1) = 0) ' now use a faster replicate for the rest If P <= LenB(Join) Then MidB$(Join, P) = Join End If ' so do we join? If T Then ' generic safe array hack If m_AP = 0 Then ' array variable pointer m_AP = ArrPtr(m_A) ' create a safe array header m_H(0) = vbLong: m_H(1) = &H800001: m_H(2) = 4: m_H(5) = &H7FFFFFFF ' header pointer m_HP = VarPtr(m_H(1)) End If ' set pointer to array PutLong m_AP, m_HP ' local safe array hack API1 = ArrPtr(I1) API2 = ArrPtr(I2) APL1 = ArrPtr(L1) APL2 = ArrPtr(L2) APL3 = ArrPtr(L3) APL4 = ArrPtr(L4) APS = ArrPtr(S) APSI = ArrPtr(SI) APSL = ArrPtr(SL) If HPS = 0 Then ' Join string HI1(0) = vbInteger: HI1(1) = &H800001: HI1(2) = 2: HI1(5) = &H7FFFFFFF HI2(0) = vbInteger: HI2(1) = &H800001: HI2(2) = 2: HI2(5) = &H7FFFFFFF HL1(0) = vbLong: HL1(1) = &H800001: HL1(2) = 4: HL1(5) = &H3FFFFFFF HL2(0) = vbLong: HL2(1) = &H800001: HL2(2) = 4: HL2(5) = &H3FFFFFFF HL3(0) = vbLong: HL3(1) = &H800001: HL3(2) = 4: HL3(5) = &H3FFFFFFF HL4(0) = vbLong: HL4(1) = &H800001: HL4(2) = 4: HL4(5) = &H3FFFFFFF ' string pointers HS(0) = vbLong: HS(1) = &H800001: HS(2) = 4 ' SourceArray's current string HSI(0) = vbInteger: HSI(1) = &H800001: HSI(2) = 2: HSI(5) = &H7FFFFFFF HSL(0) = vbLong: HSL(1) = &H800001: HSL(2) = 4: HSL(5) = &H3FFFFFFF HPI1 = VarPtr(HI1(1)) HPI2 = VarPtr(HI2(1)) HPL1 = VarPtr(HL1(1)) HPL2 = VarPtr(HL2(1)) HPL3 = VarPtr(HL3(1)) HPL4 = VarPtr(HL4(1)) HPS = VarPtr(HS(1)) HPSI = VarPtr(HSI(1)) HPSL = VarPtr(HSL(1)) End If ' allocate string Join = AllocString(0, T) Ptr = StrPtr(Join) ' update S to point to SourceArray HS(4) = VarPtr(SourceArray(0)): HS(5) = US + 1 ' update array pointers HI1(4) = Ptr HI2(4) = Ptr + 1 HL1(4) = Ptr HL2(4) = Ptr + 1 HL3(4) = Ptr + 2 HL4(4) = Ptr + 3 ' start safe array hack for local arrays m_H(4) = API1: m_A(0) = HPI1 m_H(4) = API2: m_A(0) = HPI2 m_H(4) = APL1: m_A(0) = HPL1 m_H(4) = APL2: m_A(0) = HPL2 m_H(4) = APL3: m_A(0) = HPL3 m_H(4) = APL4: m_A(0) = HPL4 m_H(4) = APS: m_A(0) = HPS m_H(4) = APSI: m_A(0) = HPSI m_H(4) = APSL: m_A(0) = HPSL ' zero position P = 0 PD = StrPtr(Delimiter) ' delimiter length? Select Case LD Case Is > 16 GoTo Over8 ' optimized zero length join Case 0 ReturnTo = 0 For J = 0 To US ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 0: End If Next J Case 1, 2 HSI(4) = PD DI1 = SI(0) ReturnTo = 1 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 1: End If ' copy delimiter PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = DI1 Case 1: I2(PI) = DI1 End Select ' update position P = P + LD Next J Case 3, 4 m_H(4) = PD DL1 = m_A(0) ReturnTo = 2 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 2: End If ' copy delimiter PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = DL1 Case 2: L3(PL) = DL1 Case 1: L2(PL) = DL1 Case 3: L4(PL) = DL1 End Select ' update position P = P + LD Next J Case 5, 6 HSI(4) = PD DI1 = SI(0) m_H(4) = PD + 2 DL1 = m_A(0) ReturnTo = 3 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 3: End If ' copy delimiter PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = DI1 Case 1: I2(PI) = DI1 End Select PL = (P + 2) \ 4 Select Case P And 3 Case 2: L1(PL) = DL1 Case 0: L3(PL) = DL1 Case 3: L2(PL) = DL1 Case 1: L4(PL) = DL1 End Select ' update position P = P + LD Next J Case 7, 8 m_H(4) = PD DL1 = m_A(0) DL2 = m_A(1) ReturnTo = 4 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 4: End If ' copy delimiter PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = DL1: L1(PL + 1) = DL2 Case 2: L3(PL) = DL1: L3(PL + 1) = DL2 Case 1: L2(PL) = DL1: L2(PL + 1) = DL2 Case 3: L4(PL) = DL1: L4(PL + 1) = DL2 End Select ' update position P = P + LD Next J Case 9, 10 HSI(4) = PD DI1 = SI(0) m_H(4) = PD + 2 DL1 = m_A(0) DL2 = m_A(1) ReturnTo = 5 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 5: End If ' copy delimiter PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = DI1 Case 1: I2(PI) = DI1 End Select PL = (P + 2) \ 4 Select Case P And 3 Case 2: L1(PL) = DL1: L1(PL + 1) = DL2 Case 0: L3(PL) = DL1: L3(PL + 1) = DL2 Case 3: L2(PL) = DL1: L2(PL + 1) = DL2 Case 1: L4(PL) = DL1: L4(PL + 1) = DL2 End Select ' update position P = P + LD Next J Case 11, 12 m_H(4) = PD DL1 = m_A(0) DL2 = m_A(1) DL3 = m_A(2) ReturnTo = 6 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 6: End If ' copy delimiter PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = DL1: L1(PL + 1) = DL2: L1(PL + 2) = DL3 Case 2: L3(PL) = DL1: L3(PL + 1) = DL2: L3(PL + 2) = DL3 Case 1: L2(PL) = DL1: L2(PL + 1) = DL2: L2(PL + 2) = DL3 Case 3: L4(PL) = DL1: L4(PL + 1) = DL2: L4(PL + 2) = DL3 End Select ' update position P = P + LD Next J Case 13, 14 HSI(4) = PD DI1 = SI(0) m_H(4) = PD + 2 DL1 = m_A(0) DL2 = m_A(1) DL3 = m_A(2) ReturnTo = 7 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 7: End If ' copy delimiter PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = DI1 Case 1: I2(PI) = DI1 End Select PL = (P + 2) \ 4 Select Case P And 3 Case 2: L1(PL) = DL1: L1(PL + 1) = DL2: L1(PL + 2) = DL3 Case 0: L3(PL) = DL1: L3(PL + 1) = DL2: L3(PL + 2) = DL3 Case 3: L2(PL) = DL1: L2(PL + 1) = DL2: L2(PL + 2) = DL3 Case 1: L4(PL) = DL1: L4(PL + 1) = DL2: L4(PL + 2) = DL3 End Select ' update position P = P + LD Next J Case 15, 16 m_H(4) = PD DL1 = m_A(0) DL2 = m_A(1) DL3 = m_A(2) DL4 = m_A(3) ReturnTo = 8 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 8: End If ' copy delimiter PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = DL1: L1(PL + 1) = DL2: L1(PL + 2) = DL3: L1(PL + 3) = DL4 Case 2: L3(PL) = DL1: L3(PL + 1) = DL2: L3(PL + 2) = DL3: L3(PL + 3) = DL4 Case 1: L2(PL) = DL1: L2(PL + 1) = DL2: L2(PL + 2) = DL3: L2(PL + 3) = DL4 Case 3: L4(PL) = DL1: L4(PL + 1) = DL2: L4(PL + 2) = DL3: L4(PL + 3) = DL4 End Select ' update position P = P + LD Next J Case Else Over8: ReturnTo = 9 For J = 0 To US - 1 ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ' copy from StringArray GoTo CopyRoutine 9: End If ' copy delimiter rtlMove Ptr + P, PD, LD ' update position P = P + LD Next J End Select ' last copy? If J = US Then ' current length L = LenB(SourceArray(J)) If L Then ' current pointer PC = S(J) ReturnTo = 10 ' copy from StringArray (last item) GoTo CopyRoutine 10: End If End If ' end safe array hacks m_H(4) = API1: m_A(0) = 0 m_H(4) = API2: m_A(0) = 0 m_H(4) = APL1: m_A(0) = 0 m_H(4) = APL2: m_A(0) = 0 m_H(4) = APL3: m_A(0) = 0 m_H(4) = APL4: m_A(0) = 0 m_H(4) = APS: m_A(0) = 0 m_H(4) = APSI: m_A(0) = 0 m_H(4) = APSL: m_A(0) = 0 m_H(4) = m_AP: m_A(0) = 0 End If End If Exit Function CopyRoutine: Select Case L Case Is > 16 rtlMove Ptr + P, PC, L GoTo ReturnPoint Case 1, 2 HSI(4) = PC PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = SI(0) Case 1: I2(PI) = SI(0) End Select GoTo ReturnPoint Case 3, 4 HSL(4) = PC PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = SL(0) Case 2: L3(PL) = SL(0) Case 1: L2(PL) = SL(0) Case 3: L4(PL) = SL(0) End Select GoTo ReturnPoint Case 5, 6 HSI(4) = PC PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = SI(0): I1(PI + 1) = SI(1): I1(PI + 2) = SI(2) Case 1: I2(PI) = SI(0): I2(PI + 1) = SI(1): I2(PI + 2) = SI(2) End Select GoTo ReturnPoint Case 7, 8 HSL(4) = PC PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = SL(0): L1(PL + 1) = SL(1) Case 2: L3(PL) = SL(0): L3(PL + 1) = SL(1) Case 1: L2(PL) = SL(0): L2(PL + 1) = SL(1) Case 3: L4(PL) = SL(0): L4(PL + 1) = SL(1) End Select GoTo ReturnPoint Case 9, 10 HSI(4) = PC PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = SI(0) Case 1: I2(PI) = SI(0) End Select HSL(4) = PC + 2 PL = (P + 2) \ 4 Select Case (P + 2) And 3 Case 0: L1(PL) = SL(0): L1(PL + 1) = SL(1) Case 2: L3(PL) = SL(0): L3(PL + 1) = SL(1) Case 1: L2(PL) = SL(0): L2(PL + 1) = SL(1) Case 3: L4(PL) = SL(0): L4(PL + 1) = SL(1) End Select GoTo ReturnPoint Case 11, 12 HSL(4) = PC PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = SL(0): L1(PL + 1) = SL(1): L1(PL + 2) = SL(2) Case 2: L3(PL) = SL(0): L3(PL + 1) = SL(1): L3(PL + 2) = SL(2) Case 1: L2(PL) = SL(0): L2(PL + 1) = SL(1): L2(PL + 2) = SL(2) Case 3: L4(PL) = SL(0): L4(PL + 1) = SL(1): L4(PL + 2) = SL(2) End Select GoTo ReturnPoint Case 13, 14 HSI(4) = PC PI = P \ 2 Select Case P And 1 Case 0: I1(PI) = SI(0) Case 1: I2(PI) = SI(0) End Select HSL(4) = PC + 2 PL = (P + 2) \ 4 Select Case (P + 2) And 3 Case 0: L1(PL) = SL(0): L1(PL + 1) = SL(1): L1(PL + 2) = SL(2) Case 2: L3(PL) = SL(0): L3(PL + 1) = SL(1): L3(PL + 2) = SL(2) Case 1: L2(PL) = SL(0): L2(PL + 1) = SL(1): L2(PL + 2) = SL(2) Case 3: L4(PL) = SL(0): L4(PL + 1) = SL(1): L4(PL + 2) = SL(2) End Select GoTo ReturnPoint Case 15, 16 HSL(4) = PC PL = P \ 4 Select Case P And 3 Case 0: L1(PL) = SL(0): L1(PL + 1) = SL(1): L1(PL + 2) = SL(2): L1(PL + 3) = SL(3) Case 2: L3(PL) = SL(0): L3(PL + 1) = SL(1): L3(PL + 2) = SL(2): L3(PL + 3) = SL(3) Case 1: L2(PL) = SL(0): L2(PL + 1) = SL(1): L2(PL + 2) = SL(2): L2(PL + 3) = SL(3) Case 3: L4(PL) = SL(0): L4(PL + 1) = SL(1): L4(PL + 2) = SL(2): L4(PL + 3) = SL(3) End Select GoTo ReturnPoint End Select ReturnPoint: ' update position P = P + L ' where we go back? Select Case ReturnTo Case 0: GoTo 0: Case 1: GoTo 1: Case 2: GoTo 2: Case 3: GoTo 3 Case 4: GoTo 4: Case 5: GoTo 5: Case 6: GoTo 6: Case 7: GoTo 7 Case 8: GoTo 8: Case 9: GoTo 9: Case 10: GoTo 10 End Select End Function Public Function Replace(Expression As String, Find As String, ReplaceWith As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = -1, Optional ByVal Compare As VbCompareMethod) As String Static P() As Long Dim CF As Long, CR As Long, CFmask As Long, CRmask As Long, UF As Long, UR As Long Dim PtrE As Long, PtrR As Long, PtrN As Long Dim C As Long, I As Long, J As Long, K As Long, L As Long, M As Long, PC As Long, PL As Long Dim LE As Long, LF As Long, LR As Long, S As Boolean ' length information LE = LenB(Expression) LF = LenB(Find) LR = LenB(ReplaceWith) ' validate start Start = Start * 2 If Start < 0 Then Start = LE + Start + 1 If Start < 1 Or Start > LE Then Exit Function ' validate lengths and limit If LE > 0 And LF > 0 And Count >= -1 Then If Count = -1 Then Count = LE \ LF Else Count = Count - 1 Else Count = -1 End If ' can we go on? If Count >= 0 Then End If End Function Public Function Split(Expression As String, Optional Delimiter As String = " ", Optional ByVal Limit As Long = -1, Optional ByVal Compare As SplitCompareMethod) As String() Procedure(AddressOf Strings.Split) = Procedure(AddressOf Strings.z_Split) Split = Strings.Split(Expression, Delimiter, Limit, Compare) End Function Public Function z_Split(Expression As String, Optional Delimiter As String = " ", Optional ByVal Limit As Long = -1, Optional ByVal Compare As SplitCompareMethod) As Long ' general variables that we need Static R() As Long, RP As Long Dim P() As Long Dim C As Long, I As Long, J As Long, K As Long, LD As Long, LD2 As Long, LE As Long, PL As Long, PS As Long ' get pointer PS = StrPtr(Expression) ' length information LE = LenB(Expression) LD = LenB(Delimiter) ' unlimited or limited? If Limit = -1 Then If LD Then Limit = LE \ LD + 1 ' validate lengths and limit If LE > 0 And LD > 0 And Limit >= 0 Then ' pointer to R array If RP = 0 Then RP = ArrPtr(R) ' generic safe array hack If m_AP = 0 Then ' array variable pointer m_AP = ArrPtr(m_A) ' create a safe array header m_H(0) = vbLong: m_H(1) = &H800001: m_H(2) = 4: m_H(5) = &H7FFFFFFF ' header pointer m_HP = VarPtr(m_H(1)) End If ' set pointer to array PutLong m_AP, m_HP ' find the first item If Limit > 1 Then If Compare = [Split BinaryCompare] Then Do: I = InStrB(I + 1, Expression, Delimiter) Loop Until (I And 1) = 1 Or (I = 0) Else I = InStr(Expression, Delimiter) End If End If ' did we find an item? If I Then ReDim P(3) As Long ' space for knowing the positions PL = (Limit \ 96) If PL > 8191 Then PL = 8191 If PL > UBound(P) Then ReDim Preserve P(0 To PL) ' InStrB? If Compare = [Split BinaryCompare] Then For C = 0 To Limit ' make sure will always have enough items If C >= PL Then PL = PL + C: ReDim Preserve P(PL) ' exit if nothing found If I = 0 Then Exit For ' remember position P(C) = I - 1 ' find next I = I + LD - 1 Do: I = InStrB(I + 1, Expression, Delimiter) Loop Until (I And 1) = 1 Or (I = 0) Next C Else ' InStr LD2 = LD \ 2 For C = 0 To Limit ' make sure will always have enough items If C >= PL Then PL = PL + C: ReDim Preserve P(PL) ' exit if nothing found If I = 0 Then Exit For ' remember position P(C) = (I - 1) * 2 ' find next I = InStr(I + LD2, Expression, Delimiter) Next C End If P(C) = LE ' make space for the new items z_Split = InitStringArray(, , (C + 1) * 0.0001@) ' set pointer m_H(4) = RP: m_A(0) = z_Split ' keep it simple, stupid! I = 0 For C = 0 To C K = P(C) J = K - I If J Then R(C) = SysAllocStringByteLen(PS + I, J) I = K + LD Next C Else ' one item z_Split = InitStringArray(, , 0.0001@) ' set pointer m_H(4) = RP: m_A(0) = z_Split R(0) = SysAllocStringByteLen(PS, LE) End If ' clean up z_Split reference m_A(0) = 0 ' clean up safe array reference m_H(4) = m_AP: m_A(0) = 0 Else z_Split = InitStringArray End If End Function ' btw, this would be fastest for VB5... as VB6 DLL is always available in Windows these days 'Public Function StrReverse(Expression As String) As String ' Procedure(AddressOf Strings.StrReverse) = API("msvbvm60", "rtcStrReverse") ' StrReverse = Strings.StrReverse(Expression) 'End Function Public Function StrReverse(Expression As String, Optional ByVal AllCharBelow0x8000 As Boolean = True) As String Static HE(0 To 6) As Long, HS(0 To 6) As Long, HPE As Long, HPS As Long Dim E() As Integer, S() As Long, APE As Long, APS As Long Dim C1 As Integer, C2 As Integer, C1L As Long, C2L As Long, I As Long, L As Long, M As Long, M2 As Long, U As Long ' length (ignore half character) L = LenB(Expression) And Not 1 If L Then ' generic safe array hack If m_AP = 0 Then ' array variable pointer m_AP = ArrPtr(m_A) ' create a safe array header m_H(0) = vbLong: m_H(1) = &H800001: m_H(2) = 4: m_H(5) = &H7FFFFFFF ' header pointer m_HP = VarPtr(m_H(1)) End If ' set pointer to array PutLong m_AP, m_HP ' local safe array hack APE = ArrPtr(E) APS = ArrPtr(S) If HPE = 0 Then HE(0) = vbInteger: HE(1) = &H910001: HE(2) = 2: HE(5) = &H7FFFFFFF HS(0) = vbLong: HS(1) = &H910001: HS(2) = 4: HS(5) = &H7FFFFFFF HPE = VarPtr(HE(1)) HPS = VarPtr(HS(1)) End If ' ubound U = L \ 4 - 1 ' allocate output string StrReverse = AllocString(0, L) HE(4) = StrPtr(Expression) HS(4) = StrPtr(StrReverse) ' start safe array hack m_H(4) = APE: m_A(0) = HPE m_H(4) = APS: m_A(0) = HPS ' first character in odd length strings If L Mod 4 Then S(0) = E(L \ 2 - 1) And &HFFFF& HS(4) = HS(4) + 2 End If ' simple loop If AllCharBelow0x8000 Then For M = U To 0 Step -1 M2 = M * 2 S(U - M) = E(M2) * &H10000 Or E(M2 + 1) Next M Else For M = U To 0 Step -1 M2 = M * 2 C1 = E(M2) C2 = E(M2 + 1) S(U - M) = &H80000000 * ((C1 And &H8000&) \ &H8000&) Or (C1 And &H7FFF&) * &H10000 Or (C2 And &HFFFF&) Next M End If ' end safe array hack m_H(4) = APE: m_A(0) = 0 m_H(4) = APS: m_A(0) = 0 m_H(4) = m_AP: m_A(0) = 0 End If End Function 'Public Sub GetByte(ByVal Ptr As Long, Value As Byte) ' Procedure(AddressOf Strings.GetByte) = API("msvbvm60", "GetMem1") ' GetByte Ptr, Value 'End Sub 'Public Sub GetInteger(ByVal Ptr As Long, Value As Integer) ' Procedure(AddressOf Strings.GetInteger) = API("msvbvm60", "GetMem2") ' GetInteger Ptr, Value 'End Sub 'Public Sub GetLong(ByVal Ptr As Long, Value As Long) ' Procedure(AddressOf Strings.GetLong) = API("msvbvm60", "GetMem4") ' GetLong Ptr, Value 'End Sub 'Public Sub GetCurrency(ByVal Ptr As Long, Value As Currency) ' Procedure(AddressOf Strings.GetCurrency) = API("msvbvm60", "GetMem8") ' GetCurrency Ptr, Value 'End Sub Public Sub PutLong(ByVal Ptr As Long, ByVal Value As Long) Procedure(AddressOf Strings.PutLong) = API("msvbvm60", "PutMem4") PutLong Ptr, Value End Sub 'Public Sub PutLong2(ByVal Ptr As Long, ByVal Value As Long) ' Procedure(AddressOf Strings.PutLong2) = Procedure(AddressOf Strings.z_PutLong) ' PutLong2 Ptr, Value 'End Sub 'Public Sub z_PutLong(Ptr As Long, ByVal Value As Long) ' Ptr = Value 'End Sub Public Sub rtlMove(ByVal Dest As Long, ByVal Src As Long, ByVal Length As Long) Procedure(AddressOf Strings.rtlMove) = API("kernel32", "RtlMoveMemory") rtlMove Dest, Src, Length End Sub 'Public Sub rtlStringToPtr(ByVal Dest As Long, ByVal Src As String, ByVal Length As Long) ' Procedure(AddressOf Strings.rtlStringToPtr) = API("kernel32", "RtlMoveMemory") ' rtlStringToPtr Dest, Src, Length 'End Sub