您所在位置：主题：[原创]编写超级记事本必需的十六个功能源代码（三）
一江秋水
[专家分：9680] 发布于 2007-09-18 09:25:00
九、读、写Unicode和UFT－8编码的文本
1.Unicode编码文件的读写技术简述
Unicode编码是两字节的全编码，对于Ascii字符它也使用两字节表示，代码页通过高字
节的取值范围来确定是Ascii字符，还是汉字的高字节。
Unicode编码的文本文件开头两个字节是 &HFF 和 &HFE，这是它的标记。下面就简单介
绍如何在自编的文本编辑器中实现Unicode编码文本文件的读写。
我们知道VB的字符串在内存中实际上就是以Unicode编码形式保存的，但当程序将字符串
写入 txt文件时，已经自动将之转变为 Ansi格式的编码形式，所以我们要保存为Unicode编
码的文本文件的话，就不能直接写入这个字符串，而应先将该字符串赋值给一个Byte型的数
组，再将这个数组原封不动地写入文件，并在文件开头添加两个值为 &HFF和 &HFE 的字节就
行了。
读文件时，VB 并不判断读入的数据开头两个字节是否为 &HFF 和&HFE，它将读入的数据
都按照Ansi格式的编码处理，会自动将读入的数据转变为Unicode编码的字符串，如果原来就
是Unicode编码的文本，哈哈，这下子就弄得一踏糊涂了。所以我们在读文件的时候，不能用
通常的字符读入法，而要用二进制读入法，先将数据读入到一个Byte型的数组中，再判断头
两个字节是否 &HFF 和 &HFE，如果是，就把这个数组直接赋值给一个字符串变量，再去掉该
字符串的第一个字符；如果不是，就通过StrConv函数转换即可。
2.UTF_8编码文件的读写技术简述
系统自带的记事本有读写UTF－8文本文件的功能，我想在自编的记事本中也加入这个功
能，但在网上查找了一个钟头，竟然找不到用VB编写的代码，看来，天降大任于斯人也，大
概要由我来开这个头了。
于是我在网上狂查UTF－8的文章，恶补这方面的知识，并且还真的获益非浅，起码从七
窍通六窍——一窍不通到七窍通一窍——略知一二了，呵呵。
当我做完最后一次试验时，长长地叹了一口气，美美地伸了一个懒腰，呵呵，真爽啊，
一天的时间终于没有白费！这也许就是编程的乐趣吧，当看到程序按照自己的愿望运行时，
各位哥们姐们，你们的心情一定也与我是一样的，无比舒畅。
下面我先简单讲述一下UTF－8编码的有关知识，并且只讲与我编写的读写UTF－8文本代
码有关的知识（如有谬误之处请各位兄弟指正），详细的理论请各位自己找专业文章看看。
UTF-8 编码字符理论上可以最多到 6个字节长，但目前全世界的所有文字和符号种类加
起来也只要编到 4个字节长就够了。
UTF-8 是以 8位（即 1个字节）为单元对原始码进行编码（注意一点：这里所讲的原始
码都是指Unicode码），并规定：多字节码（2个字节以上才称为多字节）以转换后第1个字节
起头的连续“1”的数目（这些连续“1”称为标记位），表示转换成几个字节：“110”连续
两个“1”，表示转换结果为2个字节，“1110”表示3个字节，而“11110”则表示4个字节…
…跟随在标记位之后的“0”，其作用是分隔标记位和字符码位。第2～第4个字节的起头两个
位固定设置为“10”，也作为标记，剩下的6个位才做为字符码位使用。
这样，2字节UTF-8码剩下11个字符码位，可用以转换0080～07FF的原始字符码，3字节剩
下16个字符码位，可用以转换0800～FFFF的原始字符码，由此类推。编码方式的模板如下：
原始码（16进制） UTF－8编码（二进制）
--------------------------------------------
0000 - 007F 0xxxxxxx
0080 - 07FF 110xxxxx 10xxxxxx
0800 - FFFF 1110xxxx 10xxxxxx 10xxxxxx
……
--------------------------------------------
模板中的“x”表示字符码。
VB能识别的 Ascii码＜007F，所以在VB中，Ascii码都只能编为1个字节的UTF－8码。汉
字的 Unicode编码范围为0800－FFFF，所以被编为3个字节的UTF－8码。
例如“汉”字的Unicode编码是6C49，6C49在0800-FFFF之间，所以要用3个字节的模板：
1110xxxx 10xxxxxx 10xxxxxx。
UTF－8文本文件与Unicode文本文件类似，在文件的头部也有标记字节，Unicode文件的
标记是2个字节：&HFF 和 &HFE，UTF－8文件的标记是3个字节：&HEF、&HBB 和 &HBF
要写入UTF-8编码的文本文件，关键是对汉字编码的处理。我们从上述的汉字编码模板
就可以看出，对汉字的处理步骤大致为：
第一步：取得汉字的Unicode码
第二步：将Unicode码分解为两个16进制数据
第三步：将这两个16进制数据转换成二进制数据并连接
第四步：将二进制数据分解为三个串，第一个串为4个位，在前面加上标记位“1110”，第
二、三个串均为6个位，分别在前面加上“10”标记位
第五步：将这三个串分别转换为10进制数据并赋值给字节型数组
第六步：将字节型数组用二进制法写盘，并且要先在文本头存入三个字节的标记（&HEF、
&HBB、&HBF），再将转换好的数据写入
要读取UTF-8编码的文本文件，对汉字的处理步骤大致为：
第一步：用二进制法读入文本数据，赋值给字节型数组，并判断前3个字节是否UTF－8标记，
如果是，才进行以下的处理
第二步：逐个字节判断是否汉字编码，如果是，就再提取后两个数组元素，共三个数组元素
来加以处理
第三步：将这三个数据都转换成16进制数据
第四步：将三个16进制数据都转换成二进制数据
第五步：从第一个二进制数据中去掉前4位，从第二、三个二进制数据中分别去掉前2位，并
将这三个处理后的二进制数据依次连接，成为一个16位的字串
第六步：从这个二进制串中分别提取前8位和后8位转换成两个10进制数据，这两个数据就是
汉字的Unicode码了，将它们赋值给一个字符型变量即可
由于上述的二进制数字均须进行大量的字符串操作，速度较慢，因此在实际的代码中，笔者采用了
逻辑运算（位操作）来代替上述的字符串操作
Option Explicit
Dim FileName As String '文件名
Private Sub SaveFile_Click()
On Error GoTo OutError
Dim DAT() As Byte, DAT1() As Byte, Z As String
CommonDialog1.Filter = "TXT 文件(*.txt)|*.txt|Unicode 文件(*.txt)|*.txt|UTF-8 文件(*.txt)|*.txt"
CommonDialog1.Flags = &H200A
CommonDialog1.DialogTitle = "另存为"
CommonDialog1.ShowSave
If CommonDialog1.FileName = "" Then Exit Sub
FileName=CommonDialog1.FileName
Select Case CommonDialog1.FilterIndex '根据用户选取的保存类型来进行相应的操作
Case 1 '保存为普通的TXT文件
DAT = StrConv(Text1, vbFromUnicode)
Case 2 '保存为Unicode编码文件
ReDim DAT1(1) As Byte
DAT1(0) = &HFF: DAT1(1) = &HFE
DAT = Text1
Case 3 '保存为UTF_8编码文件
Dim zAsc As Long, L As Long, i As Long
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
End Select
Open FileName For Binary As #1
If CommonDialog1.FilterIndex > 1 Then Put #1, , DAT1
Put #1, , DAT
OutError:
Close
End Sub
Sub OpenFile_Click()
On Error GoTo InErr
Dim LFile As Long, DAT() As Byte, ST As String
CommonDialog1.Flags = &H200C
CommonDialog1.DialogTitle = "打开"
CommonDialog1.Filter = "文本文件(*.txt)|*.txt"
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
FileName=CommonDialog1.FileName
LFile = FileLen(FileName) - 1
ReDim DAT(LFile) As Byte
Open FileName For Binary As #1
Get #1, , DAT
If DAT(0) = &HFF And DAT(1) = &HFE Then '如果是Unicode编码文件
ST = DAT: ST = Mid(ST, 2)
ElseIf DAT(0) = &HEF And DAT(1) = &HBB And DAT(2) = &HBF Then '如果是UTF_8编码文件
Dim DAT1(1) As Byte, Z As String, i As Long
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
InErr:
Close
End Sub
十、文本保存为图片
将该功能与“横排转换为竖排”功能结合起来，就可以制作出精美的书法图片了！
本代码可自动根据文本的大小和用户输入的每张图片的高度，来设置图片的张数，如果文本较大，
保存的图片＞1张时，可自动在图片文件名的后面加上递增的序数。
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub SaveAsImage_Click()
If Text1 = "" Then Exit Sub
On Error GoTo 300
Dim FonHeight As Integer '字体高度
Dim ImageNumber As Integer '图片张数
Dim DestineImageH As Single '预定图片高度
Dim FactImageH As Single '实际图片高度
Dim TackValueH As Integer '高度附加值
Dim TextLine As Long '文本总行数
Dim LineCount As Long '页内行计数器
Dim NonceLine As Long '当前打印行
Dim pic As Object, J As Integer, ST As String, k As Single
Set pic = Controls.Add("VB.PictureBox", "pic") '创建图片框
pic.AutoRedraw = True
DestineImageH = InputBox("请输入预定的图片高度（30－1086）：", , 768)
If DestineImageH < 30 Or DestineImageH > 1086 Then MsgBox "图片高度超界！": GoTo 300
DestineImageH = DestineImageH * 15
With CommonDialog1
.DialogTitle = "保存为图片文件"
.Flags = &H200A
.Filter = "位图文件(*.bmp)|*.bmp"
.ShowSave
If .FileName = "" Then GoTo 300
End With
Screen.MousePointer = 11
With Text1
pic.BackColor = .BackColor
pic.ForeColor = .ForeColor
pic.FontName = .FontName
pic.FontSize = .FontSize
pic.FontStrikethru = .FontStrikethru
pic.FontUnderline = .FontUnderline
pic.FontBold = .FontBold
pic.FontItalic = .FontItalic
End With
TextLine = SendMessage(Text1.hWnd, 186, 0, 0) '获取当前文本总行数
FonHeight = Int(pic.TextHeight("攀")) '获取当前字体高度
ImageNumber = 1: FactImageH = TextLine * FonHeight: k = FactImageH
Do While FactImageH > DestineImageH: ImageNumber = ImageNumber + 1: FactImageH = k \ ImageNumber: Loop '如果图片实际高度>最大高，就分页
Do While FactImageH / FonHeight <> FactImageH \ FonHeight: FactImageH = FactImageH + 1: Loop '微调每页图片实际高度
pic.Width = Text1.Width - 180 '设置图片宽度
If FactImageH > Text1.Height Or pic.FontSize < 42 Then '设置图片高度
pic.Height = FactImageH + FonHeight \ 2: TackValueH = 0.5
Else: pic.Height = FactImageH: TackValueH = 0
End If
NonceLine = 0
For J = 1 To ImageNumber
LineCount = 0: pic.Cls
Do While FonHeight * (LineCount + TackValueH) < pic.Height And NonceLine < TextLine
ST = Space(256)
SendMessage Text1.hWnd, 196, NonceLine, ByVal ST
pic.Print RTrim(ST)
NonceLine = NonceLine + 1: LineCount = LineCount + 1
Loop
If ImageNumber = 1 Then
SavePicture pic.Image, CommonDialog1.FileName
Else
SavePicture pic.Image, Left(CommonDialog1.FileName, Len(CommonDialog1.FileName) - 4) & "(" & Format(J) & ").bmp"
End If
Next
300
Screen.MousePointer = 0
Controls.Remove pic '删除临时添加的图片框
If Err.Number > 0 Then MsgBox "另存为图片失败！": Err.Clear
End Sub
说明：微调每张图片实际高度的目的，是使打印到图片框的文本最后一行字符不致于只打印出上半部分
十一、文本邮寄
将当前文本框中的文本用电子邮件寄发出去，有多种方法，笔者使用了一个 API函数ShellExecute
来完成此功能，前提是你必须在OE中设置了默认信箱，实际上它是调用了OE的发信功能。用这个 API函
数发电邮的优点是比较简单，缺点是正文的长度受到了限制，一般在2000字左右。
下面的代码中，自动以文本的第一行作为标题，如果原文本没有分行，则标题为“无标题”。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
'输入参数：待发送的文本
Sub SendEmail(TextST As String)
On Error GoTo 100
If TextST = "" Then Exit Sub
Dim ST1 As String '标题
Dim ST2 As String '正文
Dim i As Integer
i = InStr(TextST, Chr$(13))
If i > 1 Then ST1 = Left$(TextST, i - 1): ST1 = Replace(ST1, " ", ""): ST1 = Replace(ST1, " ", "") Else ST1 = "无标题"
ST2 = Replace(TextST, Chr$(13) & Chr$(10), "%0a"): ST2 = Replace(ST2, "&", "＆")
If Len(ST1) + Len(ST2) > 2004 Then ST2 = Left$(ST2, 2004 - Len(ST1))
i = ShellExecute(Me.hWnd, "open", "mailto:?subject=" & ST1 & "&Body=" & ST2, vbNullString, vbNullString, 1)
If i = 0 Then GoTo 100
Exit Sub
100
MsgBox "电邮发送失败"
End Sub
十二、文本转换为16进制字符
也许有时候你需要将文本转化为16进制的编码来进行研究，那么下面的函数可以满足你的要求。显
示时，每行可显示8－48个数据（是由用户自己决定），并且每行前面还会显示16进制的位址。
'输入参数：欲转换的文本
Function TextToHexChar(TextST As String) As String
Dim DAT() As Byte '存放文本的Unicode编码
Dim i As Long, S As Integer, ST1 As String, ST2 As String
If TextST="" Then Exit Function
100 S = Val(InputBox("请输入每行要显示的数据个数（8－48）：", "输入数字", 32))
If S < 8 Or S > 48 Then MsgBox "无效数字": Goto 100
Screen.MousePointer = 13
ST1 = StrConv(TextST, vbFromUnicode): DAT = ST1: ST1 = ""
For i = 0 To S - 1: ST2 = ST2 & " " & Right("0" & Hex(i), 2): Next
ST2 = Space(7) & ST2 & vbCrLf & String(S * 3 + 7, "-")
For i = 0 To UBound(DAT)
If i / S = i \ S Then ST2 = ST2 & ST1 & vbCrLf: ST1 = Right("00000" & Hex(i), 6) & ":"
ST1 = ST1 & " " & Right("0" & Hex(DAT(i)), 2)
Next
If Len(ST1) > 8 Then ST2 = ST2 & ST1
TextToHexChar = ST2
Screen.MousePointer = 0
End Function
1.Unicode编码文件的读写技术简述
Unicode编码是两字节的全编码，对于Ascii字符它也使用两字节表示，代码页通过高字
节的取值范围来确定是Ascii字符，还是汉字的高字节。
Unicode编码的文本文件开头两个字节是 &HFF 和 &HFE，这是它的标记。下面就简单介
绍如何在自编的文本编辑器中实现Unicode编码文本文件的读写。
我们知道VB的字符串在内存中实际上就是以Unicode编码形式保存的，但当程序将字符串
写入 txt文件时，已经自动将之转变为 Ansi格式的编码形式，所以我们要保存为Unicode编
码的文本文件的话，就不能直接写入这个字符串，而应先将该字符串赋值给一个Byte型的数
组，再将这个数组原封不动地写入文件，并在文件开头添加两个值为 &HFF和 &HFE 的字节就
行了。
读文件时，VB 并不判断读入的数据开头两个字节是否为 &HFF 和&HFE，它将读入的数据
都按照Ansi格式的编码处理，会自动将读入的数据转变为Unicode编码的字符串，如果原来就
是Unicode编码的文本，哈哈，这下子就弄得一踏糊涂了。所以我们在读文件的时候，不能用
通常的字符读入法，而要用二进制读入法，先将数据读入到一个Byte型的数组中，再判断头
两个字节是否 &HFF 和 &HFE，如果是，就把这个数组直接赋值给一个字符串变量，再去掉该
字符串的第一个字符；如果不是，就通过StrConv函数转换即可。
2.UTF_8编码文件的读写技术简述
系统自带的记事本有读写UTF－8文本文件的功能，我想在自编的记事本中也加入这个功
能，但在网上查找了一个钟头，竟然找不到用VB编写的代码，看来，天降大任于斯人也，大
概要由我来开这个头了。
于是我在网上狂查UTF－8的文章，恶补这方面的知识，并且还真的获益非浅，起码从七
窍通六窍——一窍不通到七窍通一窍——略知一二了，呵呵。
当我做完最后一次试验时，长长地叹了一口气，美美地伸了一个懒腰，呵呵，真爽啊，
一天的时间终于没有白费！这也许就是编程的乐趣吧，当看到程序按照自己的愿望运行时，
各位哥们姐们，你们的心情一定也与我是一样的，无比舒畅。
下面我先简单讲述一下UTF－8编码的有关知识，并且只讲与我编写的读写UTF－8文本代
码有关的知识（如有谬误之处请各位兄弟指正），详细的理论请各位自己找专业文章看看。
UTF-8 编码字符理论上可以最多到 6个字节长，但目前全世界的所有文字和符号种类加
起来也只要编到 4个字节长就够了。
UTF-8 是以 8位（即 1个字节）为单元对原始码进行编码（注意一点：这里所讲的原始
码都是指Unicode码），并规定：多字节码（2个字节以上才称为多字节）以转换后第1个字节
起头的连续“1”的数目（这些连续“1”称为标记位），表示转换成几个字节：“110”连续
两个“1”，表示转换结果为2个字节，“1110”表示3个字节，而“11110”则表示4个字节…
…跟随在标记位之后的“0”，其作用是分隔标记位和字符码位。第2～第4个字节的起头两个
位固定设置为“10”，也作为标记，剩下的6个位才做为字符码位使用。
这样，2字节UTF-8码剩下11个字符码位，可用以转换0080～07FF的原始字符码，3字节剩
下16个字符码位，可用以转换0800～FFFF的原始字符码，由此类推。编码方式的模板如下：
原始码（16进制） UTF－8编码（二进制）
--------------------------------------------
0000 - 007F 0xxxxxxx
0080 - 07FF 110xxxxx 10xxxxxx
0800 - FFFF 1110xxxx 10xxxxxx 10xxxxxx
……
--------------------------------------------
模板中的“x”表示字符码。
VB能识别的 Ascii码＜007F，所以在VB中，Ascii码都只能编为1个字节的UTF－8码。汉
字的 Unicode编码范围为0800－FFFF，所以被编为3个字节的UTF－8码。
例如“汉”字的Unicode编码是6C49，6C49在0800-FFFF之间，所以要用3个字节的模板：
1110xxxx 10xxxxxx 10xxxxxx。
UTF－8文本文件与Unicode文本文件类似，在文件的头部也有标记字节，Unicode文件的
标记是2个字节：&HFF 和 &HFE，UTF－8文件的标记是3个字节：&HEF、&HBB 和 &HBF
要写入UTF-8编码的文本文件，关键是对汉字编码的处理。我们从上述的汉字编码模板
就可以看出，对汉字的处理步骤大致为：
第一步：取得汉字的Unicode码
第二步：将Unicode码分解为两个16进制数据
第三步：将这两个16进制数据转换成二进制数据并连接
第四步：将二进制数据分解为三个串，第一个串为4个位，在前面加上标记位“1110”，第
二、三个串均为6个位，分别在前面加上“10”标记位
第五步：将这三个串分别转换为10进制数据并赋值给字节型数组
第六步：将字节型数组用二进制法写盘，并且要先在文本头存入三个字节的标记（&HEF、
&HBB、&HBF），再将转换好的数据写入
要读取UTF-8编码的文本文件，对汉字的处理步骤大致为：
第一步：用二进制法读入文本数据，赋值给字节型数组，并判断前3个字节是否UTF－8标记，
如果是，才进行以下的处理
第二步：逐个字节判断是否汉字编码，如果是，就再提取后两个数组元素，共三个数组元素
来加以处理
第三步：将这三个数据都转换成16进制数据
第四步：将三个16进制数据都转换成二进制数据
第五步：从第一个二进制数据中去掉前4位，从第二、三个二进制数据中分别去掉前2位，并
将这三个处理后的二进制数据依次连接，成为一个16位的字串
第六步：从这个二进制串中分别提取前8位和后8位转换成两个10进制数据，这两个数据就是
汉字的Unicode码了，将它们赋值给一个字符型变量即可
由于上述的二进制数字均须进行大量的字符串操作，速度较慢，因此在实际的代码中，笔者采用了
逻辑运算（位操作）来代替上述的字符串操作
Option Explicit
Dim FileName As String '文件名
Private Sub SaveFile_Click()
On Error GoTo OutError
Dim DAT() As Byte, DAT1() As Byte, Z As String
CommonDialog1.Filter = "TXT 文件(*.txt)|*.txt|Unicode 文件(*.txt)|*.txt|UTF-8 文件(*.txt)|*.txt"
CommonDialog1.Flags = &H200A
CommonDialog1.DialogTitle = "另存为"
CommonDialog1.ShowSave
If CommonDialog1.FileName = "" Then Exit Sub
FileName=CommonDialog1.FileName
Select Case CommonDialog1.FilterIndex '根据用户选取的保存类型来进行相应的操作
Case 1 '保存为普通的TXT文件
DAT = StrConv(Text1, vbFromUnicode)
Case 2 '保存为Unicode编码文件
ReDim DAT1(1) As Byte
DAT1(0) = &HFF: DAT1(1) = &HFE
DAT = Text1
Case 3 '保存为UTF_8编码文件
Dim zAsc As Long, L As Long, i As Long
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
End Select
Open FileName For Binary As #1
If CommonDialog1.FilterIndex > 1 Then Put #1, , DAT1
Put #1, , DAT
OutError:
Close
End Sub
Sub OpenFile_Click()
On Error GoTo InErr
Dim LFile As Long, DAT() As Byte, ST As String
CommonDialog1.Flags = &H200C
CommonDialog1.DialogTitle = "打开"
CommonDialog1.Filter = "文本文件(*.txt)|*.txt"
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
FileName=CommonDialog1.FileName
LFile = FileLen(FileName) - 1
ReDim DAT(LFile) As Byte
Open FileName For Binary As #1
Get #1, , DAT
If DAT(0) = &HFF And DAT(1) = &HFE Then '如果是Unicode编码文件
ST = DAT: ST = Mid(ST, 2)
ElseIf DAT(0) = &HEF And DAT(1) = &HBB And DAT(2) = &HBF Then '如果是UTF_8编码文件
Dim DAT1(1) As Byte, Z As String, i As Long
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
InErr:
Close
End Sub
十、文本保存为图片
将该功能与“横排转换为竖排”功能结合起来，就可以制作出精美的书法图片了！
本代码可自动根据文本的大小和用户输入的每张图片的高度，来设置图片的张数，如果文本较大，
保存的图片＞1张时，可自动在图片文件名的后面加上递增的序数。
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub SaveAsImage_Click()
If Text1 = "" Then Exit Sub
On Error GoTo 300
Dim FonHeight As Integer '字体高度
Dim ImageNumber As Integer '图片张数
Dim DestineImageH As Single '预定图片高度
Dim FactImageH As Single '实际图片高度
Dim TackValueH As Integer '高度附加值
Dim TextLine As Long '文本总行数
Dim LineCount As Long '页内行计数器
Dim NonceLine As Long '当前打印行
Dim pic As Object, J As Integer, ST As String, k As Single
Set pic = Controls.Add("VB.PictureBox", "pic") '创建图片框
pic.AutoRedraw = True
DestineImageH = InputBox("请输入预定的图片高度（30－1086）：", , 768)
If DestineImageH < 30 Or DestineImageH > 1086 Then MsgBox "图片高度超界！": GoTo 300
DestineImageH = DestineImageH * 15
With CommonDialog1
.DialogTitle = "保存为图片文件"
.Flags = &H200A
.Filter = "位图文件(*.bmp)|*.bmp"
.ShowSave
If .FileName = "" Then GoTo 300
End With
Screen.MousePointer = 11
With Text1
pic.BackColor = .BackColor
pic.ForeColor = .ForeColor
pic.FontName = .FontName
pic.FontSize = .FontSize
pic.FontStrikethru = .FontStrikethru
pic.FontUnderline = .FontUnderline
pic.FontBold = .FontBold
pic.FontItalic = .FontItalic
End With
TextLine = SendMessage(Text1.hWnd, 186, 0, 0) '获取当前文本总行数
FonHeight = Int(pic.TextHeight("攀")) '获取当前字体高度
ImageNumber = 1: FactImageH = TextLine * FonHeight: k = FactImageH
Do While FactImageH > DestineImageH: ImageNumber = ImageNumber + 1: FactImageH = k \ ImageNumber: Loop '如果图片实际高度>最大高，就分页
Do While FactImageH / FonHeight <> FactImageH \ FonHeight: FactImageH = FactImageH + 1: Loop '微调每页图片实际高度
pic.Width = Text1.Width - 180 '设置图片宽度
If FactImageH > Text1.Height Or pic.FontSize < 42 Then '设置图片高度
pic.Height = FactImageH + FonHeight \ 2: TackValueH = 0.5
Else: pic.Height = FactImageH: TackValueH = 0
End If
NonceLine = 0
For J = 1 To ImageNumber
LineCount = 0: pic.Cls
Do While FonHeight * (LineCount + TackValueH) < pic.Height And NonceLine < TextLine
ST = Space(256)
SendMessage Text1.hWnd, 196, NonceLine, ByVal ST
pic.Print RTrim(ST)
NonceLine = NonceLine + 1: LineCount = LineCount + 1
Loop
If ImageNumber = 1 Then
SavePicture pic.Image, CommonDialog1.FileName
Else
SavePicture pic.Image, Left(CommonDialog1.FileName, Len(CommonDialog1.FileName) - 4) & "(" & Format(J) & ").bmp"
End If
Next
300
Screen.MousePointer = 0
Controls.Remove pic '删除临时添加的图片框
If Err.Number > 0 Then MsgBox "另存为图片失败！": Err.Clear
End Sub
说明：微调每张图片实际高度的目的，是使打印到图片框的文本最后一行字符不致于只打印出上半部分
十一、文本邮寄
将当前文本框中的文本用电子邮件寄发出去，有多种方法，笔者使用了一个 API函数ShellExecute
来完成此功能，前提是你必须在OE中设置了默认信箱，实际上它是调用了OE的发信功能。用这个 API函
数发电邮的优点是比较简单，缺点是正文的长度受到了限制，一般在2000字左右。
下面的代码中，自动以文本的第一行作为标题，如果原文本没有分行，则标题为“无标题”。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
'输入参数：待发送的文本
Sub SendEmail(TextST As String)
On Error GoTo 100
If TextST = "" Then Exit Sub
Dim ST1 As String '标题
Dim ST2 As String '正文
Dim i As Integer
i = InStr(TextST, Chr$(13))
If i > 1 Then ST1 = Left$(TextST, i - 1): ST1 = Replace(ST1, " ", ""): ST1 = Replace(ST1, " ", "") Else ST1 = "无标题"
ST2 = Replace(TextST, Chr$(13) & Chr$(10), "%0a"): ST2 = Replace(ST2, "&", "＆")
If Len(ST1) + Len(ST2) > 2004 Then ST2 = Left$(ST2, 2004 - Len(ST1))
i = ShellExecute(Me.hWnd, "open", "mailto:?subject=" & ST1 & "&Body=" & ST2, vbNullString, vbNullString, 1)
If i = 0 Then GoTo 100
Exit Sub
100
MsgBox "电邮发送失败"
End Sub
十二、文本转换为16进制字符
也许有时候你需要将文本转化为16进制的编码来进行研究，那么下面的函数可以满足你的要求。显
示时，每行可显示8－48个数据（是由用户自己决定），并且每行前面还会显示16进制的位址。
'输入参数：欲转换的文本
Function TextToHexChar(TextST As String) As String
Dim DAT() As Byte '存放文本的Unicode编码
Dim i As Long, S As Integer, ST1 As String, ST2 As String
If TextST="" Then Exit Function
100 S = Val(InputBox("请输入每行要显示的数据个数（8－48）：", "输入数字", 32))
If S < 8 Or S > 48 Then MsgBox "无效数字": Goto 100
Screen.MousePointer = 13
ST1 = StrConv(TextST, vbFromUnicode): DAT = ST1: ST1 = ""
For i = 0 To S - 1: ST2 = ST2 & " " & Right("0" & Hex(i), 2): Next
ST2 = Space(7) & ST2 & vbCrLf & String(S * 3 + 7, "-")
For i = 0 To UBound(DAT)
If i / S = i \ S Then ST2 = ST2 & ST1 & vbCrLf: ST1 = Right("00000" & Hex(i), 6) & ":"
ST1 = ST1 & " " & Right("0" & Hex(DAT(i)), 2)
Next
If Len(ST1) > 8 Then ST2 = ST2 & ST1
TextToHexChar = ST2
Screen.MousePointer = 0
End Function
