高手是否可以整理出一个函数?

iori8421 2005-12-17 08:41:35
我这里有两个过程,希望可以做出函数调用,
Option Explicit
Dim DAT() As Byte, DAT1() As Byte
Dim Z As String
Dim i As Long

Private Sub SaveToUTF8_Click()
On Error GoTo OutError
Dim zAsc As Long 'Ascii码暂存
Dim L As Long '字节计数
CD.Flags = &H200A
CD.DialogTitle = "另存为"
CD.Filter = "UTF-8文本(*.txt)|*.txt"
CD.ShowSave
If CD.FileName = "" Then Exit Sub
For i = 1 To Len(Text1)
Z = Mid(Text1, i, 1): zAsc = Asc(Z)
If zAsc > 0 Then '如果不是汉字
ReDim Preserve DAT(L + 1) As Byte
DAT(L) = zAsc: L = L + 1
Else
ReDim Preserve DAT(L + 3) As Byte
DAT1 = Z
DAT(L) = (DAT1(1) And 240) / 16 Or 224
DAT(L + 1) = (DAT1(1) And 15) * 4 + ((DAT1(0) And 192) / 64) Or 128
DAT(L + 2) = DAT1(0) And 63 Or 128
L = L + 3
End If
Next
ReDim DAT1(2) As Byte
DAT1(0) = &HEF: DAT1(1) = &HBB: DAT1(2) = &HBF
Open CD.FileName For Binary As #1
Put #1, , DAT1
Put #1, , DAT
OutError:
Close
End Sub

Private Sub OpenFile_Click()
On Error GoTo InErr
Dim ST As String
Dim LFile As Long '文件长度
CD.Flags = &H200C
CD.DialogTitle = "打开"
CD.Filter = "文本文件(*.txt)|*.txt"
CD.ShowOpen
ST = CD.FileName
If ST = "" Then Exit Sub
LFile = FileLen(ST) - 1
ReDim DAT(LFile) As Byte, DAT1(1) As Byte
Open ST For Binary As #1
Get #1, , DAT
If DAT(0) = &HEF And DAT(1) = &HBB And DAT(2) = &HBF Then
ST = ""
For i = 3 To LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
Else
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1: ST = ST & Z: i = i + 2
End If
Next
Else: ST = StrConv(DAT, vbUnicode)
End If
Text1 = ST: ST = ""
InErr:
Close
End Sub

笔者声明:
  因为目前网上还找不到用VB编写的类似代码,所以如果哪位兄弟
要将本代码转发到别的网站,请注明“转自新帆新闻组”以及笔者的
网名。
...全文
179 15 打赏 收藏 转发到动态 举报
写回复
用AI写文章
15 条回复
切换为时间正序
请发表友善的回复…
发表回复
iori8421 2005-12-21
  • 打赏
  • 举报
回复
encode写入文件后为什么后面会多出很多e08080的16进制代码??

是不是函数有问题
iori8421 2005-12-18
  • 打赏
  • 举报
回复
还是不能给分.
iori8421 2005-12-18
  • 打赏
  • 举报
回复
谢谢老大!搞定了
rainstormmaster 2005-12-18
  • 打赏
  • 举报
回复
//试了一下.函数好像只能先encode 才能decode.

如果你有需要解码的buff数组的话(比如说从文件里读出来),先decode也没有问题

//在请问问,怎么给分呀!想送你也不行

点 页面 右上 或 右下的"管理"
iori8421 2005-12-18
  • 打赏
  • 举报
回复
在请问问,怎么给分呀!想送你也不行
iori8421 2005-12-18
  • 打赏
  • 举报
回复
试了一下.函数好像只能先encode 才能decode.

不能直接decode?

可能是我理解有问题
rainstormmaster 2005-12-18
  • 打赏
  • 举报
回复
Private Function UTF8encode(ByVal s As String) As Byte()
If Len(s) = 0 Then Exit Function
Dim DAT() As Byte, DAT1() As Byte
Dim Z As String
Dim zAsc As Long 'Ascii码暂存
Dim L As Long '字节计数
Dim i As Long
For i = 1 To Len(s)
Z = Mid(s, i, 1)
zAsc = Asc(Z)
If zAsc > 0 Then '如果不是汉字
ReDim Preserve DAT(L + 1) As Byte
DAT(L) = zAsc
L = L + 1
Else
ReDim Preserve DAT(L + 3) As Byte
DAT1 = Z
DAT(L) = (DAT1(1) And 240) / 16 Or 224
DAT(L + 1) = (DAT1(1) And 15) * 4 + ((DAT1(0) And 192) / 64) Or 128
DAT(L + 2) = DAT1(0) And 63 Or 128
L = L + 3
End If
Next
UTF8encode = DAT
End Function

