利用VBA实现word文档手写体打印

一、缘起

在日常工作中，经常遇到需要大量手写的时候，比如申请书、读后感、观后感，还有单位要求的其他需要手写的文档。作为信息技术人员，当然是能用计算机解决的，就绝不动手。下面就分享自己在打印体转手写体的一次实践。

二、实现

1、下载手写字体

字体网站很多（常用的 字体天下），可以去下载免费的手写字体

2、导入书写字体

大多数的系统字体都在这个路径：C:\Windows\Fonts，我们只需要把刚才下载的字体解压，然后放到这个路径就大功告成。

3、效果展示

有点手写的感觉了，但仔细看你会发现许多问题，比如字体都是一样大，并且每行都十分整齐，相邻两个字左右间距一致，然而我们手写的时候是做不到打印体这样 整齐的，所以需要继续优化。

4、利用VBA优化

需要实现三点，一、字体大小需要在一定范围内波动；二、行间距需要随机波动；三、左右字间距需要随机波动。代码如下：

Dim R_Character As Range
' 字体大小在下列值之间进行波动，改成需要的大小，重复出现的次数越多，相应出现的概率越大，最小精度0.5
Dim FontSize() As String
FontSize = Split("17.5,18.5,19.5,19,18", ",")
Dim FontName() As String
FontName = Split("陈静的字完整版,萌妹子体,李国夫手写体", ",")
'a数值越大，行距越大，波动范围a+x, x∈[-1~1]
a = 0
'b数值越大，字距越大，波动范围b+x, x∈[-1~1]
b = 0
'行间距 在一定以下值中均等分布，改成需要的大小，范围c+x, x∈[0~5]
c = 25
For Each R_Character In ActiveDocument.Characters
VBA.Randomize
' 数组长度
FontNameLength = UBound(FontName) - LBound(FontName)
FontSizeLength = UBound(FontSize) - LBound(FontSize)
' 字号大小
R_Character.Font.Size = FontSize(Int(VBA.Rnd * FontSizeLength) + 1)
' 字的上下偏移
R_Character.Font.Position = Choose(Int(VBA.Rnd * 5) + 1, -1, -0.5, 0, 0.5, 1) + a
' 字的左右间距
R_Character.Font.Spacing = Choose(Int(VBA.Rnd * 5) + 1, -1, -0.5, 0, 0.5, 1) + b

5、优化后效果

三、附件

1、A4纸打印效果

2、信纸打印效果

3、完整代码

Sub 字体修改()
' 字体修改 宏
Dim R_Character As Range
' 字体大小在下列值之间进行波动，改成需要的大小，重复出现的次数越多，相应出现的概率越大，最小精度0.5
Dim FontSize() As String
FontSize = Split("17.5,18.5,19.5,19,18", ",")
'字体名称在下列字体之间进行波动，改成需要的字体，但需要保证系统拥有下列字体，可以在word查看字体名字
Dim FontName() As String
FontName = Split("陈静的字完整版,萌妹子体,李国夫手写体", ",")
' 推荐字体
' "萌妹子体,张维镜手写楷书,萌妹子体,汉仪晨妹子W,小豆岛风物诗简繁,小豆岛秋日和简繁"
'a数值越大，行距越大，波动范围a+x, x∈[-1~1]
a = 0
'b数值越大，字距越大，波动范围b+x, x∈[-1~1]
b = 0
'行间距 在一定以下值中均等分布，改成需要的大小，范围c+x, x∈[0~5]
c = 25
For Each R_Character In ActiveDocument.Characters
VBA.Randomize
' 数组长度
FontNameLength = UBound(FontName) - LBound(FontName)
FontSizeLength = UBound(FontSize) - LBound(FontSize)
' 字号大小
R_Character.Font.Size = FontSize(Int(VBA.Rnd * FontSizeLength) + 1)
' 字的上下偏移
R_Character.Font.Position = Choose(Int(VBA.Rnd * 5) + 1, -1, -0.5, 0, 0.5, 1) + a
' 字的左右间距
R_Character.Font.Spacing = Choose(Int(VBA.Rnd * 5) + 1, -1, -0.5, 0, 0.5, 1) + b
If R_Character = "。" Or R_Character = "，" Or R_Character = "," Or R_Character = "；" Or R_Character = "’" Or R_Character = "‘" Or R_Character = "“" Or R_Character = "”" Or R_Character = "！" Or R_Character = "？" Or R_Character = "、" Or R_Character = "：" Then
' 中文常用标点符号
' 标点固定用以下字体
R_Character.Font.Name = "李国夫手写体"
' 标点随机用FontName中字体
'R_Character.Font.Name = FontName(Int(VBA.Rnd * FontSizeLength))
ElseIf Asc(R_Character) >= 48 And Asc(R_Character) <= 57 Then
' 数字
R_Character.Font.Name = "陈静的字完整版"
ElseIf Asc(R_Character) >= 97 And Asc(R_Character) <= 122 Or Asc(R_Character) >= 65 And Asc(R_Character) <= 90 Or R_Character = "." Or R_Character = "（" Or R_Character = "）" Or R_Character = "(" Or R_Character = ")" Then
' 大小写字母
R_Character.Font.Name = "陈静的字完整版"
End If
Next
For Each Cur_Paragraph In ActiveDocument.Paragraphs
' 设置行间距类型为固定值
Cur_Paragraph.LineSpacingRule = wdLineSpaceExactly
' 设置行间距的值
Cur_Paragraph.LineSpacing = Int(VBA.Rnd * 5) + 1 + c
Next
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "“"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "”"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.ScreenUpdating = True
End Sub