Keskustelu: Koodit: VB6: Tehokas merkkijonoluokka

' clsBSTR: a fast string handling class for big strings
' -----------------------------------------------------------
' By Vesa Piittinen < vesa.piittinen.name > 2007-04-28
' This copyright notice must be left intact in the beginning of this file.
' License: http://creativecommons.org/licenses/by/1.0/fi/deed.en

' TODO ideas:
' - Array functions (Join and Split)
' - Boyer-Moore improvement for InStr (when keyword longer than 5 chars/binary or 3 chars/text)
' - Count (number of occurances of a keyword in the string)
' - File loading and saving (support for ANSI, UTF-8 and UTF-16 files, with and without BoM)
' - InStrRev
' - Pad
' - Replace

Option Explicit

Const ALLOCDEFAULT = 64         ' default extra allocation size for buffer
Const ALLOCMAXIMUM = 134217728  ' limit maximum allocation size to 128 MB

Private AllocExtra As Long

' contains the main data in BSTR format: 4 bytes length + data + 2 bytes NULLCHAR
Private Char() As Integer
Private CharLB As Long
Private CharRealUB As Long
Private CharUB As Long
Private Chars As Long

' our very own fake BSTR string
Private CharStr As String
Private CharStrPtr() As Long
Private CharStrHeader(5) As Long

' points to the first four bytes of Char to give BSTR compatibility
Private CharLen() As Long
Private CharLenHeader(5) As Long

' for fast access to string data
Private CharTmp() As Integer
Private CharTmp2() As Integer
Private CharHeader(5) As Long
Private CharHeader2(5) As Long

Private Sub Allocate(ByVal Characters As Long, Optional ByVal PrependChars As Long = 0, Optional ByVal PreserveContent As Boolean = True)
    Dim lngOldLB As Long, lngOldChars As Long, lngPtr As Long, blnDataMove As Boolean
    If Characters < 0 Then Characters = 0
    If PrependChars < 0 Then PrependChars = 0
    ' store number of characters
    lngOldChars = Chars + Chars
    Chars = Characters + PrependChars
    ' store LBound(Char)
    lngOldLB = CharLB
    CharLB = CharLB - PrependChars
    blnDataMove = (CharLB < 2) Or (CharLB > AllocExtra + 2)
    If Not blnDataMove Then Else CharLB = 2 + AllocExtra
    ' store UBound(Char)
    CharUB = Chars + CharLB
    ' see if we preserve old content
    If PreserveContent Then
        ' see if we need to allocate more space
        If CharRealUB < CharUB Then
            CharRealUB = CharUB + AllocExtra
            ReDim Preserve Char(CharRealUB)
        End If
        ' move data if LBound changed
        If blnDataMove And lngOldChars > 0 Then
            RtlMoveLongVV VarPtr(Char(CharLB + PrependChars)), VarPtr(Char(lngOldLB)), lngOldChars
        End If
        ' make sure always ends in nullchar
        Char(CharUB) = 0
        ' keep CharStr in correct memory pointer
        lngPtr = VarPtr(Char(CharLB))
        CharStrPtr(0) = lngPtr
        ' keep CharLen(0) in correct memory pointer
        CharLenHeader(3) = lngPtr - 4&
        ' keep character count up to date to have BSTR compatibility
        If Chars > 0 Then
            CharLen(0) = Chars * 2
        Else
            CharLen(0) = 0
        End If
    Else
        ' see if we need to allocate more space
        If CharRealUB < CharUB Then
            CharRealUB = CharUB + AllocExtra
            ReDim Char(CharRealUB)
        End If
        ' keep CharStr in correct memory pointer
        lngPtr = VarPtr(Char(CharLB))
        CharStrPtr(0) = lngPtr
        ' keep CharLen(0) in correct memory pointer
        CharLenHeader(3) = lngPtr - 4&
        ' keep character count up to date to have BSTR compatibility
        If Chars > 0 Then CharLen(0) = Chars * 2
    End If
End Sub
' add data after the end of the string
Public Function Append(ByRef Text As String) As clsBSTR
    Dim lngLen As Long, lngChars As Long
    lngLen = Len(Text)
    If lngLen > 0 Then
        lngChars = Chars
        ' see if we can avoid the costly Allocate call
        If CharUB + lngLen <= CharRealUB Then
            CharUB = CharUB + lngLen
            Char(CharUB) = 0
            Chars = Chars + lngLen
            CharLen(0) = Chars * 2
        Else
            Allocate Chars + lngLen
        End If
        vbaCopyBytes lngLen * 2, CharStrPtr(0) + lngChars * 2, StrPtr(Text)
        'Mid$(CharStr, lngChars + 1, lngLen) = Text
    End If
    ' return myself
    Set Append = Me
