word的手写字体

需要先去网站下载字体，可再在代码中修改字体名字

在word的宏进行编辑，WPS不能

代码一：

Sub 字体修改()

'

' 字体修改 宏

'

    Dim R_Character As Range

    Dim FontSize(5)

    ' 字体大小在5个值之间进行波动，可以改写

    FontSize(1) = "21"

    FontSize(2) = "21.5"

    FontSize(3) = "22"

    FontSize(4) = "22.5"

    FontSize(5) = "23"

    Dim FontName(3)

    '字体名称在三种字体之间进行波动，可改写，但需要保证系统拥有下列字体

    FontName(1) = "陈静的字完整版"

    FontName(2) = "萌妹子体"

    FontName(3) = "李国夫手写体"

    Dim ParagraphSpace(5)

    '行间距 在一定以下值中均等分布，可改写

    ParagraphSpace(1) = "12"

    ParagraphSpace(2) = "13"

    ParagraphSpace(3) = "20"

    ParagraphSpace(4) = "7"

    ParagraphSpace(5) = "12"

    '不懂原理的话，不建议修改下列代码

    For Each R_Character In ActiveDocument.Characters

        VBA.Randomize

        R_Character.Font.Name = FontName(Int(VBA.Rnd * 3) + 1)

        R_Character.Font.Size = FontSize(Int(VBA.Rnd * 5) + 1)

        R_Character.Font.Position = Int(VBA.Rnd * 3) + 1

        R_Character.Font.Spacing = 0

    Next

    Application.ScreenUpdating = True

    For Each Cur_Paragraph In ActiveDocument.Paragraphs

        Cur_Paragraph.LineSpacing = ParagraphSpace(Int(VBA.Rnd * 5) + 1)

    Next

        Application.ScreenUpdating = True

End Sub

代码二：

Sub 字体()
'
' 字体 宏
'
'
Dim R_Character As Range

    ' 字体大小在下列值之间进行波动，改成需要的大小，重复出现的次数越多，相应出现的概率越大，最小精度0.5
    Dim FontSize() As String
    FontSize = Split("18.5,18.5,18.5,19,18", ",")

    '字体名称在下列字体之间进行波动，改成需要的字体，但需要保证系统拥有下列字体，可以在word查看字体名字
    '请注意，这里的值只影响中文，英文和数字的字体是固定的，如果需要修改英文和数字的字体，可以在下面的代码中修改
    Dim FontName() As String
    FontName = Split("130-上首追光手写体,130-上首追光手写体,130-上首追光手写体,130-上首追光手写体,130-上首追光手写体", ",")
    
    ' 推荐字体
    ' "萌妹子体,张维镜手写楷书,手写大象体,陈静的字完整版,汉仪晨妹子W"
    ' 不太理想但可以凑合的字体
    ' "汉仪平安行粗简", "Aa一见钟情 (非商业使用)", "李国夫手写字体"

    '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 Selection.Characters

        VBA.Randomize
        
        ' 数组长度
        FontNameLength = UBound(FontName) - LBound(FontName)
        FontSizeLength = UBound(FontSize) - LBound(FontSize)

        ' 字体类型
        R_Character.Font.Name = FontName(Int(VBA.Rnd * FontNameLength) + 1)
        ' 字号大小
        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 = "汉仪晨妹子W"
        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 = "汉仪晨妹子W"
        End If

    Next

    For Each Cur_Paragraph In ActiveDocument.Paragraphs
        ' 设置行间距类型为固定值
        Cur_Paragraph.LineSpacingRule = wdLineSpaceExactly
        ' 设置行间距的值
        Cur_Paragraph.LineSpacing = Int(VBA.Rnd * 5) + c
    Next

        ' 设置首行缩进，如不需要注释With到End With这段代码
    With Selection.ParagraphFormat
                ' 每个缩进单位长度，厘米
        .FirstLineIndent = CentimetersToPoints(0.35)
                ' 设置缩进单位
        .CharacterUnitFirstLineIndent = 2
    End With

    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

应用于全文改成选中部分是将ActiveDocument.Characters改为Selection.Characters

存在一些问题，调整行距的数值调整后，没有发生变化。