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

' 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

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
    Dim D1 As Byte, D2 As Integer, D2b As Integer, D2c As Integer, D2d As Integer, D2e As Integer, D2f As Integer, D2g As Integer
    Dim D4 As Long, D4b As Long, D4c As Long
    Dim D8 As Currency, D8b As Currency, D8c As Currency, D8d As Currency
    Dim HJ1(0 To 6) As Long, J1() As Byte
    Dim HJ2(0 To 6) As Long, J2() As Integer
    Dim HJ4(0 To 6) As Long, J4() As Long, V4 As Long
    Dim HJ8(0 To 6) As Long, J8() As Currency, V8 As Currency, V16 As Currency
    Dim I As Long, L As Long, LD As Long, P As Long, PJ As Long, T As Long, US As Long
    Dim ReturnTo As Long
    P = Not Not SourceArray
    Debug.Assert App.hInstance
    If P Then
        US = UBound(SourceArray)
        If US < 0 Or LBound(SourceArray) <> 0 Then Exit Function
        LD = LenB(Delimiter)
        If LD Then T = LD * US
        For I = 0 To US
            T = T + LenB(SourceArray(I))
        Next I
        If T Then
            Join = AllocString(0, T)
            If LenB(Join) <> T Then Exit Function
            PJ = StrPtr(Join)
            HJ1(1) = &H800001: HJ1(5) = 1
            HJ2(1) = &H800001: HJ2(5) = 7
            HJ4(1) = &H800001: HJ4(5) = 3
            HJ8(1) = &H800001: HJ8(5) = 4
            HJ1(2) = 1: HJ1(0) = vbByte
            HJ2(2) = 2: HJ2(0) = vbInteger
            HJ4(2) = 4: HJ4(0) = vbLong
            HJ8(2) = 8: HJ8(0) = vbCurrency
            PutLong ArrPtr(J1), VarPtr(HJ1(1))
            PutLong ArrPtr(J2), VarPtr(HJ2(1))
            PutLong ArrPtr(J4), VarPtr(HJ4(1))
            PutLong ArrPtr(J8), VarPtr(HJ8(1))
            P = PJ
            T = 0
            Select Case LD
            Case 0
                ReturnTo = 0
                For I = 0 To US - 1
                    GoTo SourceToJoin
0:                  P = P + L
                Next I
            Case 1
                D1 = AscB(Delimiter)
                ReturnTo = 1
                For I = 0 To US - 1
                    GoTo SourceToJoin
1:                  P = P + L
                    HJ1(4) = P
                    J1(0) = D1
                    P = P + LD
                Next I
            Case 2
                D2 = AscW(Delimiter)
                ReturnTo = 2
                For I = 0 To US - 1
                    GoTo SourceToJoin
2:                  P = P + L
                    HJ2(4) = P
                    J2(0) = D2
                    P = P + LD
                Next I
            Case 3, 4
                GetLong StrPtr(Delimiter), D4
                ReturnTo = 4
                For I = 0 To US - 1
                    GoTo SourceToJoin
4:                  P = P + L
                    HJ4(4) = P
                    J4(0) = D4
                    P = P + LD
                Next I
            Case 5
                D2 = AscW(Delimiter)
                GetLong StrPtr(Delimiter) + 2, D4
                ReturnTo = 6
                For I = 0 To US - 1
                    GoTo SourceToJoin
6:                  P = P + L
                    HJ2(4) = P
                    J2(0) = D2
                    HJ4(4) = P + 2
                    J4(0) = D4
                    P = P + LD
                Next I
            Case 6, 7, 8
                GetCurrency StrPtr(Delimiter), D8
                ReturnTo = 8
                For I = 0 To US - 1
                    GoTo SourceToJoin
8:                  P = P + L
                    HJ8(4) = P
                    J8(0) = D8
                    P = P + LD
                Next I
            Case 9
                D2 = AscW(Delimiter)
                GetCurrency StrPtr(Delimiter) + 2, D8
                ReturnTo = 10
                For I = 0 To US - 1
                    GoTo SourceToJoin
10:                 P = P + L
                    HJ2(4) = P
                    J2(0) = D2
                    HJ8(4) = P + 2
                    J8(0) = D8
                    P = P + LD
                Next I
            Case 10, 11, 12
                T = StrPtr(Delimiter)
                GetLong T, D4
                GetLong T + 4, D4b
                GetLong T + 8, D4c
                ReturnTo = 12
                For I = 0 To US - 1
                    GoTo SourceToJoin
12:                 P = P + L
                    HJ4(4) = P
                    J4(0) = D4
                    J4(1) = D4b
                    J4(2) = D4c
                    P = P + LD
                Next I
            Case 13
                D2 = AscW(Delimiter)
                T = StrPtr(Delimiter)
                GetInteger T + 2, D2b
                GetInteger T + 4, D2c
                GetInteger T + 6, D2d
                GetInteger T + 8, D2e
                GetInteger T + 10, D2f
                GetInteger T + 12, D2g
                ReturnTo = 14
                For I = 0 To US - 1
                    GoTo SourceToJoin
14:                 P = P + L
                    HJ2(4) = P
                    J2(0) = D2
                    J2(1) = D2b
                    J2(2) = D2c
                    J2(3) = D2d
                    J2(4) = D2e
                    J2(5) = D2f
                    J2(6) = D2g
                    P = P + LD
                Next I
            Case 14, 15, 16
                T = StrPtr(Delimiter)
                GetCurrency T, D8
                GetCurrency T + 8, D8b
                HJ8(5) = 2
                ReturnTo = 16
                For I = 0 To US - 1
                    GoTo SourceToJoin
