谁说我不厚道!!! ^-^ private sub cmdTest_click() dim sStr as string Open App.Path & "\Model\head" For Input As #1 Input #1, sStr Close #1 Call SaveToUTF8(sStr) end sub Private Sub SaveToUTF8(sStr as string) On Error GoTo OutError Dim DAT() As Byte, DAT1() As Byte, ST As String Dim Z As String Dim zTem As String Dim zCod As String Dim zHex As String Dim zBin As String Dim zRes As Long Dim zAsc As Long Dim L As Long, 字节计数 Dim i1 As Long Dim i2 As Integer Dim sFileName As StringFor i1 = 1 To Len(sStr) Z = Mid(sStr, i1, 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: ST = Right("0" & Hex(DAT1(1)), 2) & Right("0" & Hex(DAT1(0)), 2) For i2 = 1 To Len(ST) Z = Mid(ST, i2, 1) Select Case Z '将汉字的16进制Unicode编码转换为二进制的 Case Is = "0": zBin = zBin & "0000" Case Is = "1": zBin = zBin & "0001" Case Is = "2": zBin = zBin & "0010" Case Is = "3": zBin = zBin & "0011" Case Is = "4": zBin = zBin & "0100" Case Is = "5": zBin = zBin & "0101" Case Is = "6": zBin = zBin & "0110" Case Is = "7": zBin = zBin & "0111" Case Is = "8": zBin = zBin & "1000" Case Is = "9": zBin = zBin & "1001" Case Is = "A": zBin = zBin & "1010" Case Is = "B": zBin = zBin & "1011" Case Is = "C": zBin = zBin & "1100" Case Is = "D": zBin = zBin & "1101" Case Is = "E": zBin = zBin & "1110" Case Is = "F": zBin = zBin & "1111" End Select Next zTem = "1110" & Left(zBin, 4) & "10" & Mid(zBin, 5, 6) & "10" & Right(zBin, 6) For i2 = 1 To 24 Z = Mid(zTem, i2, 1) zRes = zRes + IIf(Z = "1", 1 * 2 ^ (24 - i2), 0 * 2 ^ (24 - i2)) Next Z = Hex(zRes) '汉字已转换为3字节的16进制数据 DAT(L) = val("&H" & Left(Z, 2)) DAT(L + 1) = val("&H" & Mid(Z, 3, 2)) DAT(L + 2) = val("&H" & Right(Z, 2)) L = L + 3 End If zBin = "": zRes = 0 Next ReDim DAT1(2) As Byte DAT1(0) = &HEF: DAT1(1) = &HBB: DAT1(2) = &HBFCdlgEOP.filename = "" CdlgEOP.ShowOpensFileName = Trim(CdlgEOP.filename) If sFileName = "" Then Exit Sub DAT(UBound(DAT)) = 32Open sFileName For Binary As #1 Put #1, , DAT1 Put #1, , DAT Close #1 OutError: Close End Sub
^-^
private sub cmdTest_click()
dim sStr as string
Open App.Path & "\Model\head" For Input As #1
Input #1, sStr
Close #1
Call SaveToUTF8(sStr)
end sub Private Sub SaveToUTF8(sStr as string)
On Error GoTo OutError
Dim DAT() As Byte, DAT1() As Byte, ST As String
Dim Z As String
Dim zTem As String
Dim zCod As String
Dim zHex As String
Dim zBin As String
Dim zRes As Long
Dim zAsc As Long
Dim L As Long, 字节计数
Dim i1 As Long
Dim i2 As Integer
Dim sFileName As StringFor i1 = 1 To Len(sStr)
Z = Mid(sStr, i1, 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: ST = Right("0" & Hex(DAT1(1)), 2) & Right("0" & Hex(DAT1(0)), 2)
For i2 = 1 To Len(ST)
Z = Mid(ST, i2, 1)
Select Case Z '将汉字的16进制Unicode编码转换为二进制的
Case Is = "0": zBin = zBin & "0000"
Case Is = "1": zBin = zBin & "0001"
Case Is = "2": zBin = zBin & "0010"
Case Is = "3": zBin = zBin & "0011"
Case Is = "4": zBin = zBin & "0100"
Case Is = "5": zBin = zBin & "0101"
Case Is = "6": zBin = zBin & "0110"
Case Is = "7": zBin = zBin & "0111"
Case Is = "8": zBin = zBin & "1000"
Case Is = "9": zBin = zBin & "1001"
Case Is = "A": zBin = zBin & "1010"
Case Is = "B": zBin = zBin & "1011"
Case Is = "C": zBin = zBin & "1100"
Case Is = "D": zBin = zBin & "1101"
Case Is = "E": zBin = zBin & "1110"
Case Is = "F": zBin = zBin & "1111"
End Select
Next
zTem = "1110" & Left(zBin, 4) & "10" & Mid(zBin, 5, 6) & "10" & Right(zBin, 6)
For i2 = 1 To 24
Z = Mid(zTem, i2, 1)
zRes = zRes + IIf(Z = "1", 1 * 2 ^ (24 - i2), 0 * 2 ^ (24 - i2))
Next
Z = Hex(zRes) '汉字已转换为3字节的16进制数据
DAT(L) = val("&H" & Left(Z, 2))
DAT(L + 1) = val("&H" & Mid(Z, 3, 2))
DAT(L + 2) = val("&H" & Right(Z, 2))
L = L + 3
End If
zBin = "": zRes = 0
Next
ReDim DAT1(2) As Byte
DAT1(0) = &HEF: DAT1(1) = &HBB: DAT1(2) = &HBFCdlgEOP.filename = ""
CdlgEOP.ShowOpensFileName = Trim(CdlgEOP.filename)
If sFileName = "" Then Exit Sub
DAT(UBound(DAT)) = 32Open sFileName For Binary As #1
Put #1, , DAT1
Put #1, , DAT
Close #1
OutError:
Close
End Sub