您所在位置：主题：[原创]介绍一种用代码制作大型空心字的方法
一江秋水
[专家分：9680] 发布于 2009-02-06 14:00:00
介绍一种用代码制作大型空心字的方法
笔者所说的空心字，是指笔划边缘颜色保持不变，而将字符笔划内部“掏空”，填上另一种颜色。
可以有多种方法达到这个要求。但笔者这种方法是自动的，不需要人工干预，非常简单实用。
思路：首先把最大的粗体72号字（使用72号字的原因是考虑到如果以后要放大，那么这个字号的锯齿边比较轻微）用某种颜色（例如红色）打印到图片框上，再逐个取点判断：如果该点的前后上下四个点都为红色，则可断定该点位于笔划内部，属于要“掏空”的点，那么就对该点做一个标记（不能直接更换颜色，因为更换颜色以后，下一个点的判断就不对了），最后再逐点检查标记，把凡是有标记的点更换颜色。
代码如下：
Option Explicit
Private Sub Form_Load()
Picture1.Font.Size = 72: Picture1.Font.Bold = True
Picture1.ForeColor = vbRed: Picture1.AutoRedraw = True
Picture1.Visible = False: Picture1.ScaleMode = 3: Me.ScaleMode = 3
Me.WindowState = 2
End Sub
Private Sub Form_Click()
Dim st As String, z As String, r() As Boolean, r1 As Long
Dim w As Integer, h As Integer, x As Integer, y As Integer
Dim i As Integer, J As Integer, k As Integer
st = "新年好"
w = Picture1.TextWidth(st): h = Picture1.TextHeight(st)
Picture1.Move 0, 0, w, h
Picture1.CurrentX = x: Picture1.CurrentY = y: Picture1.Print st
ReDim r(1 To w, 1 To h)
For i = 1 To w '按行列取点，如果该点与左右上下四点的颜色相同，则标记该点
For J = 1 To h
r1 = Picture1.Point(i, J)
If r1 = vbRed Then r(i, J) = (Picture1.Point(i - 1, J) = r1 And Picture1.Point(i + 1, J) = r1 And Picture1.Point(i, J - 1) = r1 And Picture1.Point(i, J + 1) = r1)
Next
Next
For i = 1 To w '如果某一点做了标记，则修改为白色
For J = 1 To h
If r(i, J) Then Picture1.PSet (i, J), vbWhite
Next
Next
Picture1.Picture = Picture1.Image
PaintPicture Picture1, 0, 40, w * 3, h * 3 '放大3倍复制到窗体
End Sub
如果你觉得笔划还要加粗，那么可将有关代码修改如下：
st = "新年好": k = 6
w = Picture1.TextWidth(st) + (k + 1) * Len(st): h = Picture1.TextHeight(st) + k
Picture1.Move 0, 0, w, h
For i = 1 To Len(st) '逐个打印，并加粗笔划
z = Mid(st, i, 1)
For J = 1 To k
Picture1.CurrentX = x: Picture1.CurrentY = y: Picture1.Print z
x = x + 1: y = y + 1
Next
x = x + Picture1.TextWidth(z): y = 0
Next
ReDim r(1 To w, 1 To h)
2009.02.06
笔者所说的空心字，是指笔划边缘颜色保持不变，而将字符笔划内部“掏空”，填上另一种颜色。
可以有多种方法达到这个要求。但笔者这种方法是自动的，不需要人工干预，非常简单实用。
思路：首先把最大的粗体72号字（使用72号字的原因是考虑到如果以后要放大，那么这个字号的锯齿边比较轻微）用某种颜色（例如红色）打印到图片框上，再逐个取点判断：如果该点的前后上下四个点都为红色，则可断定该点位于笔划内部，属于要“掏空”的点，那么就对该点做一个标记（不能直接更换颜色，因为更换颜色以后，下一个点的判断就不对了），最后再逐点检查标记，把凡是有标记的点更换颜色。
代码如下：
Option Explicit
Private Sub Form_Load()
Picture1.Font.Size = 72: Picture1.Font.Bold = True
Picture1.ForeColor = vbRed: Picture1.AutoRedraw = True
Picture1.Visible = False: Picture1.ScaleMode = 3: Me.ScaleMode = 3
Me.WindowState = 2
End Sub
Private Sub Form_Click()
Dim st As String, z As String, r() As Boolean, r1 As Long
Dim w As Integer, h As Integer, x As Integer, y As Integer
Dim i As Integer, J As Integer, k As Integer
st = "新年好"
w = Picture1.TextWidth(st): h = Picture1.TextHeight(st)
Picture1.Move 0, 0, w, h
Picture1.CurrentX = x: Picture1.CurrentY = y: Picture1.Print st
ReDim r(1 To w, 1 To h)
For i = 1 To w '按行列取点，如果该点与左右上下四点的颜色相同，则标记该点
For J = 1 To h
r1 = Picture1.Point(i, J)
If r1 = vbRed Then r(i, J) = (Picture1.Point(i - 1, J) = r1 And Picture1.Point(i + 1, J) = r1 And Picture1.Point(i, J - 1) = r1 And Picture1.Point(i, J + 1) = r1)
Next
Next
For i = 1 To w '如果某一点做了标记，则修改为白色
For J = 1 To h
If r(i, J) Then Picture1.PSet (i, J), vbWhite
Next
Next
Picture1.Picture = Picture1.Image
PaintPicture Picture1, 0, 40, w * 3, h * 3 '放大3倍复制到窗体
End Sub
如果你觉得笔划还要加粗，那么可将有关代码修改如下：
st = "新年好": k = 6
w = Picture1.TextWidth(st) + (k + 1) * Len(st): h = Picture1.TextHeight(st) + k
Picture1.Move 0, 0, w, h
For i = 1 To Len(st) '逐个打印，并加粗笔划
z = Mid(st, i, 1)
For J = 1 To k
Picture1.CurrentX = x: Picture1.CurrentY = y: Picture1.Print z
x = x + 1: y = y + 1
Next
x = x + Picture1.TextWidth(z): y = 0
Next
ReDim r(1 To w, 1 To h)
2009.02.06
