您所在位置：主题：[原创]编写超级记事本必需的十六个功能源代码（一）
一江秋水
[专家分：9680] 发布于 2007-09-16 11:38:00
编写超级记事本必需的十六个功能源代码
一、htm文本转换为txt文本
网上可能有许多这方面的代码，但这是我自己编写的，用起来心里要舒坦一些，呵呵，心理作用。
我喜欢从网上下载武侠小说来看，但下载的大多是htm或html类型的文件，手工去掉文件头、尾当
然也可以，但我既然能够编写简单的程序，为何不自己试试用代码来转换呢？于是就有了下面的代码。
转换的规则是：
1.如果提取的字符是“>”，那么就对它后面的字符进行分析：如果是汉字、英文空格、回车换行符或
“(”、“&”等，就从这里开始接收，直到提取的字符是“<”才停止接收。
2.整个文件接收完了后，还要删除其中的html标记。这些标记在有的源htm文件上有，有的源htm文件没
有。当然，如果还有我没有写上的标记，请自行添加转换代码（这些标记均转换为空字符）。
3.最后还要处理一下换行符。我们知道，在txt文件中，是回车符与换行符联用的，而在htm文件中，大
多数情况下，是单独使用换行符，在将htm文本转为txt文本后，最好也将单独的换行符转为回车符与换
行符联用的形式，以符合一般的习惯，当然，不转换问题也不大。
本函数适用于转换从中文网站下载的文学类型htm文档，其它类型的htm文档未测试。
函数中的Dat1数组用于装入欲转换的文本的Ascii码，Dat2数组用于接收转换后的文本的Ascii码。
下面是函数代码：
'输入参数：欲转换的htm文本
Function HtmToTxt(ByVal HtmlST As String) As String
On Error GoTo Err2
Dim TextST As String '转换好的文本字串
Dim Dat1() As Byte, Dat2() As Byte
Dim TAscii As Integer '字符的Ascii码暂存
Dim i As Long 'Dat1 计数
Dim j As Long 'Dat2 计数
Dim L As Long
Me.MousePointer = 11
HtmlST = UCase(HtmlST): HtmlST = Replace(HtmlST, "<BR>", vbCrLf)
Dat1 = StrConv(HtmlST, vbFromUnicode): L = UBound(Dat1): ReDim Dat2(L * 2)
For i = 0 To L
If Dat1(i) = 62 Then '如果是字符">"
i = i + 1: If i >= L Then Exit For
TAscii = Dat1(i)
If TAscii > 126 Or TAscii = 32 Or TAscii = 13 Or TAscii = 10 Or TAscii = 40 Or TAscii = 38 Then
Do
Dat2(j) = Dat1(i): i = i + 1: j = j + 1: If i >= L Then Exit For
Loop Until Dat1(i) = 60 '"<"
End If
End If
Next
ReDim Preserve Dat2(j - 1)
TextST = Dat2: ReDim Dat1(0), Dat2(0)
TextST = StrConv(TextST, vbUnicode)
TextST = Replace(TextST, "&NBSP;", "")
TextST = Replace(TextST, "&", "")
TextST = Replace(TextST, """, "")
TextST = Replace(TextST, "<", "")
TextST = Replace(TextST, ">", "")
TextST = Replace(TextST, "&MIDDOT;", "")
Err2:
Me.MousePointer = 0
If err.Number = 0 Then HtmToTxt = TextST
End Function
二、txt文本转换为htm文本
本功能主要用于转换中文文学作品为简单的网页文件及制作无图片的HTM格式帮助文件。
对 TXT文本的要求：
1.第一行必须是文章标题，且标题与正文之间不要有空行；
2.如果有副标题，那么副标题必须是第二行，且必须用破折号打头（英文的"-"或中文的"-"均可）；
3.整个文本连标题一起至少要有3行；
4.每个自然段前必须有空格，最好是中文空格；
5.文本最后三行可以是日期（初稿、修改和定稿日期），日期必须以4位阿拉伯数字的年份打头，如
2006年7月31日 或 2006.7.31
'输入参数：欲转换的txt文本
Function TxtToHtm(ByVal TextST As String) As String
On Error GoTo Err1
Dim TextLine As Integer '文章总行数
Dim StartLine As Integer '从哪一行开始转换
Dim TempST As String
Dim t(2) As String '存放写在文章最后面的日期和时间
Dim sh() As String, z As String, i As Long
If TextST = "" Then Exit Function
TextST = Replace(TextST, Chr(0), "")
StartLine = 1: z = Chr(34)
sh = Split(TextST, vbCrLf): TextLine = UBound(sh)
sh(0) = Trim(sh(0)) '获取第一行字符作为标题
TextST = "<HTML><BODY>" & vbCrLf
TextST = TextST & "<font face=" & z & "黑体" & z & " color=" & z & "#ff0000" & z & " size=5><b>" & sh(0) & "</b></font>" & vbCrLf
TempST = Left$(Trim(sh(1)), 1)
If TempST = "-" Or TempST = "－" Or TempST = "—" Then StartLine = 2: TextST = TextST & "<p><font color=maroon size=4><b> " & Trim(sh(1)) & "</b></font></p>" & vbCrLf '处理原文本第二行的副标题
TextST = TextST & "<HR color=" & z & "#ffffff" & z & "><font face=" & z & "宋体" & z & " color=" & z & "#00" & z & " size=2>" & vbCrLf & vbCrLf
If Len(sh(TextLine)) = 0 Then TextLine = TextLine - 1
For i = StartLine To TextLine
If i > TextLine - 3 Then If Val(sh(i)) > 1900 Then t(TextLine - i) = Trim(sh(i)): GoTo 100 '如果是日期或时间，暂时保存
If sh(i) = "" Then TextST = TextST & "<br><br>": GoTo 100 '如果是空行，在前面加2个<BR>标记
TempST = Left$(sh(i), 1): If TempST = " " Or TempST = " " Then sh(i) = "<br>" & sh(i) '如果是新段落首行，在前面加<BR>标记
TextST = TextST & sh(i): If i < TextLine Then TextST = TextST & vbCrLf
100
Next
TextST = TextST & "<br><HR color=" & z & "#ffffff" & z & ">" & vbCrLf
For i = 2 To 0 Step -1 '处理日期和时间
If Len(t(i)) > 3 Then TextST = TextST & "<br>" & t(i) & vbCrLf
Next
TextST = TextST & "</BODY></HTML>"
Err1:
If err.Number = 0 Then TxtToHtm = TextST
End Function
三、文本重排
很多时候我们需要将文本按照预定的每行字数重新排列，并在重新排列的每行后面加上硬回车。本
函数是使用字节型数组操作的，速度非常快。
本函数有三个参数：
1.欲重排的字符串。
2.换行字数。这个字数是按英文计数的，如果是中文文本，那么换行字数要×2。
3.半角转全角标记。该参数是可选的。注意，有一个英文字符“\”无法转为全角，如有必要，请自行
添加代码转换。
如果你的文本中有代码行，请勿使用本函数，除非每行代码前都有一个空格或者每两行代码间有一
空行（象本文下面就是代码行，不能使用这个函数来进行重排）。
函数中的Dat1数组用于装入欲重排的字符串的编码，Dat2数组用于接收重排后的字符串编码。
'输入参数：1.欲重排的字符串；2.换行字数（按字节计数）；3.半角转全角标记
Function TextRank(ByVal TextST As String, LineWordCount As Integer, Optional wFlags As Boolean) As String
Dim Dat1() As Byte, Dat2() As Byte
Dim RankByteCount As Long '已重排字节计数
Dim LineByteCount As Integer '行字节计数
Dim S As Long, i As Long
If wFlags Then TextST = StrConv(TextST, vbWide) '半角转全角
TextST = StrConv(TextST, vbFromUnicode): Dat1 = TextST: S = UBound(Dat1): ReDim Dat2(S * 2)
For i = 0 To S
If Dat1(i) > 127 Then
Dat2(RankByteCount) = Dat1(i): Dat2(RankByteCount + 1) = Dat1(i + 1)
RankByteCount = RankByteCount + 2: LineByteCount = LineByteCount + 2: i = i + 1
ElseIf Dat1(i) = 13 Then
If i + 2 >= S Then GoSub 100: Exit For
If LineByteCount > 0 And (Dat1(i + 2) = 32 Or Dat1(i + 2) = 161 And Dat1(i + 3) = 161) Then GoSub 100
If Dat1(i + 2) = 13 Then GoSub 100: GoSub 100: i = i + 3
ElseIf Dat1(i) > 31 Then
Dat2(RankByteCount) = Dat1(i): RankByteCount = RankByteCount + 1: LineByteCount = LineByteCount + 1
End If
If LineByteCount >= LineWordCount Then GoSub 100
Next
RankByteCount = RankByteCount - 1: ReDim Preserve Dat2(RankByteCount) '删除未用的数组元素
TextST = Dat2: TextRank = StrConv(TextST, vbUnicode)
TextST = "": ReDim Dat1(0), Dat2(0)
Exit Function
100
Dat2(RankByteCount) = 13: Dat2(RankByteCount + 1) = 10
RankByteCount = RankByteCount + 2: LineByteCount = 0
Return
End Function
四、横排转换为竖排
看了太多的横排文本，你想不想欣赏一下具有独特魅力的竖排文本呢？遗憾的是，系统自带的记事
文和写字板都无法将横排文本转换为竖排文本。不过不要紧，下面我就给大家来介绍实现这种功能的源
代码，你可以把它应用到自己编写的记事本中
转换思路：
我们假定有以下文本要转为竖排：
一二三四
①②③④
⑴⑵⑶⑷
㈠㈡㈢㈣
转为竖排后则为：
㈠ ⑴ ① 一
㈡ ⑵ ② 二
㈢ ⑶ ③ 三
㈣ ⑷ ④ 四
可以看到，文本原来的第一列变成了第一行，第二列变成了第二行……怎样用程序实现这种变化呢
？我们可以先将原文本每一行的字符赋给一个字符串型数组元素，然后从最后一个数组元素开始，依逆
向顺序至第一个数组元素，每个数组元素取其第一个字符，依次累加进一个字符串变量，所有数组元素
的第一个字符取完后，赋给字符串变量一个回车换行符，这就作为新文本的第一行，然后依照前法开始
取所有数组元素的第二个字符，累加进字符串变量，再赋给一个回车换行符……如此循环，直至取完全
部字符，这时，那个字符串变量中所包含的就是竖排的文本了，把它赋给文本框，大功告成！
这里有几点要注意：
①原文本每行的长度都不要超过一定的字数，否则转换后的直行长长短短很不美观。所以，在转换
前必须先“文本重排”，且第二个参数（换行字数）必须与“文本重排”的相同！
②每二个直行之间要有一个空直行，才能整齐美观，否则将一踏糊涂。
③如果是英汉混合文本，那么应先将半角英文字符转换为对应的全角字符，否则转换后的文本也将
“惨不忍睹”。
④代码中将29种横排的中文标点转换成竖排专用的，可能还有没有列出的，请按此格式自行添加。
⑤如果原文本的行数较多，那么文本框的属性ScrollBars=3（必须在设计时设置）。
'输入参数：1.欲转换的字符串；2.换行字数（按字节计数）
Function SidelongToErect(ByVal TextST As String, LineWordCount As Integer) As String
If Len(TextST) < 4 Or LineWordCount < 4 Then Exit Function
On Error GoTo 100
Dim Dat1() As Byte, Dat2() As Byte, sh() As String
Dim TextLine As Long '原文本的总行数
Dim j2 As Long 'Dat2的字节计数
Dim j1 As Long 'Dat1的字节计数
Dim i As Long, L As Long, k As Integer
k = LineWordCount \ 2: sh = Split(TextST, vbCrLf): TextLine = UBound(sh)
If Right(TextST, 2) = Chr(13) & Chr(10) Then TextLine = TextLine - 1
TextST = ""
For i = 0 To TextLine: sh(i) = Left$(sh(i) & String(k, Chr(-24159)), k): Next '使每行字数相等
For i = 0 To TextLine: TextST = TextST & sh(i): Next '连接
ReDim sh(0)
Dat1 = StrConv(TextST, vbFromUnicode): L = UBound(Dat1): TextST = "": ReDim Dat2(L * 2)
For L = 0 To LineWordCount - 1 Step 2
For i = TextLine To 0 Step -1
j1 = (i * LineWordCount + L)
Select Case Hex(Dat1(j1)) & Hex(Dat1(j1 + 1)) '以下将横排标点符号转为竖排标点符号
Case "A3DB", "A1BC", "A1BE": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEE
Case "A3DD", "A1BD", "A1BF": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEF
Case "A1B0", "A1BA": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEA
Case "A1B1", "A1BB": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEB
Case "A1AE", "A1B8": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE8
Case "A1AF", "A1B9": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE9
Case "A3A8": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE0
Case "A3A9": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE1
Case "A1B6": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE6
Case "A1B7": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE7
Case "A1AA": Dat2(j2) = &HA8: Dat2(j2 + 1) = &H4F
Case "A3AD": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HF2
Case "A1AD": Dat2(j2) = &HA9: Dat2(j2 + 1) = &HAB
Case "A3BD": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HAC
Case "A3BC": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HC4
Case "A3BE": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HC5
Case "A1AB": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HD2
Case "A3FB": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HF0
Case "A3FD": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HF1
Case "A1FA": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HFC
Case "A1FB": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HCD
Case Else: Dat2(j2) = Dat1(j1): Dat2(j2 + 1) = Dat1(j1 + 1)
End Select
Dat2(j2 + 2) = 32: j2 = j2 + 3
Next
Dat2(j2) = 13: Dat2(j2 + 1) = 10: j2 = j2 + 2
Next
ReDim Preserve Dat2(j2 - 2) '删除未用的数组元素
TextST = Dat2: TextST = StrConv(TextST, vbUnicode)
100
ReDim Dat1(0), Dat2(0)
If Err.Number = 0 Then SidelongToErect = TextST
End Function
一、htm文本转换为txt文本
网上可能有许多这方面的代码，但这是我自己编写的，用起来心里要舒坦一些，呵呵，心理作用。
我喜欢从网上下载武侠小说来看，但下载的大多是htm或html类型的文件，手工去掉文件头、尾当
然也可以，但我既然能够编写简单的程序，为何不自己试试用代码来转换呢？于是就有了下面的代码。
转换的规则是：
1.如果提取的字符是“>”，那么就对它后面的字符进行分析：如果是汉字、英文空格、回车换行符或
“(”、“&”等，就从这里开始接收，直到提取的字符是“<”才停止接收。
2.整个文件接收完了后，还要删除其中的html标记。这些标记在有的源htm文件上有，有的源htm文件没
有。当然，如果还有我没有写上的标记，请自行添加转换代码（这些标记均转换为空字符）。
3.最后还要处理一下换行符。我们知道，在txt文件中，是回车符与换行符联用的，而在htm文件中，大
多数情况下，是单独使用换行符，在将htm文本转为txt文本后，最好也将单独的换行符转为回车符与换
行符联用的形式，以符合一般的习惯，当然，不转换问题也不大。
本函数适用于转换从中文网站下载的文学类型htm文档，其它类型的htm文档未测试。
函数中的Dat1数组用于装入欲转换的文本的Ascii码，Dat2数组用于接收转换后的文本的Ascii码。
下面是函数代码：
'输入参数：欲转换的htm文本
Function HtmToTxt(ByVal HtmlST As String) As String
On Error GoTo Err2
Dim TextST As String '转换好的文本字串
Dim Dat1() As Byte, Dat2() As Byte
Dim TAscii As Integer '字符的Ascii码暂存
Dim i As Long 'Dat1 计数
Dim j As Long 'Dat2 计数
Dim L As Long
Me.MousePointer = 11
HtmlST = UCase(HtmlST): HtmlST = Replace(HtmlST, "<BR>", vbCrLf)
Dat1 = StrConv(HtmlST, vbFromUnicode): L = UBound(Dat1): ReDim Dat2(L * 2)
For i = 0 To L
If Dat1(i) = 62 Then '如果是字符">"
i = i + 1: If i >= L Then Exit For
TAscii = Dat1(i)
If TAscii > 126 Or TAscii = 32 Or TAscii = 13 Or TAscii = 10 Or TAscii = 40 Or TAscii = 38 Then
Do
Dat2(j) = Dat1(i): i = i + 1: j = j + 1: If i >= L Then Exit For
Loop Until Dat1(i) = 60 '"<"
End If
End If
Next
ReDim Preserve Dat2(j - 1)
TextST = Dat2: ReDim Dat1(0), Dat2(0)
TextST = StrConv(TextST, vbUnicode)
TextST = Replace(TextST, "&NBSP;", "")
TextST = Replace(TextST, "&", "")
TextST = Replace(TextST, """, "")
TextST = Replace(TextST, "<", "")
TextST = Replace(TextST, ">", "")
TextST = Replace(TextST, "&MIDDOT;", "")
Err2:
Me.MousePointer = 0
If err.Number = 0 Then HtmToTxt = TextST
End Function
二、txt文本转换为htm文本
本功能主要用于转换中文文学作品为简单的网页文件及制作无图片的HTM格式帮助文件。
对 TXT文本的要求：
1.第一行必须是文章标题，且标题与正文之间不要有空行；
2.如果有副标题，那么副标题必须是第二行，且必须用破折号打头（英文的"-"或中文的"-"均可）；
3.整个文本连标题一起至少要有3行；
4.每个自然段前必须有空格，最好是中文空格；
5.文本最后三行可以是日期（初稿、修改和定稿日期），日期必须以4位阿拉伯数字的年份打头，如
2006年7月31日 或 2006.7.31
'输入参数：欲转换的txt文本
Function TxtToHtm(ByVal TextST As String) As String
On Error GoTo Err1
Dim TextLine As Integer '文章总行数
Dim StartLine As Integer '从哪一行开始转换
Dim TempST As String
Dim t(2) As String '存放写在文章最后面的日期和时间
Dim sh() As String, z As String, i As Long
If TextST = "" Then Exit Function
TextST = Replace(TextST, Chr(0), "")
StartLine = 1: z = Chr(34)
sh = Split(TextST, vbCrLf): TextLine = UBound(sh)
sh(0) = Trim(sh(0)) '获取第一行字符作为标题
TextST = "<HTML><BODY>" & vbCrLf
TextST = TextST & "<font face=" & z & "黑体" & z & " color=" & z & "#ff0000" & z & " size=5><b>" & sh(0) & "</b></font>" & vbCrLf
TempST = Left$(Trim(sh(1)), 1)
If TempST = "-" Or TempST = "－" Or TempST = "—" Then StartLine = 2: TextST = TextST & "<p><font color=maroon size=4><b> " & Trim(sh(1)) & "</b></font></p>" & vbCrLf '处理原文本第二行的副标题
TextST = TextST & "<HR color=" & z & "#ffffff" & z & "><font face=" & z & "宋体" & z & " color=" & z & "#00" & z & " size=2>" & vbCrLf & vbCrLf
If Len(sh(TextLine)) = 0 Then TextLine = TextLine - 1
For i = StartLine To TextLine
If i > TextLine - 3 Then If Val(sh(i)) > 1900 Then t(TextLine - i) = Trim(sh(i)): GoTo 100 '如果是日期或时间，暂时保存
If sh(i) = "" Then TextST = TextST & "<br><br>": GoTo 100 '如果是空行，在前面加2个<BR>标记
TempST = Left$(sh(i), 1): If TempST = " " Or TempST = " " Then sh(i) = "<br>" & sh(i) '如果是新段落首行，在前面加<BR>标记
TextST = TextST & sh(i): If i < TextLine Then TextST = TextST & vbCrLf
100
Next
TextST = TextST & "<br><HR color=" & z & "#ffffff" & z & ">" & vbCrLf
For i = 2 To 0 Step -1 '处理日期和时间
If Len(t(i)) > 3 Then TextST = TextST & "<br>" & t(i) & vbCrLf
Next
TextST = TextST & "</BODY></HTML>"
Err1:
If err.Number = 0 Then TxtToHtm = TextST
End Function
三、文本重排
很多时候我们需要将文本按照预定的每行字数重新排列，并在重新排列的每行后面加上硬回车。本
函数是使用字节型数组操作的，速度非常快。
本函数有三个参数：
1.欲重排的字符串。
2.换行字数。这个字数是按英文计数的，如果是中文文本，那么换行字数要×2。
3.半角转全角标记。该参数是可选的。注意，有一个英文字符“\”无法转为全角，如有必要，请自行
添加代码转换。
如果你的文本中有代码行，请勿使用本函数，除非每行代码前都有一个空格或者每两行代码间有一
空行（象本文下面就是代码行，不能使用这个函数来进行重排）。
函数中的Dat1数组用于装入欲重排的字符串的编码，Dat2数组用于接收重排后的字符串编码。
'输入参数：1.欲重排的字符串；2.换行字数（按字节计数）；3.半角转全角标记
Function TextRank(ByVal TextST As String, LineWordCount As Integer, Optional wFlags As Boolean) As String
Dim Dat1() As Byte, Dat2() As Byte
Dim RankByteCount As Long '已重排字节计数
Dim LineByteCount As Integer '行字节计数
Dim S As Long, i As Long
If wFlags Then TextST = StrConv(TextST, vbWide) '半角转全角
TextST = StrConv(TextST, vbFromUnicode): Dat1 = TextST: S = UBound(Dat1): ReDim Dat2(S * 2)
For i = 0 To S
If Dat1(i) > 127 Then
Dat2(RankByteCount) = Dat1(i): Dat2(RankByteCount + 1) = Dat1(i + 1)
RankByteCount = RankByteCount + 2: LineByteCount = LineByteCount + 2: i = i + 1
ElseIf Dat1(i) = 13 Then
If i + 2 >= S Then GoSub 100: Exit For
If LineByteCount > 0 And (Dat1(i + 2) = 32 Or Dat1(i + 2) = 161 And Dat1(i + 3) = 161) Then GoSub 100
If Dat1(i + 2) = 13 Then GoSub 100: GoSub 100: i = i + 3
ElseIf Dat1(i) > 31 Then
Dat2(RankByteCount) = Dat1(i): RankByteCount = RankByteCount + 1: LineByteCount = LineByteCount + 1
End If
If LineByteCount >= LineWordCount Then GoSub 100
Next
RankByteCount = RankByteCount - 1: ReDim Preserve Dat2(RankByteCount) '删除未用的数组元素
TextST = Dat2: TextRank = StrConv(TextST, vbUnicode)
TextST = "": ReDim Dat1(0), Dat2(0)
Exit Function
100
Dat2(RankByteCount) = 13: Dat2(RankByteCount + 1) = 10
RankByteCount = RankByteCount + 2: LineByteCount = 0
Return
End Function
四、横排转换为竖排
看了太多的横排文本，你想不想欣赏一下具有独特魅力的竖排文本呢？遗憾的是，系统自带的记事
文和写字板都无法将横排文本转换为竖排文本。不过不要紧，下面我就给大家来介绍实现这种功能的源
代码，你可以把它应用到自己编写的记事本中
转换思路：
我们假定有以下文本要转为竖排：
一二三四
①②③④
⑴⑵⑶⑷
㈠㈡㈢㈣
转为竖排后则为：
㈠ ⑴ ① 一
㈡ ⑵ ② 二
㈢ ⑶ ③ 三
㈣ ⑷ ④ 四
可以看到，文本原来的第一列变成了第一行，第二列变成了第二行……怎样用程序实现这种变化呢
？我们可以先将原文本每一行的字符赋给一个字符串型数组元素，然后从最后一个数组元素开始，依逆
向顺序至第一个数组元素，每个数组元素取其第一个字符，依次累加进一个字符串变量，所有数组元素
的第一个字符取完后，赋给字符串变量一个回车换行符，这就作为新文本的第一行，然后依照前法开始
取所有数组元素的第二个字符，累加进字符串变量，再赋给一个回车换行符……如此循环，直至取完全
部字符，这时，那个字符串变量中所包含的就是竖排的文本了，把它赋给文本框，大功告成！
这里有几点要注意：
①原文本每行的长度都不要超过一定的字数，否则转换后的直行长长短短很不美观。所以，在转换
前必须先“文本重排”，且第二个参数（换行字数）必须与“文本重排”的相同！
②每二个直行之间要有一个空直行，才能整齐美观，否则将一踏糊涂。
③如果是英汉混合文本，那么应先将半角英文字符转换为对应的全角字符，否则转换后的文本也将
“惨不忍睹”。
④代码中将29种横排的中文标点转换成竖排专用的，可能还有没有列出的，请按此格式自行添加。
⑤如果原文本的行数较多，那么文本框的属性ScrollBars=3（必须在设计时设置）。
'输入参数：1.欲转换的字符串；2.换行字数（按字节计数）
Function SidelongToErect(ByVal TextST As String, LineWordCount As Integer) As String
If Len(TextST) < 4 Or LineWordCount < 4 Then Exit Function
On Error GoTo 100
Dim Dat1() As Byte, Dat2() As Byte, sh() As String
Dim TextLine As Long '原文本的总行数
Dim j2 As Long 'Dat2的字节计数
Dim j1 As Long 'Dat1的字节计数
Dim i As Long, L As Long, k As Integer
k = LineWordCount \ 2: sh = Split(TextST, vbCrLf): TextLine = UBound(sh)
If Right(TextST, 2) = Chr(13) & Chr(10) Then TextLine = TextLine - 1
TextST = ""
For i = 0 To TextLine: sh(i) = Left$(sh(i) & String(k, Chr(-24159)), k): Next '使每行字数相等
For i = 0 To TextLine: TextST = TextST & sh(i): Next '连接
ReDim sh(0)
Dat1 = StrConv(TextST, vbFromUnicode): L = UBound(Dat1): TextST = "": ReDim Dat2(L * 2)
For L = 0 To LineWordCount - 1 Step 2
For i = TextLine To 0 Step -1
j1 = (i * LineWordCount + L)
Select Case Hex(Dat1(j1)) & Hex(Dat1(j1 + 1)) '以下将横排标点符号转为竖排标点符号
Case "A3DB", "A1BC", "A1BE": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEE
Case "A3DD", "A1BD", "A1BF": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEF
Case "A1B0", "A1BA": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEA
Case "A1B1", "A1BB": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HEB
Case "A1AE", "A1B8": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE8
Case "A1AF", "A1B9": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE9
Case "A3A8": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE0
Case "A3A9": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE1
Case "A1B6": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE6
Case "A1B7": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HE7
Case "A1AA": Dat2(j2) = &HA8: Dat2(j2 + 1) = &H4F
Case "A3AD": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HF2
Case "A1AD": Dat2(j2) = &HA9: Dat2(j2 + 1) = &HAB
Case "A3BD": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HAC
Case "A3BC": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HC4
Case "A3BE": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HC5
Case "A1AB": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HD2
Case "A3FB": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HF0
Case "A3FD": Dat2(j2) = &HA6: Dat2(j2 + 1) = &HF1
Case "A1FA": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HFC
Case "A1FB": Dat2(j2) = &HA1: Dat2(j2 + 1) = &HCD
Case Else: Dat2(j2) = Dat1(j1): Dat2(j2 + 1) = Dat1(j1 + 1)
End Select
Dat2(j2 + 2) = 32: j2 = j2 + 3
Next
Dat2(j2) = 13: Dat2(j2 + 1) = 10: j2 = j2 + 2
Next
ReDim Preserve Dat2(j2 - 2) '删除未用的数组元素
TextST = Dat2: TextST = StrConv(TextST, vbUnicode)
100
ReDim Dat1(0), Dat2(0)
If Err.Number = 0 Then SidelongToErect = TextST
End Function