Private Function UTF8DECODE(DAT() As Byte) As String
Dim ST As String
Dim LFile As Long '文件长度
Dim Z As String
Dim i As Long
LFile = UBound(DAT)
i = 0
Dim DAT1(1) As Byte
ST = ""
Do While i <= LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
i = i + 1
Else
Debug.Print i
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1
ST = ST & Z
i = i + 3
End If
Loop
UTF8DECODE = ST
End Function
iori8421 2005-12-18
  • 打赏
  • 举报
回复
前缀可以去除!前缀是用于导出到txt用的.
麻烦再改改?

先送分
rainstormmaster 2005-12-18
  • 打赏
  • 举报
回复
这样更合理一些:
'去除了无关的文件读写部分
'原来你的代码中在不能确定循环次数的情况下,错误的使用了for循环,已改正
'参数DAT:传入的byte数组
'参数s:这个是我额外添加的,返回的是byte数组utf8解码后的字串
'返回值UTF8DECODE,是去除了你指定前缀的byte数组utf8解码后的字串
Private Function UTF8DECODE(DAT() As Byte, s As String) As String
Dim ST As String
Dim LFile As Long '文件长度
Dim Z As String
Dim i As Long
Dim DAT1(1) As Byte
LFile = UBound(DAT)
i = 0
ST = ""
Do While i <= LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
i = i + 1
Else
Debug.Print i
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1
ST = ST & Z
i = i + 3
End If
Loop
s = ST
If DAT(0) = &HEF And DAT(1) = &HBB And DAT(2) = &HBF Then
i = 3
ST = ""
Do While i <= LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
i = i + 1
Else
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1
ST = ST & Z
i = i + 3
End If
Loop
UTF8DECODE = ST
Exit Function
Else
UTF8DECODE = StrConv(DAT, vbUnicode)
End If
End Function

另外,程序没进行错误处理,你自己添加吧
rainstormmaster 2005-12-18
  • 打赏
  • 举报
回复
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'去除了无关的文件读写部分
'参数s:传入的字串
'参数buff:这个是我额外添加的,返回的是不加前缀的utf8编码
'返回值UTF8encode,是添加了你指定前缀的utf8编码
Private Function UTF8encode(ByVal s As String, buff() As Byte) As Byte()
If Len(s) = 0 Then Exit Function
Dim DAT() As Byte, DAT1() As Byte
Dim Z As String
Dim zAsc As Long 'Ascii码暂存
Dim L As Long '字节计数
Dim i As Long
For i = 1 To Len(s)
Z = Mid(s, i, 1)
zAsc = Asc(Z)
If zAsc > 0 Then '如果不是汉字
ReDim Preserve DAT(L + 1) As Byte
DAT(L) = zAsc
L = L + 1
Else
ReDim Preserve DAT(L + 3) As Byte
DAT1 = Z
DAT(L) = (DAT1(1) And 240) / 16 Or 224
DAT(L + 1) = (DAT1(1) And 15) * 4 + ((DAT1(0) And 192) / 64) Or 128
DAT(L + 2) = DAT1(0) And 63 Or 128
L = L + 3
End If
Next
ReDim DAT1(2) As Byte '这个是你定义的文件头吗
DAT1(0) = &HEF
DAT1(1) = &HBB
DAT1(2) = &HBF
i = UBound(DAT)
buff = DAT
Dim buff1() As Byte
ReDim buff1(i + 3)
CopyMemory buff1(0), DAT1(0), 3
CopyMemory buff1(3), DAT(0), i + 1
UTF8encode = buff1
End Function


