如何压缩字符串？
9 个解决方案
#1
用XML载体确实不错。
可以两端用压缩解压的算法来做。
不过对接收端要求比较高。因为压缩数据可能不是一次传过来的。所以要等到全部传输完毕，组合成原始压缩数据，才能解压缩。
我的C/S系统，就用的这个技术。
我用Huffman_Dynamic和LZW_Multidict算法，两种算法各有优缺点。
Huffman_Dynamic
100.000% 21 21 0.000000秒 OK 0.000000秒
047.461% 571 271 0.015625秒 OK 0.000000秒
046.476% 1121 521 0.015625秒 OK 0.000000秒
046.140% 1671 771 0.015625秒 OK 0.015625秒
045.970% 2221 1021 0.015625秒 OK 0.015625秒
045.868% 2771 1271 0.031250秒 OK 0.015625秒
045.799% 3321 1521 0.031250秒 OK 0.031250秒
045.750% 3871 1771 0.046875秒 OK 0.031250秒
045.714% 4421 2021 0.031250秒 OK 0.046875秒
045.685% 4971 2271 0.046875秒 OK 0.062500秒
045.662% 5521 2521 0.062500秒 OK 0.046875秒
045.643% 6071 2771 0.062500秒 OK 0.062500秒
045.628% 6621 3021 0.062500秒 OK 0.078125秒
045.614% 7171 3271 0.062500秒 OK 0.062500秒
045.603% 7721 3521 0.062500秒 OK 0.078125秒
045.593% 8271 3771 0.078125秒 OK 0.078125秒
045.584% 8821 4021 0.078125秒 OK 0.078125秒
045.577% 9371 4271 0.093750秒 OK 0.078125秒
045.570% 9921 4521 0.093750秒 OK 0.093750秒
045.564% 10471 4771 0.078125秒 OK 0.109375秒
LZW_MultyDict
076.190% 21 16 0.015625秒 OK 0.000000秒
004.729% 571 27 0.000000秒 OK 0.000000秒
003.122% 1121 35 0.000000秒 OK 0.000000秒
002.454% 1671 41 0.015625秒 OK 0.000000秒
002.071% 2221 46 0.000000秒 OK 0.000000秒
001.877% 2771 52 0.015625秒 OK 0.000000秒
001.716% 3321 57 0.015625秒 OK 0.000000秒
001.602% 3871 62 0.015625秒 OK 0.015625秒
001.515% 4421 67 0.015625秒 OK 0.000000秒
001.509% 4971 75 0.015625秒 OK 0.000000秒
001.449% 5521 80 0.015625秒 OK 0.000000秒
001.400% 6071 85 0.031250秒 OK 0.000000秒
001.359% 6621 90 0.015625秒 OK 0.015625秒
001.325% 7171 95 0.015625秒 OK 0.015625秒
001.295% 7721 100 0.015625秒 OK 0.000000秒
001.294% 8271 107 0.015625秒 OK 0.015625秒
001.270% 8821 112 0.031250秒 OK 0.000000秒
001.249% 9371 117 0.031250秒 OK 0.000000秒
001.230% 9921 122 0.031250秒 OK 0.000000秒
001.213% 10471 127 0.031250秒 OK 0.000000秒
以上是测试报告，百分比是压缩效率。
上面报告依次是：压缩比，数据量，压缩后数据量，压缩时间，成功标志，解压缩时间
当然，可以给我发信交流。
可以两端用压缩解压的算法来做。
不过对接收端要求比较高。因为压缩数据可能不是一次传过来的。所以要等到全部传输完毕，组合成原始压缩数据，才能解压缩。
我的C/S系统，就用的这个技术。
我用Huffman_Dynamic和LZW_Multidict算法，两种算法各有优缺点。
Huffman_Dynamic
100.000% 21 21 0.000000秒 OK 0.000000秒
047.461% 571 271 0.015625秒 OK 0.000000秒
046.476% 1121 521 0.015625秒 OK 0.000000秒
046.140% 1671 771 0.015625秒 OK 0.015625秒
045.970% 2221 1021 0.015625秒 OK 0.015625秒
045.868% 2771 1271 0.031250秒 OK 0.015625秒
045.799% 3321 1521 0.031250秒 OK 0.031250秒
045.750% 3871 1771 0.046875秒 OK 0.031250秒
045.714% 4421 2021 0.031250秒 OK 0.046875秒
045.685% 4971 2271 0.046875秒 OK 0.062500秒
045.662% 5521 2521 0.062500秒 OK 0.046875秒
045.643% 6071 2771 0.062500秒 OK 0.062500秒
045.628% 6621 3021 0.062500秒 OK 0.078125秒
045.614% 7171 3271 0.062500秒 OK 0.062500秒
045.603% 7721 3521 0.062500秒 OK 0.078125秒
045.593% 8271 3771 0.078125秒 OK 0.078125秒
045.584% 8821 4021 0.078125秒 OK 0.078125秒
045.577% 9371 4271 0.093750秒 OK 0.078125秒
045.570% 9921 4521 0.093750秒 OK 0.093750秒
045.564% 10471 4771 0.078125秒 OK 0.109375秒
LZW_MultyDict
076.190% 21 16 0.015625秒 OK 0.000000秒
004.729% 571 27 0.000000秒 OK 0.000000秒
003.122% 1121 35 0.000000秒 OK 0.000000秒
002.454% 1671 41 0.015625秒 OK 0.000000秒
002.071% 2221 46 0.000000秒 OK 0.000000秒
001.877% 2771 52 0.015625秒 OK 0.000000秒
001.716% 3321 57 0.015625秒 OK 0.000000秒
001.602% 3871 62 0.015625秒 OK 0.015625秒
001.515% 4421 67 0.015625秒 OK 0.000000秒
001.509% 4971 75 0.015625秒 OK 0.000000秒
001.449% 5521 80 0.015625秒 OK 0.000000秒
001.400% 6071 85 0.031250秒 OK 0.000000秒
001.359% 6621 90 0.015625秒 OK 0.015625秒
001.325% 7171 95 0.015625秒 OK 0.015625秒
001.295% 7721 100 0.015625秒 OK 0.000000秒
001.294% 8271 107 0.015625秒 OK 0.015625秒
001.270% 8821 112 0.031250秒 OK 0.000000秒
001.249% 9371 117 0.031250秒 OK 0.000000秒
001.230% 9921 122 0.031250秒 OK 0.000000秒
001.213% 10471 127 0.031250秒 OK 0.000000秒
以上是测试报告，百分比是压缩效率。
上面报告依次是：压缩比，数据量，压缩后数据量，压缩时间，成功标志，解压缩时间
当然，可以给我发信交流。
#2
压缩 还不如 传送那 vb压缩很慢的
#3
winsock其实传送很快的
至少比拟压缩了在传快
至少比拟压缩了在传快
#4
支持楼上的，一般几百上千条记录持久化后也不过几百K,无论是用Winsock还是http，只要网络稳定，传送起来开销不大。
#5
最好的办法还是
不用XML
用COM+不好吗？
不用XML
用COM+不好吗？
#6
以前我们的程序就是用XML，winsock传送，服务器端还是VC写的多线程的呢；
但是数据转为纯文本本身就效率低，再加上额外的标签，解析操作，效率极低啊，C/S程序搞得像B/S似的，最慢要等上好几秒，无法忍受啊~
但是数据转为纯文本本身就效率低，再加上额外的标签，解析操作，效率极低啊，C/S程序搞得像B/S似的，最慢要等上好几秒，无法忍受啊~
#7
我们用的XML还不是Recordset，是BusinessObject或BO的集合
最后通过优化代码，精简数据，精简XML标签，费尽周折才使性能到可以忍受的地步~
最后通过优化代码，精简数据，精简XML标签，费尽周折才使性能到可以忍受的地步~
#8
我以前做过类似的项目。最后的实现方式是在服务器端压缩，然后传输到客户端后解压。
由于传输的都是XML文件，重复内容最多的其实是XML标签，考虑到VB的效率问题，我并没有用二进制方式进行压缩，而是直接对文本进行了压缩。压缩算法是参考的LZW算法。
源码如下：
Option Explicit
Private strZiped As String
Const MAX_WND_SIZE As Long = 8191
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Public Function Zip(FromString As String) As String
'压缩传入的字符串
Dim strIn As String
Dim strOut As String
Dim lngLenIn As Long
Dim strWin As String '窗口内的字符串
Dim strNew As String '要处理的字符串
Dim strHave As String '已确定包含的字符串
Dim strNewEnd As String '要处理字符串的最后一个字符
Dim blnHave As Boolean '标识要处理的字符串是否包含在窗口内
Dim lngOff As Long
Dim lngLen As Long
Dim lngOffNew As Long
Dim strOff As String
Dim strLen As String
Dim i As Long, ii As Long
strIn = FromString
lngLenIn = Len(strIn)
strOut = Space(lngLenIn * 10)
ii = 1
i = 1
While i <= lngLenIn
strNew = ""
strHave = ""
blnHave = True
While blnHave And (i <= lngLenIn)
strHave = strNew
lngOff = lngOffNew
strNewEnd = Mid$(strIn, i, 1)
strNew = strNew & strNewEnd
lngOffNew = Val(InStr(1, strWin, strNew))
blnHave = Not (lngOffNew = 0)
If blnHave Then
i = i + 1
Else
strWin = Right(strWin & strNew, MAX_WND_SIZE)
End If
Wend
i = i + 1
'记录三元符号组
strOff = LngToChr(lngOff)
If lngOff > 0 Then
lngLen = Len(strHave)
strLen = LngToChr(lngLen)
' strOut = strOut & strOff & strLen & strNewEnd
'
Mid$(strOut, ii, Len(strOff)) = strOff
ii = ii + Len(strOff)
Mid$(strOut, ii, Len(strLen)) = strLen
ii = ii + Len(strLen)
Mid$(strOut, ii, Len(strNewEnd)) = strNewEnd
ii = ii + Len(strNewEnd)
ElseIf lngOff = 0 Then
' strOut = strOut & strOff & strNewEnd
Mid$(strOut, ii, Len(strOff)) = strOff
ii = ii + Len(strOff)
Mid$(strOut, ii, Len(strNewEnd)) = strNewEnd
ii = ii + Len(strNewEnd)
End If
Wend
strOut = Mid$(strOut, 1, ii - 1)
Zip = strOut
End Function
Public Function UnZip(FromString As String) As String
'解压传入的字符串
On Error Resume Next
Dim strIn As String
Dim strOut As String
Dim lngLenIn As Long
Dim strRange As String '在窗口中找到的替代字符
Dim strWin As String
Dim i As Long, ii As Long
Dim lngOff As Long '
Dim lngLen As Long
Dim strNew As String
Dim lngNewAsc As Long, lngNewAsc2 As Long
strIn = FromString
lngLenIn = Len(strIn)
strOut = Space(lngLenIn * 25)
ii = 1
i = 1
While i <= lngLenIn
'得到Off
lngOff = CLng(AscW(Mid$(strIn, i, 1))) + CLng(AscW(Mid$(strIn, i + 1, 1))) * 256
'得到Len
If lngOff = 0 Then
lngLen = 0
'得到下一字符
lngNewAsc = Asc(Mid$(strIn, i + 2, 1))
If lngNewAsc > 255 Then '双字节
lngNewAsc2 = Asc(Mid$(strIn, i + 3, 1))
strNew = Chr(Val("&H" & Hex(lngNewAsc) & Hex(lngNewAsc2)))
i = i + 4
Else
strNew = Chr(lngNewAsc)
i = i + 3
End If
Else
lngLen = CLng(AscW(Mid$(strIn, i + 2, 1))) + CLng(AscW(Mid$(strIn, i + 3, 1))) * 256
'在窗口中查找
strRange = Mid$(strWin, lngOff, lngLen)
'strOut = strOut & strRange
Mid$(strOut, ii, Len(strRange)) = strRange
ii = ii + Len(strRange)
strWin = Right(strWin & strRange, MAX_WND_SIZE)
'得到下一字符
lngNewAsc = Asc(Mid$(strIn, i + 4, 1))
If lngNewAsc > 255 Then '双字节
lngNewAsc2 = Asc(Mid$(strIn, i + 5, 1))
strNew = Chr(Val("&H" & Hex(lngNewAsc) & Hex(lngNewAsc2)))
i = i + 6
Else
strNew = Chr(lngNewAsc)
i = i + 5
End If
End If
' strOut = strOut & strNew
Mid$(strOut, ii, Len(strNew)) = strNew
ii = ii + Len(strNew)
'新窗口内容
strWin = Right(strWin & strNew, MAX_WND_SIZE)
Wend
strOut = Mid$(strOut, 1, ii - 1)
UnZip = strOut
End Function
Private Function LngToChr(lngIn As Long) As String
Dim b() As Byte
Dim m As Long
Dim s As String
m = lngIn
' Select Case lngIn
' Case Is <= 255
' ReDim b(0)
' CopyMemory VarPtr(b(0)), VarPtr(m), 4
' s = Chr(b(0))
' Case Is > 255
ReDim b(1)
CopyMemory VarPtr(b(0)), VarPtr(m), 4
s = ChrW(b(0)) & ChrW(b(1))
' End Select
LngToChr = s
End Function
Private Function Golomb(lngLen As Long, pm As Long) As String
Dim m As Long
Dim b As Long
Dim q As Long
Dim r As Long
Dim s As String
m = pm
b = 2 ^ m
q = Int((lngLen - 1) / b)
r = lngLen - q * b - 1
s = String(q, "1") & "0" & Format(HexChange(Hex(r)), String(m, "0"))
Golomb = s
End Function
Private Function HexChange(ByVal vHexCode As String) As String
On Error GoTo ErrOPR
vHexCode = UCase(vHexCode)
If Not IsNumeric("&H" & vHexCode) Then Exit Function
Dim i%
For i = 1 To Len(vHexCode)
HexChange = HexChange & DoHex(Mid$(vHexCode, i, 1))
Next
'HexChange = Format(HexChange, "0000000000000000")
Exit Function
ErrOPR:
HexChange = ""
End Function
Private Function DoHex(ByVal vHexCode As String) As String
Dim tA%, tB$, n%
If vHexCode <> "0" Then
tA = CInt("&H" & vHexCode)
Do Until tA = 0
n = tA Mod 2
tB = n & tB
tA = tA \ 2
Loop
DoHex = Format(tB, "0000")
Else
DoHex = "0000"
End If
End Function
由于传输的都是XML文件，重复内容最多的其实是XML标签，考虑到VB的效率问题，我并没有用二进制方式进行压缩，而是直接对文本进行了压缩。压缩算法是参考的LZW算法。
源码如下：
Option Explicit
Private strZiped As String
Const MAX_WND_SIZE As Long = 8191
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Public Function Zip(FromString As String) As String
'压缩传入的字符串
Dim strIn As String
Dim strOut As String
Dim lngLenIn As Long
Dim strWin As String '窗口内的字符串
Dim strNew As String '要处理的字符串
Dim strHave As String '已确定包含的字符串
Dim strNewEnd As String '要处理字符串的最后一个字符
Dim blnHave As Boolean '标识要处理的字符串是否包含在窗口内
Dim lngOff As Long
Dim lngLen As Long
Dim lngOffNew As Long
Dim strOff As String
Dim strLen As String
Dim i As Long, ii As Long
strIn = FromString
lngLenIn = Len(strIn)
strOut = Space(lngLenIn * 10)
ii = 1
i = 1
While i <= lngLenIn
strNew = ""
strHave = ""
blnHave = True
While blnHave And (i <= lngLenIn)
strHave = strNew
lngOff = lngOffNew
strNewEnd = Mid$(strIn, i, 1)
strNew = strNew & strNewEnd
lngOffNew = Val(InStr(1, strWin, strNew))
blnHave = Not (lngOffNew = 0)
If blnHave Then
i = i + 1
Else
strWin = Right(strWin & strNew, MAX_WND_SIZE)
End If
Wend
i = i + 1
'记录三元符号组
strOff = LngToChr(lngOff)
If lngOff > 0 Then
lngLen = Len(strHave)
strLen = LngToChr(lngLen)
' strOut = strOut & strOff & strLen & strNewEnd
'
Mid$(strOut, ii, Len(strOff)) = strOff
ii = ii + Len(strOff)
Mid$(strOut, ii, Len(strLen)) = strLen
ii = ii + Len(strLen)
Mid$(strOut, ii, Len(strNewEnd)) = strNewEnd
ii = ii + Len(strNewEnd)
ElseIf lngOff = 0 Then
' strOut = strOut & strOff & strNewEnd
Mid$(strOut, ii, Len(strOff)) = strOff
ii = ii + Len(strOff)
Mid$(strOut, ii, Len(strNewEnd)) = strNewEnd
ii = ii + Len(strNewEnd)
End If
Wend
strOut = Mid$(strOut, 1, ii - 1)
Zip = strOut
End Function
Public Function UnZip(FromString As String) As String
'解压传入的字符串
On Error Resume Next
Dim strIn As String
Dim strOut As String
Dim lngLenIn As Long
Dim strRange As String '在窗口中找到的替代字符
Dim strWin As String
Dim i As Long, ii As Long
Dim lngOff As Long '
Dim lngLen As Long
Dim strNew As String
Dim lngNewAsc As Long, lngNewAsc2 As Long
strIn = FromString
lngLenIn = Len(strIn)
strOut = Space(lngLenIn * 25)
ii = 1
i = 1
While i <= lngLenIn
'得到Off
lngOff = CLng(AscW(Mid$(strIn, i, 1))) + CLng(AscW(Mid$(strIn, i + 1, 1))) * 256
'得到Len
If lngOff = 0 Then
lngLen = 0
'得到下一字符
lngNewAsc = Asc(Mid$(strIn, i + 2, 1))
If lngNewAsc > 255 Then '双字节
lngNewAsc2 = Asc(Mid$(strIn, i + 3, 1))
strNew = Chr(Val("&H" & Hex(lngNewAsc) & Hex(lngNewAsc2)))
i = i + 4
Else
strNew = Chr(lngNewAsc)
i = i + 3
End If
Else
lngLen = CLng(AscW(Mid$(strIn, i + 2, 1))) + CLng(AscW(Mid$(strIn, i + 3, 1))) * 256
'在窗口中查找
strRange = Mid$(strWin, lngOff, lngLen)
'strOut = strOut & strRange
Mid$(strOut, ii, Len(strRange)) = strRange
ii = ii + Len(strRange)
strWin = Right(strWin & strRange, MAX_WND_SIZE)
'得到下一字符
lngNewAsc = Asc(Mid$(strIn, i + 4, 1))
If lngNewAsc > 255 Then '双字节
lngNewAsc2 = Asc(Mid$(strIn, i + 5, 1))
strNew = Chr(Val("&H" & Hex(lngNewAsc) & Hex(lngNewAsc2)))
i = i + 6
Else
strNew = Chr(lngNewAsc)
i = i + 5
End If
End If
' strOut = strOut & strNew
Mid$(strOut, ii, Len(strNew)) = strNew
ii = ii + Len(strNew)
'新窗口内容
strWin = Right(strWin & strNew, MAX_WND_SIZE)
Wend
strOut = Mid$(strOut, 1, ii - 1)
UnZip = strOut
End Function
Private Function LngToChr(lngIn As Long) As String
Dim b() As Byte
Dim m As Long
Dim s As String
m = lngIn
' Select Case lngIn
' Case Is <= 255
' ReDim b(0)
' CopyMemory VarPtr(b(0)), VarPtr(m), 4
' s = Chr(b(0))
' Case Is > 255
ReDim b(1)
CopyMemory VarPtr(b(0)), VarPtr(m), 4
s = ChrW(b(0)) & ChrW(b(1))
' End Select
LngToChr = s
End Function
Private Function Golomb(lngLen As Long, pm As Long) As String
Dim m As Long
Dim b As Long
Dim q As Long
Dim r As Long
Dim s As String
m = pm
b = 2 ^ m
q = Int((lngLen - 1) / b)
r = lngLen - q * b - 1
s = String(q, "1") & "0" & Format(HexChange(Hex(r)), String(m, "0"))
Golomb = s
End Function
Private Function HexChange(ByVal vHexCode As String) As String
On Error GoTo ErrOPR
vHexCode = UCase(vHexCode)
If Not IsNumeric("&H" & vHexCode) Then Exit Function
Dim i%
For i = 1 To Len(vHexCode)
HexChange = HexChange & DoHex(Mid$(vHexCode, i, 1))
Next
'HexChange = Format(HexChange, "0000000000000000")
Exit Function
ErrOPR:
HexChange = ""
End Function
Private Function DoHex(ByVal vHexCode As String) As String
Dim tA%, tB$, n%
If vHexCode <> "0" Then
tA = CInt("&H" & vHexCode)
Do Until tA = 0
n = tA Mod 2
tB = n & tB
tA = tA \ 2
Loop
DoHex = Format(tB, "0000")
Else
DoHex = "0000"
End If
End Function
#9
对这种算法来说，被压缩文件中的重复内容越多，压缩率就越高，这就比较适合用于压缩XML格式的Recordset。
智能推荐
注意！
本站转载的文章为个人学习借鉴使用，本站对版权不负任何法律责任。如果侵犯了您的隐私权益，请联系我们删除。