好吧,我写函数用了 30分钟。
说明:函数内用到的控件名为 P1,类型为 PictureBox ,会自动创建。窗体中内不能出现同名的,但类型不是 PictureBox 的控件,该控件你可以手动创建,会自动引用。
该函数代码需要放到窗体内才能正确运行。放在BAS里就会出现错误(未测试)
传入的字符串数组,下标从0开始,然后自动取所有的元素,如果该元素空白,会导致空行。如果该元素保存了 VBCRLF 字符,会导致跳行。
调用如
程序代码:
Dim s(2) As String
s(0) = "0sdfbsad"
s(1) = "1asnvfgjhdfh"
s(2) = "2dghghjtydfgnsabnsvb"
Debug.Print texttopic(s(), "F:\A.bmp", 20)
函数完整代码
程序代码:
Public Function texttopic(s() As String, FileName As String, Optional FontSize As Long = 12) As Long
Dim P As PictureBox
Dim i As Long, j As Long
Dim w As Long, h As Long
'文件名为空,传回 -1
If FileName = "" Then
texttopic = -1
Exit Function
End If
On Error Resume Next
j = 0 '临时标志
For i = 0 To Me.Controls.Count - 1 '查找所有的控件
If Me.Controls(i).Name = "P1" Then '找到P1
Set P = Me.Controls(i) '引用
j = 1 '写标志
Exit For '退出循环
End If
Next i
If j = 0 Then '如果没有找到P1,说明第一次运行本函数
Set P = Controls.Add("VB.PictureBox", "P1") '创建P1并引用
End If
P.AutoRedraw = True '自动重绘开
P.Appearance = 0 '样式为普通
P.BackColor = &HFFFFFF '背景
'此处定义字号的大小
If FontSize > 1 And FontSize < 128 Then '最大值未测试,随手写了 128
P.Font.Size = FontSize '字号,按传入的参数
End If
'计算字符总高度及最大宽度,未计算上下左右边界及行距
For i = 0 To UBound(s())
j = P.TextHeight(s(i))
h = h + j '未计算字符间距,未考虑字符上下边距
j = P.TextWidth(s(i))
If j > w Then w = j
Next i
P.Width = w
P.Width = w + (P.Width - P.ScaleWidth) '把控件的边距加进去
P.Height = h
P.Height = h + (P.Height - P.ScaleHeight) '把控件边距加进去
P.Cls '清除内容,以确保原点回左上角
'打印字符
For i = 0 To UBound(s())
P.Print s(i)
Next i
'保存为BMP格式
SavePicture P.Image, FileName
texttopic = Err '如果有错误产生,把错误号传回去
End Function