VBA自动加拼音

windows99

             老师宏里面输入那些代码可以自动加拼音 可以更改对齐方式 字体 字号 偏移量 跪求老师

windows99

Sub 逐句加注拼音()
   
   Num = ActiveDocument.Sentences.Count
   
   For sen = 1 To Num
   
        ActiveDocument.Sentences(sen).Select
        
        ' 调整字号为8磅
        SendKeys "+{tab 3}", 2
        SendKeys "+{s}", 2
        SendKeys "{up 7}", 2
        SendKeys "{down 4}", 2
        
        ' 调整偏移量为2磅
        SendKeys "{tab}", 2
        SendKeys "+{o}", 2
        SendKeys "{up 2}", 2
        
        ' 确认
        SendKeys "{enter}", 2
        
        Application.Run MacroName:="FormatPhoneticGuide"
   
   Next sen
End Sub

老师以下代码可以加拼音但是不能改对齐方式 和 字体老师怎么添加呢

sylun

可试试如下类似代码，测试时可能需作相应改动：

1. <blockquote>Sub test()

复制代码

a838469224

这个看着比较深奥呢

sylun

昨晚本想对代码作些修改，但最终修没了。主要是后面用函数处理有问题，需改用查找替换办法。可试试如下代码，只是使用时需据实对代码作相应修改

1. Sub test1()
   
2.     Dim myRange As Range
   
3.     Dim aSentence As Range
   
4.     Dim aField As Field
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
   
8.     ActiveDocument.ActiveWindow.View.ShowFieldCodes = False
   
9.     For Each aSentence In myRange.Sentences
   
10.         If aSentence.Text Like "*[一-龥]*" Then
    
11.             aSentence.Select
    
12.             Dialogs(986).Show 1
    
13.         End If
    
14.     Next:
    
15.    
    
16. '    以下循环语句可用于调整拼音文本的设置参数（开关），如有必要，请据实自行测试后设定替换方案
    
17. '    显示域代码后即可看到EQ域的代码文本，其中包括原设置中的各项参数，可据实修改代码中的参数文本
    
18. '    代码文本中jc,hps,up加数字分别表示对齐、偏移量
    
19.     For Each aField In myRange.Fields
    
20.         If aField.Type = wdFieldFormula Then
    
21.             With aField.Code.Find
    
22.                 .MatchWildcards = True
    
23.                 .Execute findtext:="( hps)[0-9]{1,}", replacewith:="\116 ", Replace:=wdReplaceAll
    
24.                 .Execute findtext:="(\up )[0-9]{1,}", replacewith:="\114", Replace:=wdReplaceAll
    
25.                 .Execute findtext:="Font:宋体", replacewith:="Font:仿宋", Replace:=wdReplaceAll
    
26.                 .Font.Size = 7
    
27.                 .Replacement.Font.Size = 10
    
28.                 .Execute findtext:=Empty, replacewith:=Empty, Replace:=wdReplaceAll
    
29.             End With
    
30.         End If
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码

如用SendKeys语句操作，可试试如下代码：

1. Sub test2()
   
2.     Dim myRange As Range
   
3.     Dim aSentence As Range
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
   
7.     ActiveDocument.ActiveWindow.View.ShowFieldCodes = False
   
8.     For Each aSentence In myRange.Sentences
   
9.         If aSentence.Text Like "*[一-龥]*" Then
   
10.             aSentence.Select
    
11.             SendKeys "%L{DOWN}%F仿宋%O{UP 2}%S8{ENTER 2}", True
    
12.             Application.Run "FormatPhoneticGuide"
    
13.         End If
    
14.     Next
    
15.     Application.ScreenUpdating = True
    
16. End Sub

复制代码

praijna

感恩各位老师的分享！

windows99

sylun 发表于 2019-9-5 20:44
昨晚本想对代码作些修改，但最终修没了。主要是后面用函数处理有问题，需改用查找替换办法。可试试如下代码 ...

老师测试不过去

sylun

windows99 发表于 2019-9-11 18:37
老师测试不过去

只在2003版测试通过，其他版本没测试