技术宅的结界

 找回密码
 立即注册→加入我们

QQ登录

只需一步,快速开始

搜索
热搜: 下载 VB C 实现 编写
查看: 710|回复: 2
收起左侧

vb StringBuilder类

[复制链接]

1

主题

4

帖子

36

积分

用户组: 初·技术宅

UID
5181
精华
0
威望
0 点
宅币
32 个
贡献
0 次
宅之契约
0 份
在线时间
7 小时
注册时间
2019-7-25
发表于 2019-7-25 20:23:27 | 显示全部楼层 |阅读模式

欢迎访问技术宅的结界,请注册或者登录吧。

您需要 登录 才可以下载或查看,没有帐号?立即注册→加入我们

x
本帖最后由 天马座 于 2019-7-26 17:47 编辑

此类主要解决vb字符串频繁连接速度慢的问题,支持UTF-8 UTF-16互转,其他功能陆续添加
[mw_shl_code=vb,true]
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Private s As String
Private size As Long, capacity As Long
Private Sub Class_Initialize()
    size = 0
    capacity = 8
    s = String(capacity \ 2, ChrW(0))
End Sub
Public Function length() As Long
    '返回字符串长度 宽字节
    length = size \ 2
End Function
Public Function lengthB() As Long
    '返回字符串长度 字节
    lengthB = size
End Function
Public Sub clear()
    '清除缓冲区
    size = 0
    capacity = 8
    s = String(capacity \ 2, ChrW(0))
End Sub
Public Sub append(ByRef value As String)
    '添加
    Call copyB(value, size)
End Sub
Public Sub copy(ByRef value As String, ByVal index As Long)
    '写入 index对应宽字节 put命名被占用 改为copy
    Call copyB(value, index * 2)
End Sub
Public Sub copyB(ByRef value As String, ByVal index As Long)
    '写入 index对应字节
    If index < 0 Or index > size Or LenB(value) = 0 Then
        Exit Sub
    End If
    Dim n As Long
    n = LenB(value)
    Call ensureCapacity(index + n)
    Call CopyMemory(ByVal unsignedAdd(StrPtr(s), index), ByVal StrPtr(value), n)
    If size < index + n Then
         size = index + n
    End If
End Sub
Public Sub insert(ByRef value As String, ByVal index As Long)
    '插入 index对应宽字节
    Call insertB(value, index * 2)
End Sub
Public Sub insertB(ByRef value As String, ByVal index As Long)
    '插入 index对应字节
    If index < 0 Or index > size Or LenB(value) = 0 Then
        Exit Sub
    End If
    Dim n As Long
    n = LenB(value)
    Call ensureCapacity(size + n)
    If index <> size Then
           Call CopyMemory(ByVal unsignedAdd(StrPtr(s), index + n), ByVal unsignedAdd(StrPtr(s), index), size - index)
    End If
    Call CopyMemory(ByVal unsignedAdd(StrPtr(s), index), ByVal StrPtr(value), n)
    size = size + n
End Sub
Public Sub remove(ByVal index As Long)
    '删除 index对应宽字节
    Call removeRange0(index * 2, 2)
End Sub
Public Sub removeB(ByVal index As Long)
    '删除 index对应字节
    Call removeRange0(index, 1)
End Sub
Public Sub removeRange(ByVal lo As Long, ByVal hi As Long)
    '删除 [lo..hi]对应宽字节
    Call removeRange0(lo * 2, (hi - lo + 1) * 2)
End Sub
Public Sub removeRangeB(ByVal lo As Long, ByVal hi As Long)
     '删除 [lo..hi]对应字节
     Call removeRange0(lo, hi - lo + 1)
End Sub
Private Sub removeRange0(ByVal lo As Long, ByVal n As Long)
    If n <= 0 Or lo < 0 Or lo + n > size Then
        Exit Sub
    End If
    If size - (lo + n) > 0 Then
        Call CopyMemory(ByVal unsignedAdd(StrPtr(s), lo), ByVal unsignedAdd(StrPtr(s), lo + n), size - (lo + n))
    End If
    size = size - n
End Sub
Public Sub replaceRange(ByVal lo As Long, ByVal hi As Long, ByRef oldValue As String, ByRef nweValue As String)
    '替换[lo..hi]对应宽字节
    Call replaceRangeB(lo * 2, hi * 2, oldValue, nweValue)
End Sub
Public Sub replaceRangeB(ByVal lo As Long, ByVal hi As Long, ByRef oldValue As String, ByRef nweValue As String)
    '替换[lo..hi]对应字节
    If lo < 0 Or hi >= size Or LenB(oldValue) = 0 Then
        Exit Sub
    End If
    Dim start As Long, i As Long, oldLength As Long
    Dim update As Boolean
    Dim src As String
    Dim sb As New StringBuilder
    src = toString()
    update = False
    oldLength = LenB(oldValue)
    i = lo + 1
    start = lo + 1
    Do While i <= hi + 1
        i = InStrB(i, src, oldValue)
        If i < 1 Then
            If update Then
                sb.append MidB(src, start, hi + 2 - start)
            End If
            Exit Do
        End If
        sb.append MidB(src, start, i - start)
        sb.append nweValue
        i = i + oldLength
        start = i
        update = True
    Loop
    If update Then
        Call removeRangeB(lo, hi)
        Call insertB(sb.toString, lo)
    End If
    Set sb = Nothing
End Sub
Public Function toString() As String
    '返回缓冲区中的字符串
    toString = MidB(s, 1, size)