'去除了无关的文件读写部分
'原来你的代码中在不能确定循环次数的情况下,错误的使用了for循环,已改正
'参数DAT:传入的byte数组
'参数s:这个是我额外添加的,返回的是byte数组utf8解码后的字串
'返回值UTF8DECODE,是去除了你指定前缀的byte数组utf8解码后的字串
Private Function UTF8DECODE(DAT() As Byte, s As String) As String
Dim ST As String
Dim LFile As Long '文件长度
Dim Z As String
Dim i As Long
Dim DAT1(1) As Byte
LFile = UBound(DAT)
If DAT(0) = &HEF And DAT(1) = &HBB And DAT(2) = &HBF Then
i = 3
ST = ""
Do While i <= LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
i = i + 1
Else
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1
ST = ST & Z
i = i + 3
End If
Loop
s = ST
UTF8DECODE = ST
Exit Function
Else
i = 0
ST = ""
Do While i <= LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
i = i + 1
Else
Debug.Print i
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1
ST = ST & Z
i = i + 3
End If
Loop
s = ST
UTF8DECODE = StrConv(DAT, vbUnicode)
End If
End Function
Private Sub Command1_Click()
Dim buff() As Byte, buff1() As Byte
Dim s As String, s1 As String, s2 As String
s = "hello中国abc1234"
buff = UTF8encode(s, buff1)
s1 = UTF8DECODE(buff, s2)
MsgBox s1
MsgBox s2
s1 = UTF8DECODE(buff1, s2)
MsgBox s1
MsgBox s2
End Sub
iori8421 2005-12-17
  • 打赏
  • 举报
回复
我需要的是通用的函数.
比如 我取得一个文件中某个位置的字符串a
想通过函数转出来 比如

dim mystr() as byte
Open FileName For Binary As #1
redim mystr(20)
Get #1, 1, mystr
close 1

然后用decodeutf8(mystr) 得到我要的正确字符串

现在就是想转成decode和encode 函数
iori8421 2005-12-17
  • 打赏
  • 举报
回复
怎么用呀!

没什么效果呀
rainstormmaster 2005-12-17
  • 打赏
  • 举报
回复
//我这里有两个过程,希望可以做出函数调用

呵呵,效率如何
northwolves 2005-12-17
  • 打赏
  • 举报
回复
如果你的代码能运行的话,加个参数就可以调用了:
Option Explicit


Sub savetoutf(ByVal mystr As String)
On Error GoTo OutError
Dim DAT() As Byte, DAT1() As Byte
Dim Z As String
Dim i As Long
Dim zAsc As Long 'Ascii码暂存
Dim L As Long '字节计数
CD.Flags = &H200A
CD.DialogTitle = "另存为"
CD.Filter = "UTF-8文本(*.txt)|*.txt"
CD.ShowSave
If CD.FileName = "" Then Exit Sub
For i = 1 To Len(mystr)
Z = Mid(Text1, i, 1): zAsc = Asc(Z)
If zAsc > 0 Then '如果不是汉字
ReDim Preserve DAT(L + 1) As Byte
DAT(L) = zAsc: L = L + 1
Else
ReDim Preserve DAT(L + 3) As Byte
DAT1 = Z
DAT(L) = (DAT1(1) And 240) / 16 Or 224
DAT(L + 1) = (DAT1(1) And 15) * 4 + ((DAT1(0) And 192) / 64) Or 128
DAT(L + 2) = DAT1(0) And 63 Or 128
L = L + 3
End If
Next
ReDim DAT1(2) As Byte
DAT1(0) = &HEF: DAT1(1) = &HBB: DAT1(2) = &HBF
Open CD.FileName For Binary As #1
Put #1, , DAT1
Put #1, , DAT
OutError:
Close
End Sub

Function openutf8() As String
Dim DAT() As Byte, DAT1() As Byte
Dim Z As String
Dim i As Long
On Error GoTo InErr
Dim ST As String
Dim LFile As Long '文件长度
CD.Flags = &H200C
CD.DialogTitle = "打开"
CD.Filter = "文本文件(*.txt)|*.txt"
CD.ShowOpen
ST = CD.FileName
If ST = "" Then Exit Function
LFile = FileLen(ST) - 1
ReDim DAT(LFile) As Byte, DAT1(1) As Byte
Open ST For Binary As #1
Get #1, , DAT
If DAT(0) = &HEF And DAT(1) = &HBB And DAT(2) = &HBF Then
ST = ""
For i = 3 To LFile
If DAT(i) < 128 Then
ST = ST & Chr(DAT(i))
Else
DAT1(1) = ((DAT(i) And 15) * 16 + (DAT(i + 1) And 60) / 4)
DAT1(0) = (DAT(i + 1) And 3) * 64 + (DAT(i + 2) And 63)
Z = DAT1: ST = ST & Z: i = i + 2
End If
Next
Else: ST = StrConv(DAT, vbUnicode)
End If
openutf8 = ST: ST = ""
InErr:
Close
End Function
Private Sub SaveToUTF8_Click()
savetoutf Text1.Text
End Sub

Private Sub OpenFile_Click()
Text1.Text = openutf8
End Sub
iori8421 2005-12-17
  • 打赏
  • 举报
回复
需要直接对字符串进行decode的函数

7,759

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