End Function
Public Property Get Asc(ByVal Pos As Long) As Integer
    If Pos >= 0 And Pos < Chars Then Asc = Char(Pos + CharLB)
End Property
Public Property Let Asc(ByVal Pos As Long, ByVal NewValue As Integer)
    If Pos >= 0 And Pos < Chars Then Char(Pos + CharLB) = NewValue
End Property
Public Property Get BufferAllocSize() As Long
    BufferAllocSize = AllocExtra
End Property
Public Property Let BufferAllocSize(ByVal NewValue As Long)
    If NewValue < 0 Then
        AllocExtra = 0
    ElseIf BufferSize > ALLOCMAXIMUM Then
        AllocExtra = ALLOCMAXIMUM
    Else
        AllocExtra = NewValue
    End If
End Property
Friend Sub BufferCopy(ByVal FromPtr As Long, ByVal DataLen As Long)
    Allocate DataLen \ 2
    'RtlMoveLongVV VarPtr(Char(CharLB)), FromPtr, DataLen
    vbaCopyBytes DataLen, VarPtr(Char(CharLB)), FromPtr
End Sub
Public Property Get BufferSize() As Long
    BufferSize = CharRealUB
End Property
Public Property Let BufferSize(ByVal NewValue As Long)
    Dim lngPtr As Long
    If NewValue >= 0 Then
        CharRealUB = NewValue + CharLB
    Else
        CharRealUB = CharLB
    End If
    If CharRealUB < CharUB Then
        Chars = (CharRealUB - CharLB)
        CharUB = CharRealUB
    End If
    ReDim Preserve Char(CharRealUB)
    Char(CharUB) = 0
    ' keep CharStr in correct memory pointer
    lngPtr = VarPtr(Char(CharLB))
    CharStrPtr(0) = lngPtr
    ' keep CharLen(0) in correct memory pointer
    CharLenHeader(3) = lngPtr - 4&
    CharLen(0) = Chars * 2
End Property
Public Property Get Chr(ByVal Pos As Long) As String
    If Pos >= 0 And Pos < Chars Then Chr = ChrW$(Char(Pos + CharLB))
End Property
Public Property Let Chr(ByVal Pos As Long, ByRef NewValue As String)
    If Pos >= 0 And Pos < Chars Then
        If LenB(NewValue) > 0 Then Char(Pos + CharLB) = AscW(NewValue)
    End If
End Property
' returns a given number of characters from the left as new clsBSTR
Public Function GetLeft(ByVal Length As Long) As clsBSTR
    Set GetLeft = New clsBSTR
    If Length > 0 Then
        If Length < Chars Then
            GetLeft.BufferCopy VarPtr(Char(CharLB)), Length * 2
        Else
            GetLeft.BufferCopy VarPtr(Char(CharLB)), CharLen(0)
        End If
    End If
End Function
' returns a clip of a string as new clsBSTR
Public Function GetMiddle(ByVal Pos As Long, Optional ByVal Length As Long = -1&) As clsBSTR
    Dim lngA As Long
    Set GetMiddle = New clsBSTR
    Pos = Pos + CharLB
    If Pos >= CharLB And Pos <= CharUB Then
        If Length >= -1& Then
            If Pos + Length >= CharUB Or Length = -1& Then Length = CharUB - Pos
            If Length > 0 Then GetMiddle.BufferCopy VarPtr(Char(Pos)), Length * 2
        End If
    End If
End Function
' returns a given number of characters from the right as new clsBSTR
Public Function GetRight(ByVal Length As Long) As clsBSTR
    Set GetRight = New clsBSTR
    If Length > 0 Then
        If Length < Chars Then
            GetRight.BufferCopy VarPtr(Char(CharUB - Length)), Length * 2
        Else
            GetRight.BufferCopy VarPtr(Char(CharLB)), CharLen(0)
        End If
    End If
End Function
Public Function GetValue() As clsBSTR
    Set GetValue = New clsBSTR
    GetValue.BufferCopy VarPtr(Char(CharLB)), CharLen(0)
