批处理之家 » VBS原创&转载 » 双字节字符转16进制utf-8编码工具 For 二维码生成器

老刘1号 发表于 2017-4-23 14:00

双字节字符转16进制utf-8编码工具 For 二维码生成器

[i=s] 本帖最后由 老刘1号 于 2017-4-23 17:53 编辑 [/i]

批处理版二维码生成器：[url=http://www.bathome.net/thread-32908-1-4.html]http://www.bathome.net/thread-32908-1-4.html[/url]

替作者完善下功能
现在可以支持所有双字节字符了（包括汉字）[code]
Option Explicit
Rem 老刘制作～
Rem 读取二进制函数块感谢一个不知名的老外，设置剪辑版感谢Demon，此外原创～
Rem 转载请注明作者昵称及批处理之家，感谢合作。
Randomize
Const ForReading = 1 , ForWriting = 2
Dim [需转换的文本],FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
[需转换的文本] = Replace( _
        InputBox("输入需要转换的文本：" & vbNewLine & "\n会被替换为回车符+换行符") , _
                "\n" , vbCrLf)
If [需转换的文本] = "" Then WScript.Quit
Dim [随机文件名]
[随机文件名] = Replace(Rnd,".","")
Dim [文件指针]
Set [文件指针] = _
        FSO.CreateTextFile(FSO.GetSpecialFolder(2)&"\"&[随机文件名]&".TMP",True)
[文件指针].Write [需转换的文本]
[文件指针].Close

[ANSI转UTF-8] FSO.GetSpecialFolder(2)&"\"&[随机文件名]&".TMP"

Dim [二进制数组],[元素指针],[UTF-8编码后文本二进制（使用0xHex表示）内容]
[二进制数组] = ReadBinary(FSO.GetSpecialFolder(2)&"\"&[随机文件名]&".TMP")
FSO.DeleteFile FSO.GetSpecialFolder(2)&"\"&[随机文件名]&".TMP",True

For [元素指针] = 0 To UBound([二进制数组])
        If Len(Hex([二进制数组]([元素指针]))) = 1 Then
                [UTF-8编码后文本二进制（使用0xHex表示）内容] = _
                        [UTF-8编码后文本二进制（使用0xHex表示）内容] & _
                        "\x0" & Hex([二进制数组]([元素指针]))
        Else
                [UTF-8编码后文本二进制（使用0xHex表示）内容] = _
                        [UTF-8编码后文本二进制（使用0xHex表示）内容] & _
                        "\x" & Hex([二进制数组]([元素指针]))
        End If
Next

[设置剪辑版] [UTF-8编码后文本二进制（使用0xHex表示）内容]

MsgBox "已经替你复制到了剪辑版～"


Rem ANSI转UTF-8
Sub [ANSI转UTF-8](FilePath)
        Dim objStream,objFSO
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objStream = CreateObject("Adodb.Stream")
        objStream.Type = 2
        objStream.Mode = 3
        objStream.Charset = "UTF-8"
        If objFSO.FileExists(FilePath) = True Then
                Dim Text
                Text = objFSO.OpenTextFile(FilePath,ForReading,False).ReadAll
                objFSO.DeleteFile FilePath,True
                objStream.Open
                objStream.WriteText Text
                objStream.SaveToFile FilePath
                objStream.Close
        End If
End Sub

Rem 读二进制
Function ReadBinary(FileName)
  Dim Buf(), I
  With CreateObject("ADODB.Stream")
    .Mode = 3: .Type = 1: .Open: .LoadFromFile FileName
    ReDim Buf(.Size - 1)
    For I = 0 To .Size - 1: Buf(I) = AscB(.Read(1)): Next
    .Close
  End With
  ReadBinary = Buf
End Function

Sub [设置剪辑版](Text)
    With CreateObject("Word.Application")
        .Documents.Add
        .Selection.Text = Text
        .Selection.Copy
        .Quit False
    End With
End Sub
[/code]

老刘1号 发表于 2023-2-19 23:00

[b]回复 [url=http://www.bathome.net/redirect.php?goto=findpost&pid=264450&ptid=43919]2#[/url] [i]jyswjjgdwtdtj[/i] [/b]


    当年的黑历史，甭管了…

查看完整版本: 双字节字符转16进制utf-8编码工具 For 二维码生成器