用打印机模拟手写字体-冰丝带雨

众所周知在许多不必要的场合中我们被要求使用手写完成某些任务。比如XX论文5000字，比如每周一次的XX等等。在排除掉写字难看的原因下，我对这类动不动就抄写XX字的任务深恶痛绝，所以就研究了下面的办法，希望能帮助到大家。

当然，要明确的是，这个方法只能应急和应对无聊任务。有利有弊，自由取舍。

首先要准备这么一些东西：两个或者两个以上不同但又相近的手写体字体。我这里用到的是 “书体坊硬笔行书3500” 和“徐静蕾钢笔字体”。字体2-3个合适，越相近越好。当然，要安装好字体。

然后自然是要有文章喽，我用的是这个。

其实直接用上面提到的徐静蕾钢笔体打印也可以，不仔细看看不出问题来，不过抱着GEEK的目的，我们还是动一下小细节–我们要结合两种字体：）

需要用到的是word的宏，使用宏自动修改每一个字体，包括修改字体、放大或缩小0.5号、上浮或下沉0.3行。

宏的内容

    Dim R_Character As Range
    Application.ScreenUpdating = False
    For Each R_Character In ActiveDocument.Characters
        VBA.Randomize
        If 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 = Choose(Int(VBA.Rnd * 2) + 1, "方正静蕾简体", "书体坊硬笔行书3500")
         Else
         R_Character.Font.Name = "方正静蕾简体"
         End If
        R_Character.Font.Size = Choose(Int(VBA.Rnd * 7) + 1, "18", "17.5", "17", "19.5", "18.5", "19", "20")
        R_Character.Font.Position = Choose(Int(VBA.Rnd * 5) + 1, 1.5, 2.5, 2, 0, 1)
        R_Character.Font.Spacing = Choose(Int(VBA.Rnd * 5) + 1, -1.8, -1.5, -1.6, -1.7, -1.4)
    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

复制上面的内容，在word里（我以2010为例）找到视图-宏