End Function
Public Function InStr(ByRef Keyword As String, Optional ByVal Start As Long = 0&, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
    Dim lngKeyLen As Long, lngKeyLenB As Long, lngKeyEnd As Long, lngA As Long, lngB As Long
    Dim strLCase As String, strUCase As String
    Dim intChar1 As Integer, intChar1b As Integer
    Dim intChar2 As Integer
    Dim intChar3 As Integer, intChar3b As Integer
    Dim intChar4 As Integer
    If CharUB < 3 Then InStr = -1&: Exit Function
    lngKeyLen = Len(Keyword)
    lngKeyLenB = LenB(Keyword)
    If lngKeyLen = 0 Then InStr = Start: Exit Function
    If CharLen(0) < lngKeyLenB Then InStr = -1&: Exit Function
    If Start < 0 Or Start > (CharLen(0) - lngKeyLenB + 1) \ 2 Then InStr = -1&: Exit Function
    If Compare = vbBinaryCompare Then
        Dim lngResult As Long
        lngResult = vbaInStr(0&, StrPtr(Keyword), CharStrPtr(0), Start + 1)
        InStr = lngResult - 1
        Exit Function
        CharHeader(3) = StrPtr(Keyword)
        CharHeader(4) = lngKeyLen
        intChar1 = CharTmp(0)
        If lngKeyLen = 1 Then
            For lngA = CharLB To CharUB - 1
                intChar2 = Char(lngA)
                If intChar1 = intChar2 Then Exit For
            Next lngA
            If lngA < CharUB Then InStr = lngA - CharLB Else InStr = -1&
        ElseIf lngKeyLen = 2 Then
            intChar3 = CharTmp(1)
            For lngA = CharLB To CharUB - 2
                intChar2 = Char(lngA)
                If intChar1 = intChar2 Then
                    intChar4 = Char(lngA + 1)
                    If intChar3 = intChar4 Then Exit For
                End If
            Next lngA
            If lngA < CharUB Then InStr = lngA - CharLB Else InStr = -1&
        Else
            lngKeyEnd = lngKeyLen - 1
            intChar3 = CharTmp(lngKeyEnd)
            For lngA = CharLB To CharUB - lngKeyLen
                intChar2 = Char(lngA)
                If intChar1 = intChar2 Then
                    intChar4 = Char(lngA + lngKeyEnd)
                    If intChar3 = intChar4 Then
                        For lngB = 1 To lngKeyEnd - 1
                            If Char(lngB + lngA) <> CharTmp(lngB) Then Exit For
                        Next lngB
                        If lngB = lngKeyEnd Then Exit For
                    End If
                End If
            Next lngA
            If lngA < CharUB Then InStr = lngA - CharLB Else InStr = -1&
        End If
    Else
        ' create local copies of the keywords
        strUCase = Keyword
        strLCase = Keyword
        CharHeader(3) = StrPtr(strUCase)
        CharHeader(4) = lngKeyLen
        CharHeader2(3) = StrPtr(strLCase)
        CharHeader2(4) = lngKeyLen
        ' convert to lower case
        For lngA = 0 To lngKeyLen - 1
            CharTmp(lngA) = UTable(CharTmp(lngA) And &HFFFF&)
            CharTmp2(lngA) = LTable(CharTmp(lngA) And &HFFFF&)
        Next lngA
        intChar1 = CharTmp(0)
        intChar1b = CharTmp2(0)
        If lngKeyLen = 1 Then
            For lngA = CharLB To CharUB - 1
                intChar2 = Char(lngA)
                If intChar1 = intChar2 Or intChar1b = intChar2 Then Exit For
            Next lngA
            If lngA < CharUB Then InStr = lngA - CharLB Else InStr = -1&
        ElseIf lngKeyLen = 2 Then
            intChar3 = CharTmp(1)
            intChar3b = CharTmp2(1)
            For lngA = CharLB To CharUB - 2
                intChar2 = Char(lngA)
                If intChar1 = intChar2 Or intChar1b = intChar2 Then
                    intChar4 = Char(lngA + 1)
                    If intChar3 = intChar4 Or intChar3b = intChar4 Then Exit For
                End If
            Next lngA
            If lngA < CharUB Then InStr = lngA - CharLB Else InStr = -1&
        Else
            lngKeyEnd = lngKeyLen - 1
            intChar3 = CharTmp(lngKeyEnd)
            intChar3b = CharTmp2(lngKeyEnd)
            For lngA = CharLB To CharUB - lngKeyLen
                intChar2 = Char(lngA)
                If intChar1 = intChar2 Or intChar1b = intChar2 Then
                    intChar4 = Char(lngA + lngKeyEnd)
                    If intChar3 = intChar4 Or intChar3b = intChar4 Then
                        For lngB = 1 To lngKeyEnd - 1
                            intChar2 = Char(lngB + lngA)
                            If intChar2 <> CharTmp(lngB) And intChar2 <> CharTmp2(lngB) Then Exit For
                        Next lngB
                        If lngB = lngKeyEnd Then Exit For
                    End If
                End If
            Next lngA
            If lngA < CharUB Then InStr = lngA - CharLB Else InStr = -1&
        End If
    End If
End Function
' lower case
Public Function LCase() As clsBSTR
    Dim lngA As Long
    ' loop through all characters and switch to lower case
    For lngA = CharLB To CharUB - 1
        Char(lngA) = LTable(Char(lngA) And &HFFFF&)
    Next lngA
    ' return myself
    Set LCase = Me
End Function
' returns a given number of characters from the left
Public Function Left(ByVal Length As Long) As String
    If Length > 0 Then
        If Length < Chars Then
            Left = Strings.Left$(CharStr, Length)
        Else
            Left = CharStr
        End If
    End If
End Function
' returns string length in characters
Public Function Length() As Long
    Length = Chars
End Function
' returns string length in bytes
Public Function LengthB() As Long
    LengthB = CharLen(0)
End Function
Public Property Get Middle(ByVal Pos As Long, Optional ByVal Length As Long = -1&) As String
    Dim lngPos As Long
    lngPos = Pos + CharLB
    If lngPos >= CharLB And lngPos <= CharUB Then
        If Length >= -1& Then
            If (lngPos + Length >= CharUB Or Length = -1&) Then Length = CharUB - lngPos
            If Length > 0 Then Middle = Mid$(CharStr, Pos + 1, Length)
        End If
    End If
End Property
Public Property Let Middle(ByVal Pos As Long, Optional ByVal Length As Long = -1&, ByRef NewValue As String)
    Dim lngA As Long, lngDiff As Long, lngEnd As Long, lngPos As Long, lngLen As Long
    lngPos = Pos + CharLB
    If lngPos >= CharLB And lngPos <= CharUB Then
        If Length >= -1& Then
            If lngPos + Length >= CharUB Or Length = -1& Then Length = CharUB - lngPos
            lngLen = Len(NewValue)
            lngDiff = Length - lngLen
            If lngDiff = 0 Then
                Mid$(CharStr, Pos + 1, Length) = NewValue
                'vbaCopyBytes Length * 2, VarPtr(Char(lngPos)), StrPtr(NewValue)
            ElseIf lngDiff > 0 Then
                If lngLen > 0 Then
                    Mid$(CharStr, Pos + 1, lngLen) = NewValue
                    'vbaCopyBytes Length * 2, VarPtr(Char(lngPos)), StrPtr(NewValue)
                    lngPos = lngPos + lngLen
                End If
                lngA = CharUB - lngPos - lngDiff
                If lngA > 0 Then RtlMoveLongVV VarPtr(Char(lngPos)), VarPtr(Char(lngPos + lngDiff)), lngA * 2
                Allocate Chars - lngDiff
            Else
                lngPos = lngPos + Length
                lngEnd = (CharUB - lngPos) * 2
                Allocate Chars - lngDiff
                If lngEnd > 0 Then RtlMoveLongVV VarPtr(Char(lngPos - lngDiff)), VarPtr(Char(lngPos)), lngEnd
                If lngLen > 0 Then Mid$(CharStr, Pos + 1, lngLen) = NewValue 'vbaCopyBytes Length * 2, VarPtr(Char(lngPos)), StrPtr(NewValue)
            End If
        End If
    End If
End Property
Public Property Set Middle(ByVal Pos As Long, Optional ByVal Length As Long = -1&, ByRef NewValue As clsBSTR)
    Dim lngA As Long, lngDiff As Long, lngEnd As Long, lngPos As Long, lngLen As Long, strValue As String
    lngPos = Pos + CharLB
    If lngPos >= CharLB And lngPos <= CharUB Then
        If Length >= -1& Then
            If lngPos + Length >= CharUB Or Length = -1& Then Length = CharUB - lngPos
            If Not NewValue Is Nothing Then strValue = NewValue.Value
            lngLen = Len(strValue)
            lngDiff = Length - lngLen
            If lngDiff = 0 Then
                Mid$(CharStr, Pos + 1, Length) = strValue
            ElseIf lngDiff > 0 Then
                If lngLen > 0 Then
                    Mid$(CharStr, Pos + 1, lngLen) = strValue
                    lngPos = lngPos + lngLen
                End If
                lngA = CharUB - lngPos - lngDiff
                If lngA > 0 Then RtlMoveLongVV VarPtr(Char(lngPos)), VarPtr(Char(lngPos + lngDiff)), lngA * 2
                Allocate Chars - lngDiff
            Else
                lngPos = lngPos + Length
                lngEnd = (CharUB - lngPos) * 2
                Allocate Chars - lngDiff
                If lngEnd > 0 Then RtlMoveLongVV VarPtr(Char(lngPos - lngDiff)), VarPtr(Char(lngPos)), lngEnd
                If lngLen > 0 Then Mid$(CharStr, Pos + 1, lngLen) = strValue
            End If
        End If
    End If
End Property
' proper case
Public Function PCase() As clsBSTR
    Dim lngA As Long, blnLCase As Boolean, lngChar As Long
    ' loop through all characters and switch to proper case
    For lngA = CharLB To CharUB - 1
        lngChar = Char(lngA) And &HFFFF&
        If Not PTable(lngChar) Then
            If blnLCase Then
                Char(lngA) = LTable(lngChar)
            Else
                Char(lngA) = UTable(lngChar)
                blnLCase = True
            End If
        Else
            blnLCase = False
        End If
    Next lngA
    ' return myself
    Set PCase = Me
End Function
' add data before the beginning of the string
Public Function Prepend(ByRef Text As String) As clsBSTR
    Dim lngLen As Long, lngLenB As Long
    lngLenB = LenB(Text)
    If lngLenB > 0 Then
        lngLen = lngLenB \ 2
        ' avoid the costly Allocate call
        If CharLB - lngLen >= 2 Then
            CharLB = CharLB - lngLen
            Chars = Chars + lngLen
            CharStrPtr(0) = CharStrPtr(0) - lngLenB
            CharLenHeader(3) = CharLenHeader(3) - lngLenB
            CharLen(0) = Chars * 2
        Else
            Allocate Chars, lngLen
        End If
        vbaCopyBytes lngLenB, CharStrPtr(0), StrPtr(Text)
        'Mid$(CharStr, 1, lngLen) = Text
    End If
    ' return myself
    Set Prepend = Me
End Function
' returns the StrPtr to data
Public Function Ptr() As Long
    Ptr = VarPtr(Char(CharLB))
End Function
' replicates the current string to given number of copies
Public Function Replicate(Optional ByVal Count As Long = 2) As clsBSTR
    Dim lngLenB As Long, lngPtrSrc As Long, lngPtrDest As Long, lngPtrOut As Long
    ' validate count
    If Count > 1 Then
        lngLenB = CharLen(0)
        Allocate Chars * Count
        lngPtrSrc = VarPtr(Char(CharLB))
        lngPtrDest = lngPtrSrc + lngLenB
        lngPtrOut = VarPtr(Char(CharUB))
        Do While lngPtrOut > lngPtrDest + lngLenB
            RtlMoveLongVV lngPtrDest, lngPtrSrc, lngLenB
            lngPtrDest = lngPtrDest + lngLenB
            lngLenB = lngLenB * 2
        Loop
        If lngPtrDest < lngPtrOut Then RtlMoveLongVV lngPtrDest, lngPtrSrc, lngPtrOut - lngPtrDest
    ElseIf Count = 0 Then
        Allocate 0
    End If
    ' return self
    Set Replicate = Me
End Function
' reverses the string; returns object itself
Public Function Reverse() As clsBSTR
    ' see if we have anything to reverse
    If Chars > 1 Then Mid$(CharStr, 1&, Chars) = vbaStrReverse(CharStrPtr(0))
    ' return self
    Set Reverse = Me
End Function
' returns a given number of characters from the right
Public Function Right(ByVal Length As Long) As String
    If Length > 0 Then
        If Length < Chars Then
            Right = Strings.Right$(CharStr, Length)
        Else
            Right = CharStr
        End If
    End If
End Function
Public Function SetValue(ByRef Text As String) As clsBSTR
    Allocate Len(Text)
    If CharLen(0) > 0 Then Mid$(CharStr, 1, Chars) = Text
    Set SetValue = Me
End Function
' trim by given string
Public Function Trim(Optional ByRef Characters As String = " ", Optional TrimType As vbTrimType = vbTrimBoth) As clsBSTR
    Dim TrimChar As Integer, lngTrimType As Long
    Dim lngLeft As Long, lngRight As Long, lngChar As Long, lngA As Long
    Dim lngPtr As Long
    lngChar = LenB(Characters)
    ' see if we got trim characters
    If lngChar = 1 Or lngChar = 2 Then
        ' one character only
        TrimChar = AscW(Characters)
        ' see if we trim from the left
        If (TrimType And vbTrimLeft) = vbTrimLeft Then
            For lngLeft = CharLB To CharUB - 1
                If Char(lngLeft) = TrimChar Then Else Exit For
            Next lngLeft
        Else
            lngLeft = CharLB
        End If
        If (TrimType And vbTrimRight) = vbTrimRight Then
            For lngRight = CharUB - 1 To lngLeft Step -1
                If Char(lngRight) = TrimChar Then Else Exit For
            Next lngRight
        Else
            lngRight = CharUB - 1
        End If
        If lngLeft <= lngRight Then
            Chars = (lngRight - lngLeft) + 1
            CharUB = lngRight
            CharLB = lngLeft
            ' keep CharStr in correct memory pointer
            lngPtr = VarPtr(Char(CharLB))
            CharStrPtr(0) = lngPtr
            CharLenHeader(3) = lngPtr - 4&
            CharLen(0) = Chars * 2
            'RtlMoveLongVV VarPtr(Char(CharLB)), VarPtr(Char(lngLeft)), (lngRight - lngLeft + 1) * 2
            'Allocate (lngRight - lngLeft + 1)
        Else
            Allocate 0
        End If
    ElseIf lngChar <> 0 Then
        ' generate a table of characters to use for trimming
        CharHeader(3) = StrPtr(Characters)
        CharHeader(4) = Len(Characters)
        For lngA = 0 To CharHeader(4) - 1
            TTable(CharTmp(lngA) And &HFFFF&) = True
        Next lngA
        ' see if we trim from the left
        If (TrimType And vbTrimLeft) = vbTrimLeft Then
            For lngLeft = CharLB To CharUB - 1
                If TTable(Char(lngLeft) And &HFFFF&) Then Else Exit For
            Next lngLeft
        Else
            lngLeft = CharLB
        End If
        If (TrimType And vbTrimRight) = vbTrimRight Then
            For lngRight = CharUB - 1 To lngLeft Step -1
                If TTable(Char(lngRight) And &HFFFF&) Then Else Exit For
            Next lngRight
        Else
            lngRight = CharUB - 1
        End If
        If lngLeft <= lngRight Then
            Chars = (lngRight - lngLeft) + 1
            CharUB = lngRight
            CharLB = lngLeft
            ' keep CharStr in correct memory pointer
            lngPtr = VarPtr(Char(CharLB))
            CharStrPtr(0) = lngPtr
            CharLenHeader(3) = lngPtr - 4&
            CharLen(0) = Chars * 2
            'RtlMoveLongVV VarPtr(Char(CharLB)), VarPtr(Char(lngLeft)), (lngRight - lngLeft + 1) * 2
            'Allocate (lngRight - lngLeft + 1)
        Else
            Allocate 0
        End If
        ' restore trimchars to null state
        For lngA = 0 To CharHeader(4) - 1
            TTable(CharTmp(lngA) And &HFFFF&) = False
        Next lngA
    End If
    ' return myself
    Set Trim = Me
End Function
' upper case
Public Function UCase() As clsBSTR
    Dim lngA As Long
    ' loop through all characters and switch to upper case
    For lngA = CharLB To CharUB - 1
        Char(lngA) = UTable(Char(lngA) And &HFFFF&)
    Next lngA
    ' return myself
    Set UCase = Me
End Function
' get string
Public Property Get Value() As String
    Value = CharStr
End Property
' set string
Public Property Let Value(ByRef Text As String)
    Dim lngLen As Long
    lngLen = Len(Text)
    If lngLen > 0 Then
        If lngLen <> Chars Then
            If CharLB + lngLen <= CharRealUB Then
                CharUB = CharLB + lngLen
                Char(CharUB) = 0
                Chars = lngLen
                CharLen(0) = Chars * 2
            Else
                Allocate lngLen
            End If
        End If
        vbaCopyBytes CharLen(0), CharStrPtr(0), StrPtr(Text)
        'Mid$(CharStr, 1, Chars) = Text
    Else
        Allocate 0
    End If
End Property
' set string from other object
Public Property Set Value(ByRef Text As clsBSTR)
    If Not Text Is Nothing Then
        BufferCopy Text.Ptr, Text.LengthB
    Else
        Allocate 0
    End If
End Property
' get string as an integer array
Public Property Get ValueArray() As Integer()
    Dim intOut() As Integer
    If Chars > 0 Then
        ReDim intOut(CharUB - CharLB)
        RtlMoveLongVV VarPtr(intOut(0)), VarPtr(Char(CharLB)), CharLen(0)
        ValueArray = intOut
        Erase intOut
    End If
End Property
' set string from integer array
Public Property Let ValueArray(ByRef NewValue() As Integer)
    Dim lngPtr As Long, lngLow As Long, lngHigh As Long
    ' check if the array is initialized
    RtlMoveMemory lngPtr, ByVal VarPtrArray(NewValue), 4
    If lngPtr = 0 Then Exit Property
    ' check boundaries
    lngLow = LBound(NewValue)
    lngHigh = UBound(NewValue)
    If lngHigh < lngLow Then Exit Property
    ' reserve space for the new data
    Allocate lngHigh - lngLow + 1
    ' copy data
    RtlMoveLongVV VarPtr(Char(CharLB)), VarPtr(NewValue(lngLow)), (lngHigh - lngLow + 1) * 2
End Property
Private Sub Class_Initialize()
    ' only set these once: see modBSTR
    If Not PTable(0) Then GenerateCaseTables

    ' create a one element long safearray for fast access: CharStrPtr(0)
    CharStrHeader(0) = 1&
    CharStrHeader(1) = 4&
    CharStrHeader(3) = VarPtr(CharStr)
    CharStrHeader(4) = 1&
    RtlMoveLongVR ByVal VarPtrArray(CharStrPtr), VarPtr(CharStrHeader(0)), 4&

    ' create a one element long safearray for fast access: CharLen(0)
    CharLenHeader(0) = 1&
    CharLenHeader(1) = 4&
    'CharLenHeader(3) is automatically set in Allocate
    CharLenHeader(4) = 1&
    RtlMoveLongVR ByVal VarPtrArray(CharLen), VarPtr(CharLenHeader(0)), 4&

    ' this is our primary safearray for strings: CharTmp
    CharHeader(0) = 1&
    CharHeader(1) = 2&
    RtlMoveLongVR ByVal VarPtrArray(CharTmp), VarPtr(CharHeader(0)), 4&

    ' this is our secondary safearray for strings: CharTmp2
    CharHeader2(0) = 1&
    CharHeader2(1) = 2&
    RtlMoveLongVR ByVal VarPtrArray(CharTmp2), VarPtr(CharHeader2(0)), 4&

    ' initial allocation: also resets all our helper variables
    AllocExtra = ALLOCDEFAULT
    Allocate 0, 0, False
End Sub
Private Sub Class_Terminate()
    ' unset faked BSTR
    CharStrPtr(0) = 0&
    ' unset custom safearrays
    RtlMoveLongVR ByVal VarPtrArray(CharStrPtr), 0&, 4&
    RtlMoveLongVR ByVal VarPtrArray(CharLen), 0&, 4&
    RtlMoveLongVR ByVal VarPtrArray(CharTmp), 0&, 4&
    RtlMoveLongVR ByVal VarPtrArray(CharTmp2), 0&, 4&
    ' free memory
    Erase Char
End Sub

' clsBSTR: a fast string handling class for big strings
' -----------------------------------------------------------
' By Vesa Piittinen < vesa.piittinen.name > 2007-04-28
' This copyright notice must be left intact in the beginning of this file.
' License: http://creativecommons.org/licenses/by/1.0/fi/deed.en
'
' modBSTR.bas for use with clsBSTR.cls

Option Explicit

' case tables
Public LTable(65535) As Integer ' to lower case codes
Public PTable(65535) As Boolean ' proper case separators
Public UTable(65535) As Integer ' to upper case codes
Public TTable(65535) As Boolean ' temp table that is always kept in zero state when not in use

' generic additions
Public Const vbQuote As String = """"

' for Pad
Public Enum vbPadType
    vbPadLeft = 1
    vbPadRight = 2
    vbPadBoth = 3
End Enum

' for Trim
Public Enum vbTrimType
    vbTrimLeft = 1
    vbTrimRight = 2
    vbTrimBoth = 3
End Enum

' API declarations
Public Declare Sub RtlMoveMemory Lib "ntdll.dll" (ByRef lpvDest As Any, ByRef lpvSrc As Any, ByVal cbLen As Long)
'Public Declare Sub RtlMoveLongVR Lib "ntdll.dll" Alias "RtlMoveMemory" (ByRef lpvDest As Any, ByRef lpvSrc As Any, ByVal cbLen As Long)
'Public Declare Sub RtlMoveLongVV Lib "ntdll.dll" Alias "RtlMoveMemory" (ByVal lpvDest As Long, ByVal lpvSrc As Long, ByVal cbLen As Long)

'Public Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Var() As Any) As Long
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef lpvDest As Any, ByRef lpvSrc As Any, ByVal cbLen As Long)
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
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
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, lpNumberOfBytesWritten As Long) As Long

Private Sub DeclareAPI(ByVal AddressOfDest As Long, ByRef API As String, ByRef Module As String)
    Dim lngModuleHandle As Long, AddressOfSrc As Long
    Dim larJMPASM(1) As Long
    Dim lngProcessHandle As Long, lngBytesWritten As Long
    ' get handle for module
    lngModuleHandle = GetModuleHandle(Module)
    If lngModuleHandle = 0 Then lngModuleHandle = LoadLibrary(Module)
    ' if failed, we can't do anything
    If lngModuleHandle = 0 Then Exit Sub
    ' get address of function
    AddressOfSrc = GetProcAddress(lngModuleHandle, API)
    ' if failed, we can't do anything
    If AddressOfSrc = 0 Then Exit Sub
    ' get a handle for current process
    lngProcessHandle = OpenProcess(&H1F0FFF, 0&, GetCurrentProcessId)
    ' if failed, we can't do anything
    If lngProcessHandle = 0 Then Exit Sub
    ' check if we are in the IDE
    If InIDE Then
        ' get the real location of the procedure
        CopyMemory AddressOfDest, ByVal AddressOfDest + &H16&, 4&
    End If
    ' set ASM JMP
    larJMPASM(0) = &HE9000000
    ' set JMP parameter (how many bytes to jump)
    larJMPASM(1) = AddressOfSrc - AddressOfDest - 5
    ' replace original procedure with the JMP
    WriteProcessMemory lngProcessHandle, ByVal AddressOfDest, ByVal VarPtr(larJMPASM(0)) + 3, 5, lngBytesWritten
    ' close handle for current process
    CloseHandle lngProcessHandle
End Sub
' this generates case tables: optimized to separate module to save memory and extra speed
Public Sub GenerateCaseTables()
    Dim strTest As String, lngA As Long
    ' generate upper and lower case link tables
    For lngA = 0 To 65535
        strTest = ChrW$(lngA)
        UTable(lngA) = AscW(UCase$(strTest))
        LTable(lngA) = AscW(LCase$(strTest))
    Next lngA

    ' proper case separators: these are the same as in StrConv(vbProperCase)
    PTable(0) = True
    PTable(9) = True
    PTable(10) = True
    PTable(11) = True
    PTable(12) = True
    PTable(13) = True
    PTable(32) = True
    PTable(8192) = True
    PTable(8193) = True
    PTable(8194) = True
    PTable(8195) = True
    PTable(8196) = True
    PTable(8197) = True
    PTable(8198) = True
    PTable(12288) = True

    ' hack: enum names to prevent VB IDE from messing their case
    Dim vbPadLeft As vbPadType, vbPadRight As vbPadType, vbPadBoth As vbPadType
    Dim vbTrimLeft As vbTrimType, vbTrimRight As vbTrimType, vbTrimBoth As vbTrimType
End Sub
Public Function InIDE() As Boolean
    Debug.Assert Not InIDEtest(InIDE)
End Function
Private Function InIDEtest(ByRef IDE As Boolean) As Boolean
    IDE = True
End Function
Private Sub ReplaceSub(ByVal AddressOfDest As Long, ByVal AddressOfSrc As Long)
    Dim larJMPASM(1) As Long
    Dim lngProcessHandle As Long, lngBytesWritten As Long
    ' get a handle for current process
    lngProcessHandle = OpenProcess(&H1F0FFF, 0&, GetCurrentProcessId)
    ' if failed, we can't do anything
    If lngProcessHandle = 0 Then Exit Sub
    ' check if we are in the IDE
    If InIDE Then
        ' get the real locations of the procedures
        CopyMemory AddressOfDest, ByVal AddressOfDest + &H16&, 4&
        CopyMemory AddressOfSrc, ByVal AddressOfSrc + &H16&, 4&
    End If
    ' set ASM JMP
    larJMPASM(0) = &HE9000000
    ' set JMP parameter (how many bytes to jump)
    larJMPASM(1) = AddressOfSrc - AddressOfDest - 5
    ' replace original procedure with the JMP
    WriteProcessMemory lngProcessHandle, ByVal AddressOfDest, ByVal VarPtr(larJMPASM(0)) + 3, 5, lngBytesWritten
    ' close handle for current process
    CloseHandle lngProcessHandle
End Sub
Public Sub RtlMoveLongVR(ByVal lpvDest As Long, lpvSrc As Long, ByVal cbLen As Long)
    DeclareAPI AddressOf RtlMoveLongVR, "RtlMoveMemory", "ntdll.dll"
    RtlMoveLongVR lpvDest, lpvSrc, cbLen
End Sub
Public Sub RtlMoveLongVV(ByVal lpvDest As Long, ByVal lpvSrc As Long, ByVal cbLen As Long)
    DeclareAPI AddressOf RtlMoveLongVV, "RtlMoveMemory", "ntdll.dll"
    RtlMoveLongVV lpvDest, lpvSrc, cbLen
End Sub
Public Sub vbaCopyBytes(ByVal Length As Long, ByVal dest As Long, ByVal Src As Long)
    DeclareAPI AddressOf modBSTR.vbaCopyBytes, "__vbaCopyBytes", "msvbvm60.dll"
    vbaCopyBytes Length, dest, Src
End Sub
Public Function vbaInStr(ByVal Compare As Long, ByVal String2 As Long, ByVal String1 As Long, ByVal Start As Long) As Long
    DeclareAPI AddressOf modBSTR.vbaInStr, "__vbaInStr", "msvbvm60.dll"
    vbaInStr = vbaInStr(Compare, String2, String1, Start)
End Function
Public Function vbaStrReverse(ByVal Text As Long) As String
    DeclareAPI AddressOf modBSTR.vbaStrReverse, "rtcStrReverse", "msvbvm60.dll"
    vbaStrReverse = vbaStrReverse(Text)
End Function