主页

如何对这段代码提速

progame 2004-03-29 02:38:09

''
' Convert binary stream to string with hexadecimal representation.
'
'@param value binary stream
'
'@return encoding string
Public Function BinaryToString(value() As Byte) As String
Dim s() As String
Dim i As Long

ReDim s(UBound(value))

For i = LBound(value) To UBound(value)

If value(i) > 15 Then
s(i) = Hex(value(i))
Else
s(i) = "0" & Hex(value(i))
End If

Next i

BinaryToString = "0x" & Join(s, "")

Erase s

End Function

''
' Convert hexadecimal representation string to binary stream.
'
'@param value string
'
'@return decoding stream
Public Function StringToBinary(ByVal value As String) As Byte()
Dim arr() As Byte
Dim i As Long

If Left(value, 2) <> "0x" Then
Err.Raise vbObjectError, , "not binary string."
End If

value = Right(value, Len(value) - 2)

ReDim arr(Len(value) / 2 - 1)

For i = LBound(arr) To UBound(arr)
arr(i) = CByte("&H" & Mid(value, i * 2 + 1, 2))
Next i

StringToBinary = arr

End Function

这两个函数主要是完成一个二进制数据到十六进制字符串的转换
可是对于1M的数据，耗时居然要20多s
有没有什么方法提速？

在用join之前，直接拼字符串，更是速度慢得难以忍受

...全文

13 条回复

切换为时间正序

请发表友善的回复…

发表回复

progame 2004-03-30

''
' Convert hexadecimal representation string to binary stream.
'
'@param value string
'
'@return decoding stream
Public Function StringToBinary(ByVal value As String) As Byte()
Dim arr() As Byte
Dim i As Long
Dim t As Single

t = Timer

Dim dic As New Scripting.Dictionary

For i = 0 To 255
If i > 15 Then
dic.Add Hex(i), i
Else
dic.Add "0" & Hex(i), i
End If
Next i

If Left(value, 2) <> "0x" Then
Err.Raise vbObjectError, , "not binary string."
End If

ReDim arr(Len(value) / 2 - 2)

For i = LBound(arr) To UBound(arr)
arr(i) = dic.Item(Mid(value, i * 2 + 3, 2))
Next i

StringToBinary = arr

Debug.Print "string to binary:"; Timer - t

End Function

略有提升

回复赞

liyan010 2004-03-30

百家争鸣啊，不错，学习

回复赞

progame 2004-03-30

起　继续征求第二个函数的改进方案

回复赞

progame 2004-03-29

Public Function BinaryToString3(value() As Byte) As String
Dim x(255) As String
Dim s As String
Dim i As Long
i = (UBound(value) - LBound(value) + 1) * 2

s = Space(i)

For i = 0 To 255
If i > 15 Then
x(i) = Hex(i)
Else
x(i) = "0" & Hex(i)
End If
Next i

For i = LBound(value) To UBound(value)
Mid(s, 2 * i + 1, 2) = x(value(i))
Next i

BinaryToString3 = "0x" & s

End Function

原来的是2.4s 这个函数是0.8s

回复赞

progame 2004-03-29

那么再小改一下：
s = String(i, "0")
For i = LBound(value) To UBound(value)
If value(i) > 15 Then
Mid(s, 2 * i + 1, 2) = Hex(value(i))
Else
Mid(s, 2 * i + 2, 1) = Hex(value(i))
End If
Next i

回复赞

rainstormmaster 2004-03-29

//差别没这么大的.
精确千分一秒后,加$和不加$只差0.05秒.对不起了. 算我没有来过..呵呵.....

加上也很好啊：）

回复赞

华芸智森 2004-03-29

差别没这么大的.
精确千分一秒后,加$和不加$只差0.05秒.对不起了. 算我没有来过..呵呵.....
MsgBox (Timer() - d) / 1000

回复赞

华芸智森 2004-03-29

在 rainstormmaster(暴风雨 v2.0) 的基础.多加一个$.
不加时我的电脑是"2秒",加后是"1秒".
'-------------------------------------------------------
Public Function BinaryToString(value() As Byte) As String
Dim i As Long
i = (UBound(value) - LBound(value) + 1) * 2

Dim s As String
s = Space(i)
For i = LBound(value) To UBound(value)
If value(i) > 15 Then
Mid$(s, 2 * i + 1, 2) = Hex$(value(i))
Else
Mid$(s, 2 * i + 1, 2) = "0" & Hex$(value(i))
End If
Next
BinaryToString = "0x" & s
End Function

回复赞

lfshf 2004-03-29

向rainstormmaster(暴风雨 v2.0) 表示景仰！有技术且非常热心。

回复赞

progame 2004-03-29

不错的方法　谢谢

回复赞

rainstormmaster 2004-03-29

修改了一下BinaryToString，用mid语句加速了字串赋值，处理vba6.dll（1.62M），耗时4秒左右：

Option Explicit
Public Function BinaryToString(value() As Byte) As String
Dim i As Long
i = (UBound(value) - LBound(value) + 1) * 2
Dim s As String
s = Space(i)
For i = LBound(value) To UBound(value)
If value(i) > 15 Then
Mid(s, 2 * i + 1, 2) = Hex(value(i))
Else
Mid(s, 2 * i + 1, 2) = "0" & Hex(value(i))
End If
Next i
BinaryToString = "0x" & s
End Function

Private Sub Command1_Click()
Dim d As Date
d = Now
Dim mfile As String
mfile = "e:\vba6.dll"
Dim buff() As Byte
Dim i As Long
i = FileLen(mfile)
ReDim buff(i - 1)
Open mfile For Binary As #1
Get #1, , buff
Close #1
Dim s As String
s = BinaryToString(buff)
Debug.Print s
MsgBox DateDiff("s", d, Now)
End Sub

回复赞