如何用word制作逼真的手写字体？

最新推荐文章于 2025-12-11 10:51:34 发布

原创最新推荐文章于 2025-12-11 10:51:34 发布 · 1.1w 阅读

31 ·

CC 4.0 BY-SA版权

学习专栏收录该内容

18 篇文章

订阅专栏

本文将指导你如何在Word中创建具有逼真手写风格的字体效果，包括详细步骤和代码应用。

效果

在这里插入图片描述

代码

Sub rand()
 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 = "”" Or R_Character = "！" Or R_Character = "？" Or R_Character = "、" Or R_Character = "：" Then
         R_Character.Font.Name = "世界那么大"
         ElseIf R_Character = "分" Or R_Character = "统" Then
            R_Character.Font.Name = "伯乐俏皮体"
         ElseIf Asc(R_Character) >= 48 And Asc(R_Character) <= 57 Then
            If R_Character = "5" Then
            R_Character.Font.Name = "游狼近草体（简）"
            Else
            R_Character.Font.Name = "建刚字库徐明简体"
            End If
         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 = "游狼近草体（简）"
         Else
            If R_Character = "具" Or R_Character = "有" Or R_Character = "面" Then
            R_Character.Font.Name = Choose(Int(VBA.Rnd * 5) + 1, "陈代明硬笔体2013正式版", "邯郸-郭灵霞灵芝体", "迷你简硬笔行书", "陈代明粉笔字体演示版", "方正硬笔行书简体")
            Else
            R_Character.Font.Name = Choose(Int(VBA.Rnd * 2) + 1, "邯郸-郭灵霞灵芝体", "邯郸-郭灵霞灵芝体")
            End If
         End If
        R_Character.Font.Size = Choose(Int(VBA.Rnd * 7) + 1, "19", "18", "18", "19.5", "18.5", "19", "19.5")
        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

End Sub