End Function
Public Function toUtf16String() As String
    '调用前确保s内容为UTF8
    Dim sb As New StringBuilder
    Dim i As Long, codePoint As Long, c As Byte, low As Long, high As Long
    i = 0
    Do While i < size
        c = AscB(MidB(s, i + 1, 1))
        If c < &H80 Then
            codePoint = c
            i = i + 1
        ElseIf c < &HE0 Then
            codePoint = ((c And &H1F) * 2 ^ 6) Or _
                        (AscB(MidB(s, i + 2, 1)) And &H3F)
            i = i + 2
        ElseIf c < &HF0 Then
            codePoint = ((c And &HF) * 2 ^ 12) Or _
                        ((AscB(MidB(s, i + 2, 1)) And &H3F) * 2 ^ 6) Or _
                        (AscB(MidB(s, i + 3, 1)) And &H3F)
            i = i + 3
        Else
            codePoint = ((c And &H7) * 2 ^ 18) Or _
                        ((AscB(MidB(s, i + 2, 1)) And &H3F) * 2 ^ 12) Or _
                        ((AscB(MidB(s, i + 3, 1)) And &H3F) * 2 ^ 6) Or _
                        (AscB(MidB(s, i + 4, 1)) And &H3F)
            i = i + 4
        End If
        If (&HFFFF0000 And codePoint) = 0 Then
            sb.append ChrB(codePoint And &HFF)
            sb.append ChrB(codePoint \ 256 And &HFF)
        Else
            high = (codePoint \ 2 ^ 10) + &HD7C0&
            low = (codePoint And &H3FF&) + &HDC00&
            sb.append ChrB(high And &HFF)
            sb.append ChrB(high \ 256 And &HFF)
            sb.append ChrB(low And &HFF)
            sb.append ChrB(low \ 256 And &HFF)
        End If
    Loop
    toUtf16String = sb.toString
    Set sb = Nothing
End Function
Public Function toUtf8String() As String
    '调用前确保s内容为UTF16 vb默认为UTF16
    Dim sb As New StringBuilder
    Dim i As Long, codePoint As Long, c1 As Long, c2 As Long
    i = 0
    Do While i < size
        c1 = AscB(MidB(s, i + 1, 1)) Or AscB(MidB(s, i + 2, 1)) * 2 ^ 8
        If c1 >= &HD800& And c1 <= &HDBFF& And i + 3 < size Then
            c2 = AscB(MidB(s, i + 3, 1)) Or AscB(MidB(s, i + 4, 1)) * 2 ^ 8
            If c2 >= &HDC00& And c2 <= &HDFFF& Then
                codePoint = ((c1 * 2 ^ 10) + c2) + (&HFCA02400)
            Else
                codePoint = c1
            End If
        Else
            codePoint = c1
        End If
        If codePoint >= &H10000 Then
            i = i + 4
        Else
            i = i + 2
        End If
        If codePoint < &H80 Then
             sb.append ChrB(codePoint)
        ElseIf codePoint < &H800 Then
             sb.append ChrB(&HC0 Or (codePoint \ 2 ^ 6))
             sb.append ChrB(&H80 Or (codePoint And &H3F))
        ElseIf codePoint < &H10000 Then
             sb.append ChrB(&HE0 Or (codePoint \ 2 ^ 12))
             sb.append ChrB(&H80 Or (codePoint \ 2 ^ 6 And &H3F))
             sb.append ChrB(&H80 Or (codePoint And &H3F))
        Else
             sb.append ChrB(&HF0 Or (codePoint \ 2 ^ 18))
             sb.append ChrB(&H80 Or (codePoint \ 2 ^ 12 And &H3F))
             sb.append ChrB(&H80 Or (codePoint \ 2 ^ 6 And &H3F))
             sb.append ChrB(&H80 Or (codePoint And &H3F))
        End If
    Loop
    toUtf8String = sb.toString
    Set sb = Nothing
End Function
Private Function unsignedAdd(a As Long, b As Long) As Long
   If (a Xor b) And &H80000000 Then
      unsignedAdd = a + b
   Else
      unsignedAdd = (a Xor &H80000000) + b Xor &H80000000
   End If
End Function
Private Sub ensureCapacity(ByVal minCapacity As Long)
    If capacity >= minCapacity Then
        Exit Sub
    End If
    Dim newCapacity As Long
    newCapacity = capacity
    Do While newCapacity < minCapacity
        newCapacity = newCapacity + newCapacity
    Loop
    s = s & String((newCapacity - capacity) \ 2, ChrW(0))
    capacity = newCapacity
End Sub

[/mw_shl_code]

1

主题

46

帖子

171

积分

用户组: 小·技术宅

UID
4683
精华
0
威望
0 点
宅币
125 个
贡献
0 次
宅之契约
0 份
在线时间
20 小时
注册时间
2019-2-11
发表于 2019-7-25 20:29:09 | 显示全部楼层
没有示例的代码,差评。

1

主题

4

帖子

36

积分

用户组: 初·技术宅

UID
5181
精华
0
威望
0 点
宅币
32 个
贡献
0 次
宅之契约
0 份
在线时间
7 小时
注册时间
2019-7-25
 楼主| 发表于 2019-7-25 20:36:06 | 显示全部楼层
Ink_Hin_fifteen 发表于 2019-7-25 20:29
没有示例的代码,差评。

后续会添加

本版积分规则

QQ|申请友链||Archiver|手机版|小黑屋|技术宅的结界 ( 滇ICP备16008837号 )|网站地图

GMT+8, 2019-12-15 10:23 , Processed in 0.087326 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表