16:                 P = P + L
                    HJ8(4) = P
                    J8(0) = D8
                    J8(1) = D8b
                    P = P + LD
                Next I
            Case 22, 23, 24
                T = StrPtr(Delimiter)
                GetCurrency T, D8
                GetCurrency T + 8, D8b
                GetCurrency T + 16, D8c
                ReturnTo = 24
                For I = 0 To US - 1
                    GoTo SourceToJoin
24:                 P = P + L
                    HJ8(4) = P
                    J8(0) = D8
                    J8(1) = D8b
                    J8(2) = D8c
                    P = P + LD
                Next I
            Case 30, 31, 32
                T = StrPtr(Delimiter)
                GetCurrency T, D8
                GetCurrency T + 8, D8b
                GetCurrency T + 16, D8c
                GetCurrency T + 24, D8d
                ReturnTo = 32
                For I = 0 To US - 1
                    GoTo SourceToJoin
32:                 P = P + L
                    HJ8(4) = P
                    J8(0) = D8
                    J8(1) = D8b
                    J8(2) = D8c
                    J8(3) = D8d
                    P = P + LD
                Next I
            Case Else
                ReturnTo = 33
                For I = 0 To US - 1
                    GoTo SourceToJoin
33:                 P = P + L
                    rtlStringToPtr P, Delimiter, LD: P = P + LD
                Next I
            End Select
            ReturnTo = 34
            GoTo SourceToJoin
34:         PutLong ArrPtr(J1), 0
            PutLong ArrPtr(J2), 0
            PutLong ArrPtr(J4), 0
            PutLong ArrPtr(J8), 0
        End If
    End If
    Exit Function
SourceToJoin:
    L = LenB(SourceArray(I))
    Select Case L
    Case 0
    Case 2
        HJ2(4) = P: J2(0) = AscW(SourceArray(I))
    Case 1
        HJ1(4) = P: J1(0) = AscB(SourceArray(I))
    Case 4
        HJ4(4) = StrPtr(SourceArray(I))
        V4 = J4(0)
        HJ4(4) = P
        J4(0) = V4
    Case 6
        HJ2(4) = P: J2(0) = AscW(SourceArray(I))
        HJ4(4) = StrPtr(SourceArray(I)) + 2
        V4 = J4(0)
        HJ4(4) = P + 2
        J4(0) = V4
    Case 8
        HJ8(4) = StrPtr(SourceArray(I))
        V8 = J8(0)
        HJ8(4) = P
        J8(0) = V8
    Case 10
        HJ2(4) = P: J2(0) = AscW(SourceArray(I))
        HJ8(4) = StrPtr(SourceArray(I)) + 2
        V8 = J8(0)
        HJ8(4) = P + 2
        J8(0) = V8
    Case 12
        T = StrPtr(SourceArray(I))
        HJ8(4) = T
        V8 = J8(0)
        HJ8(4) = P
        J8(0) = V8
        HJ4(4) = T + 8
        V4 = J4(0)
        HJ4(4) = P + 8
        J4(0) = V4
    Case 14
        HJ2(4) = P: J2(0) = AscW(SourceArray(I))
        T = StrPtr(SourceArray(I))
        HJ8(4) = T + 2
        V8 = J8(0)
        HJ8(4) = P + 2
        J8(0) = V8
        HJ4(4) = T + 10
        V4 = J4(0)
        HJ4(4) = P + 10
        J4(0) = V4
    Case 16
        HJ8(4) = StrPtr(SourceArray(I))
        V8 = J8(0)
        V16 = J8(1)
        HJ8(4) = P
        J8(0) = V8
        J8(1) = V16
    Case Else
        rtlStringToPtr P, SourceArray(I), L
    End Select
    Select Case ReturnTo
    Case 0: GoTo 0
    Case 1: GoTo 1
    Case 2: GoTo 2
    Case 4: GoTo 4
    Case 6: GoTo 6
    Case 8: GoTo 8
    Case 10: GoTo 10
    Case 12: GoTo 12
    Case 14: GoTo 14
    Case 16: GoTo 16
    Case 24: GoTo 24
    Case 32: GoTo 32
    Case 33: GoTo 33
    Case 34: GoTo 34
    End Select
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
    Dim P() As Long, R() As Long
    Dim C As Long, I As Long, J As Long, K As Long, LD 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
        ' 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
            ' space for knowing the positions
            PL = Limit \ 80
            ReDim P(0 To PL)
            ' InStrB?
            If Compare = [Split BinaryCompare] Then
                Do
                    ' 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)
                    ' increase counter
                    C = C + 1
                    If C > PL Then PL = PL + C: ReDim Preserve P(PL)
                Loop While I > 0 And C <= Limit
            Else ' InStr
                Do
                    ' remember position
                    P(C) = (I - 1) * 2
                    ' find next
                    I = InStr(I + LD \ 2, Expression, Delimiter)
                    ' increase counter
                    C = C + 1
                    If C > PL Then PL = PL + C: ReDim Preserve P(PL)
                Loop While I > 0 And C <= Limit
            End If
            P(C) = LE
            ' make space for the new items
            z_Split = InitStringArray(, , (C + 1) * 0.0001@)
            PutLong ArrPtr(R), 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@)
            PutLong ArrPtr(R), z_Split
            R(0) = SysAllocStringByteLen(PS, LE)
        End If
        ' clean up z_Split reference
        PutLong ArrPtr(R), 0
    Else
        z_Split = InitStringArray
    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 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