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

Question

我这里有两个过程,希望可以做出函数调用,
Option Explicit
Dim DAT() As Byte, DAT1() As Byte
Dim Z As String
Dim i As LongPrivate 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 SubPrivate 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编写的类似代码，所以如果哪位兄弟
要将本代码转发到别的网站，请注明“转自新帆新闻组”以及笔者的
网名。

Answer 1

需要直接对字符串进行decode的函数

Answer 2

如果你的代码能运行的话，加个参数就可以调用了：
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 SubFunction 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 SubPrivate Sub OpenFile_Click()
Text1.Text = openutf8
End Sub

Answer 3

我需要的是通用的函数.
比如 我取得一个文件中某个位置的字符串a
想通过函数转出来 比如dim mystr() as byte
Open FileName For Binary As #1
redim mystr(20)
Get #1, 1, mystr
close 1然后用decodeutf8(mystr) 得到我要的正确字符串现在就是想转成decode和encode 函数

Answer 4

Option ExplicitPrivate 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

Answer 5

这样更合理一些：
'去除了无关的文件读写部分
'原来你的代码中在不能确定循环次数的情况下，错误的使用了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另外，程序没进行错误处理，你自己添加吧

Answer 6

前缀可以去除!前缀是用于导出到txt用的.
麻烦再改改?先送分

Answer 7

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 FunctionPrivate 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

Answer 8

试了一下.函数好像只能先encode 才能decode.不能直接decode?可能是我理解有问题

Answer 9

//试了一下.函数好像只能先encode 才能decode.如果你有需要解码的buff数组的话（比如说从文件里读出来），先decode也没有问题//在请问问,怎么给分呀!想送你也不行点 页面 右上 或 右下的"管理"

Answer 10

encode写入文件后为什么后面会多出很多e08080的16进制代码??是不是函数有问题