[求助]求高手挑战－word如何排版出手写效果？？

sqhsqhli

再议此贴。
为了以假乱真，我又增加了一种字体，双引号干脆不要了。但是有个问题就是效率太低了，页数多了像死机了。
Sub 手写字体()
    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, "方正静蕾简体", "书体坊安景臣钢笔行书")
         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
End Sub

sqhsqhli

能不能这样：
先随机打乱文字顺序，然后按照所有可能出现的格式总数等分成若干组，设置每组对应一种格式，再重新恢复文字顺序。
这样就无需在字符中循环了，当文档很长时，应该可以提升效率。我只有想法，却不能写出代码，盼高手只招！！！

onetoone01

感谢楼主和二楼的分享！！！！尝试一下

tarimland

每个人都用同样的字体，领导肯定会发现的，还有大家都在一个单位，别人怎么写字，笔记怎么样，领导会知道的。如果用打印机打出来，领导一看不是本人的笔迹，就漏馅了，hehe～

aili2011

看到你的帖子才知道真的有人研究了，能吧方法也发给我分享一下吗？ 谢谢啦！

chris1998

来向大家学习啦！

lazywxm

sqhsqhli 发表于 2011-1-26 09:50
再议此贴。
为了以假乱真，我又增加了一种字体，双引号干脆不要了。但是有个问题就是效率太低了，页数多了 ...

试了一下，挺不错的，赞。

-喵小主-

别的都很好啦，就是段落的左右两边对的太整齐了，有宏可改吗

loquat

对21楼代码做简化。。。

1. Sub 手写字体_loquat()
   
2.     Dim R_Character As Range, aRange As Range
   
3.     Application.ScreenUpdating = False
   
4.     For Each R_Character In ActiveDocument.Characters
   
5.        'DoEvents  '这样应该可以解决假死问题，但是较大地影响效率，虽然也可以用API降低其影响但是这里就不班门弄斧了。
   
6.         VBA.Randomize
   
7.         If InStr(1, "、。‘’“”！？", R_Character) > 0 Then '还可以加其他标点符号
   
8.             R_Character.Font.Name = Choose(Int(VBA.Rnd * 2) + 1, "方正静蕾简体", "书体坊安景臣钢笔行书")
   
9.         Else
   
10.             R_Character.Font.Name = "方正静蕾简体"
    
11.         End If
    
12.         '下面三行代码应该自己去更改
    
13.         R_Character.Font.Size = Choose(Int(VBA.Rnd * 7) + 1, "18", "17.5", "17", "19.5", "18.5", "19", "20")
    
14.         R_Character.Font.Position = Choose(Int(VBA.Rnd * 5) + 1, 1.5, 2.5, 2, 0, 1)
    
15.         R_Character.Font.Spacing = Choose(Int(VBA.Rnd * 5) + 1, -1.8, -1.5, -1.6, -1.7, -1.4)
    
16.     Next
    
17.     With Selection.Find
    
18.         .ClearFormatting
    
19.         .Replacement.ClearFormatting
    
20.         .Text = "[“”]"
    
21.         .Forward = True
    
22.         .Wrap = wdFindContinue
    
23.         .MatchWildcards = True
    
24.         .Execute Replace:=wdReplaceAll
    
25.     End With
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

xyz74sc

除非没人看，不然再怎么也能区分手写稿和打印稿