求救:我的软件中需要把文本转换为UTF8 的URL 编码 下下面这个函数能实现,但是数据量大的时候非常慢!有没有大虾能优化这个代码的算法或者有更好的算法!谢谢
Function UTF8EncodeURI(szInput)
Dim wch, uch, szRet
Dim x
Dim nAsc, nAsc2, nAsc3 If szInput = "" Then
UTF8EncodeURI = szInput
Exit Function
End If For x = 1 To Len(szInput)
wch = Mid(szInput, x, 1)
nAsc = AscW(wch) If nAsc < 0 Then nAsc = nAsc + 65536 If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next UTF8EncodeURI = szRet
End Function
Function UTF8EncodeURI(szInput)
Dim wch, uch, szRet
Dim x
Dim nAsc, nAsc2, nAsc3 If szInput = "" Then
UTF8EncodeURI = szInput
Exit Function
End If For x = 1 To Len(szInput)
wch = Mid(szInput, x, 1)
nAsc = AscW(wch) If nAsc < 0 Then nAsc = nAsc + 65536 If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next UTF8EncodeURI = szRet
End Function
Dim strOutput As String
Dim intAscii As Integer
Dim i As Integer
For i = 1 To Len(strInput)
intAscii = Asc(Mid(strInput, i, 1))
If ((intAscii < 58) And (intAscii > 47)) Or _
((intAscii < 91) And (intAscii > 64)) Or _
((intAscii < 123) And (intAscii > 96)) Then
strOutput = strOutput & Chr$(intAscii)
Else
strOutput = strOutput & _
IIf(intAscii < 16, "%0", "%") & _
Trim$(Hex$(intAscii))
End If
Next
URLEncode = strOutput
End Function
Dim i As Long
Dim ansi() As Byte
Dim ascii As Integer
Dim encText As String ansi = StrConv(urlText, vbFromUnicode) encText = ""
For i = 0 To UBound(ansi)
ascii = ansi(i) Select Case ascii
Case 48 To 57, 65 To 90, 97 To 122
encText = encText & chr(ascii) Case 32
encText = encText & "+" Case Else
If ascii < 16 Then
encText = encText & "%0" & Hex(ascii)
Else
encText = encText & "%" & Hex(ascii)
End If End Select
Next i
UrlEncode = encText
End Function
在VB里,两个很长的字符串连接非常耗费时间,为了优化你的代码,你需要模仿.NET实现一个StringBuilder类,思路是:
使用一个私有变量保存字符串值,另一个私有变量保存追加字符串的缓存。提供如下方法:Append(string) 用来追加字符串
GetString,返回字符串。内部实现大致代码:private m_buffer As String '缓存
private m_data As StringSub Append(string s)
If len(m_buffer) < 500 Then '假设缓存500个字符,这个可以根据性能调整
m_buffer = m_buffer & s
Else
m_data = m_data & m_buffer
m_buffer = s
End If
End SubSub GetString()
m_data = m_data & m_buffer
m_buffer = ""
GetString = m_data
End If
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function UTF8_Encode(ByVal strUnicode As String) As Byte()
'UTF-8 编码
Dim TLen As Long
Dim lngBufferSize As Long
Dim lngResult As Long
Dim bytUtf8() As Byte
TLen = Len(strUnicode)
If TLen = 0 Then Exit Function
lngBufferSize = TLen * 3 + 1
ReDim bytUtf8(lngBufferSize - 1)
lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strUnicode), TLen, bytUtf8(0), lngBufferSize, vbNullString, 0)
If lngResult <> 0 Then
lngResult = lngResult - 1
ReDim Preserve bytUtf8(lngResult)
End If
UTF8_Encode = bytUtf8
End Function
Public Function UTF8_Decode(ByRef bUTF8() As Byte) As String
'UTF-8 解码
Dim lRet As Long
Dim lLen As Long
Dim lBufferSize As Long
Dim sBuffer As String
Dim bBuffer() As Byte
lLen = UBound(bUTF8) + 1
If lLen = 0 Then Exit Function
lBufferSize = lLen * 2
sBuffer = String$(lBufferSize, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(bUTF8(0)), lLen, StrPtr(sBuffer), lBufferSize)
If lRet <> 0 Then
sBuffer = Left(sBuffer, lRet)
End If
UTF8_Decode = sBuffer
End Function
Public Function CreateStringFromByte(ByRef byteArray() As Byte, ByVal ByteLength As Long) As String
'字节数组中的数据连接成字符串
Dim StringData As String
'** 分配字符串空间
StringData = Space(ByteLength)
'** 复制字符数组地址内容到字符串地址
MoveMemory ByVal StringData, ByVal VarPtr(byteArray(0)), ByteLength
'** 返回字符串
CreateStringFromByte = StringData
End Function
Public Function SaveStringToByteArry(ByRef strString As String) As Byte()
'把字符串存入字节数组
Dim BytArray() As Byte, lngStrLen As Long
'** 获取字符串的长度(字节)
lngStrLen = LenB(StrConv(strString, vbFromUnicode))
'** 分配数组空间
ReDim BytArray(lngStrLen - 1)
'** 将字符串地址中的内容拷贝到数组
MoveMemory ByVal VarPtr(BytArray(0)), ByVal strString, lngStrLen
SaveStringToByteArry = BytArray
End FunctionUTF8编解码
Ding...........^_^