WORD宏命令

1、 为宏命令指定快捷键。
在WORD中，操作可以通过菜单项或工具栏按钮实现，如果功能项有对应的快捷键的话，利用快捷键可以快速实现我们需要的功能。如最常见的CTRL＋O、CTRL＋A等等。WORD已经为很多功能指定了快捷键，可以大大提高WORD的操作速度，比用鼠标操作快捷很多。

而我们自己编辑或者录制的宏，可以用菜单项操作完成，也可以为这些命令设置按钮，通过工具栏按钮操作，如果为这些常用的宏指定合适的快捷键，会为我们提供很大的便利。

如何为功能项设置快捷键或修改功能项已有的快捷键，需要对 WORD进行自定义设置。
在WORD主界面中，点击“工具”菜单下的“自定义”菜单项， 在“自定义”对话框中，点击“键盘”，如下图所示：




2、 举例说明
WORD打开状态下，按ALT＋F11，打开VBA编辑器，粘贴如下代码


Sub 英文引号转中文双引号()
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = """"
.Forward = True
.Wrap = wdStop
.MatchByte = True
End With
With Selection
While .Find.Execute
.Text = ChrW(8220)
.Find.Execute
.Text = ChrW(8221)
Wend
End With
End Sub


保存后，再打开“自定义”等命令可以出现下图：

这时按你要指定的快捷键，一一般要跟CTRL、ALT和SHIFT结合，可选取一个两个或者三个，再加上某一个字母。上例我为选定的宏指定的快捷键为ALT+"，因为"与'是在同一键上，实际操作是按三个键。如果“目前指定到”项为[未指定]，选择是保存常规模板“NORMAL”还是本文档，点“指定”，然后关闭。每次按ALT+"，就会执行这段VBA命令。

3、 指定快捷键，尽量不要使用WORD已经使用的快捷键，如果一定使用，那么该快捷键将不再指定给原有的功能命令。指定的快捷键要方便记忆，要有一定的规律。
4、如果对WORD默认为功能命令指定的快捷键或自己指定的快捷键不满意，可以进入“自定义键盘”对话框，在“当前快捷键”列表中，选中要删除的快捷键，此时“删除”按钮被激活，点击“删除”，指定的功能命令的快捷键就被删除了。

也可为符号和样式指定快捷，这里不再多说了，下面就放几段宏命令。如有错误，务必指出。如有侵权，请告知，马上删除。

常规设置下标的过程：输入，选定，设定下标，取消选定，设置非下标，继续输入。下面的命令设置光标前一个字符为下标，并继续输入时保持设置前的格式。后面的例子不再解释。
Sub Macro1()
'
' Macro1 Macro
' 设置光标前一个字符为下标,快捷键为"Alt+="
'
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Subscript = True
Selection.MoveRigh

t Unit:=wdCharacter, Count:=1
Selection.Font.Subscript = False
End Sub



Sub Macro9()
'
' Macro9 Macro
' 设置光标前一个字符为上标,快捷键为"Alt++"
'
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Superscript = True
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Superscript = False
End Sub

Sub Macro2()
'
' Macro2 Macro
' 设置光标前一个字符为斜体,快捷键为"Alt+I"
'
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Italic = True
Other = "Times New Roman"
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Italic = False

End Sub

Sub Macro5()
'
' Macro5 Macro
' 调整中西文字符间距,快捷键为"Alt+J"
'
If Selection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = False Then
Selection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = True
Else
Selection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = False
End If

End Sub

Sub Macro4()
'
' Macro4 Macro
' 设置光标前一个文字加着重号,快捷键为"Alt+."
'
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.EmphasisMark = wdEmphasisMarkUnderSolidCircle
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.EmphasisMark = wdEmphasisMarkNone
End Sub

Sub Macro10()
'
' Macro10 Macro
' 调整中文和数字符间距,快捷键为"Alt+N"
'
If Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = False Then
Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = True
Else
Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = False
End If
End Sub

设置分式的宏命令：A为分子，B为分母，输入A,B（注意AB之间的逗号为英文逗号）。如果分子是ABC，分母是DG，输入ABC,DG按住SHIFT，按左方向键，选定刚才输入的字符，留3个不选，执行下面的命令。

Sub 分式()
'
' 分式 Macro
' 设置选定分数,快捷键为"Alt+F"
'
Selection.MoveLeft Unit:=wdCharacter, Count:=3, Extend:=wdExtend
If Selection.Type = wdSelectionNormal Then
'Selection.Font.Italic = True
Selection.Cut
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeBackspace
Selection.TypeText Text:="eq \f()"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Paste
'Selection.TypeText Text:=")"
Selection.Fields.Update
Selection.MoveRight Unit:=wdCharacter, Count:=1
Else
MsgBox "您没有选择文字。"
End If
'
End Sub

Sub 弧()
'
' 弧 Macro
' 设置选定的两个字母上加弧
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
If Selection.Type = wdSelectionNormal Then
Selection.Font.Italic = True
Selection.Cut
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Ty

peText Text:="eq \o(\s\up5(⌒"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Scaling = 150
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Scaling = 100
Selection.TypeText Text:="),\s\do0("
Selection.Paste
Selection.TypeText Text:="))"
Selection.Fields.Update
Selection.MoveRight Unit:=wdCharacter, Count:=1
Else
MsgBox "您没有选择文字。"
End If
'
End Sub

Sub Password()
'
' 文件自动添加密码。
'
If ActiveDocument.WriteReserved = False Then
If MsgBox("是否为本文档添加密码？", vbYesNo) = vbYes Then With ActiveDocument
.Password = "123456"
.WritePassword = "123456"
End With

Else
End If
Else
End If
End Sub

Sub Example()
'根据文档字符数中重复频率排序字符并计数
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@OfficeFans 2008-2-24 18:05:42
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0334^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Dim myDictionary As Object, MyString As String
Dim iCount As Long, i As Long, n As Long
Dim ochar As String, TempA As Variant, st As Single
Dim Array_Keys() As Variant, Array_Items() As Variant
st = VBA.Timer
Set myDictionary = CreateObject("Scripting.Dictionary")
MyString = ActiveDocument.Content.Text
n = Len(MyString) - 1
For i = 1 To n
ochar = VBA.Mid(MyString, i, 1)
If myDictionary.Exists(ochar) = False Then
myDictionary.Add ochar, 1
Else
myDictionary(ochar) = myDictionary(ochar) + 1
End If
Next
MyString = ""
iCount = myDictionary.Count - 1
Array_Keys = myDictionary.keys
Array_Items = myDictionary.Items
Set myDictionary = Nothing
For i = 0 To iCount - 1
For n = i + 1 To iCount
If Array_Items(i) < Array_Items(n) Then
TempA = Array_Items(n)
Array_Items(n) = Array_Items(i)
Array_Items(i) = TempA
TempA = Array_Keys(n)
Array_Keys(n) = Array_Keys(i)
Array_Keys(i) = TempA
End If
Next n
Next i
For i = 0 To iCount
MyString = MyString & Array_Keys(i) & "　" & Array_Items(i) & Chr(13)
Next
ActiveDocument.Content.Text = MyString
MsgBox "共有" & iCount & "个不重复的字符,用时" & VBA.Format(Timer - st, "0.00") & "秒"
End Sub

Sub yy()
'本代码旨在解决WORD中数据转化为千分位
'数据限定要求:-922,337,203,685,477.5808 到 922,337,203,685,477.5807
'转化结果1000以上数据以千分位计算,小数点右侧保留二位小数;1000以下数据不变
Dim myRange As Range, i As Byte, myValue As Currency
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
NextFind: Set myRange = ActiveDocument.Content '定义为主文档文字部分
With myRange.Find '查找
.ClearFormatting '清除格式
.Text = "[0-9]{4,15}" '4到15位数据
.MatchWildcards = True '使用通配符
Do While .Execute '每次查找成功
i = 2 '起始值为2
'

如果是有小数点
If myRange.Next(wdCharacter, 1) = "." Then
'进行一个未知循环
While myRange.Next(wdCharacter, i) Like "#"
i = i + 1 '只要是[0-9]任意数字则累加
Wend
'重新定义RANGE对象
myRange.SetRange myRange.Start, myRange.End + i - 1
End If
myValue = VBA.Val(myRange) '保险起见转换为数据,也可省略
myRange = VBA.Format(myValue, "Standard") '转为千分位格式
GoTo NextFind '转到指定行
Loop
End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

Sub setpicsize_1() '设置图片大小为当前的百分比
Dim n '图片个数
Dim picwidth
Dim picheight
If Selection.Type = wdSelectionNormal Then
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
picheight = ActiveDocument.InlineShapes(n).Height
picwidth = ActiveDocument.InlineShapes(n).Width
ActiveDocument.InlineShapes(n).Height = picheight * 0.5 '设置高度
ActiveDocument.InlineShapes(n).Width = picwidth * 0.5 '设置宽度
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
picheight = ActiveDocument.Shapes(n).Height
picwidth = ActiveDocument.Shapes(n).Width
ActiveDocument.Shapes(n).Height = picheight * 0.5 '设置高度倍数
ActiveDocument.Shapes(n).Width = picwidth * 0.5 '设置宽度倍数
Next n

Else End If
End Sub

Sub setpicsize_2() '设置图片大小为固定值
Dim n '图片个数
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为 400px
ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度 300px
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400px
ActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300px
Next n
End Sub

Sub 图片版式转换()
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-12-11 5:28:26
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0281^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'Option Explicit Dim oShape As Variant, shapeType As WdWrapType
On Error Resume Next
If MsgBox("Y将图片由嵌入式转为浮动式,N将图片由浮动式转为嵌入式", 68) = 6 Then
shapeType = Val(InputBox(Prompt:="请输入图片版式:0=四周型,1=紧密型, " & vbLf & _
"3=衬于文字下方,4=浮于文字上方", Default:=0))
For Each oShape In ActiveDocument.InlineShapes
Set oShape = oShape.ConvertToShape
With oShape
Select Case shapeType
Case 0, 1
.WrapFormat.Type = shapeType
Case 3
.WrapFormat.Type = 3
.ZOrder 5
Case 4
.WrapFormat.Type = 3
.ZOrder 4
Case Else
Exit Sub
End Select
.WrapFormat.AllowOverlap = False '不允许重叠
End With
Next
Else
For Each oSh

ape In ActiveDocument.Shapes
oShape.ConvertToInlineShape
Next
End If
End Sub

Sub GetChineseNum2()
'把数字转化为汉字大写人民币
Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Label As String
Dim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As String
Dim strNumber As String
Const ZWDX As String = "壹贰叁肆伍陆柒捌玖零" '定义一个中文大写汉字常量
On Error Resume Next '错误忽略
If Selection.Type = wdSelectionNormal Then

With Selection
strNumber = VBA.Replace(.Text, " ", "")
Numeric = VBA.Round(ur(strNumber), 2) '四舍五入保留小数点后两位
'判断是否在表格中
If .Information(wdWithInTable) Then _
.MoveRight Unit:=wdCell Else .MoveRight Unit:=wdCharacter
'对数据进行判断,是否在指定的范围内
If VBA.Abs(Numeric) > 2147483647 Then MsgBox "数值超过范围!", _
vbOKOnly + vbExclamation, "Warning": Exit Sub
IntPart = Int(VBA.Abs(Numeric)) '定义一个正整数
Odd = VBA.IIf(IntPart = 0, "", "圆") '定义一个STRING变量
'插入中文大写前的标签
Label = VBA.IIf(Numeric = VBA.Abs(Numeric), "人民币金额大写:　", "人民币金额大写:　负")
'对小数点后面二位数进行择定
DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100
Select Case DecimalPart
Case Is = 0 '如果是0,即是选定的数据为整数
Oddment = VBA.IIf(Odd = "", "", Odd & "整")
Case Is < 10 '<10,即是零头是分
Oddment = VBA.IIf(Odd <> "", "圆零" & VBA.Mid(ZWDX, DecimalPart, 1) & "分", _
VBA.Mid(ZWDX, DecimalPart, 1) & "分")
Case 10, 20, 30, 40, 50, 60, 70, 80, 90 '如果是角整
Oddment = "圆" & VBA.Mid(ZWDX, DecimalPart / 10, 1) & "角整"
Case Else '既有角,又有分的情况
Jiao = VBA.Left(CStr(DecimalPart), 1) '取得角面值
Fen = VBA.Right(CStr(DecimalPart), 1) '取得分面值
Oddment = Odd & VBA.Mid(ZWDX, Jiao, 1) & "角" '转换为角的中文大写
Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "分" '转换为分的中文大写
End Select
'指定区域插入中文大写格式的域
Set MyField = .Fields.Add(Range:=.Range, Text:="= " & IntPart & " \*CHINESENUM2")
MyField.Select '选定域(最后是用指定文本覆盖选定区域)
'如果仅有角分情况下,Mychinese为""
MyChinese = VBA.IIf(MyField.Result <> "零", MyField.Result, "")
.Text = Label & MyChinese & Oddment
End With
Else
MsgBox "您没有选择数字。"
End If End Sub

Sub ToggleInterpunction() '中英文标点互换
Dim ChineseInterpunction() As Variant, EnglishInterpunction() As Variant
Dim myArray1() As Variant, myArray2() As Variant, strFind As String, strRep As String
Dim msgResult As VbMsgBoxResult, n As Byte
'定义一个中文标点的数组对象
ChineseInterpunction = Array("、", "。", "，", "；", "：", "？", "！", "……", "—", "～", "（", "）", "《", "》")
'定义一个英文标点的数组对象
EnglishInterpunction = Array(",", ".", ",", ";", ":", "?",

"!", "…", "-", "~", "(", ")", "<", ">")
'提示用户交互的MSGBOX对话框
msgResult = MsgBox("您想中英标点互换吗?按Y将中文标点转为英文标点,按N将英文标点转为中文标点!", vbYesNoCancel)
Select Case msgResult
Case vbCancel
Exit Sub '如果用户选择了取消按钮,则退出程序运行
Case vbYes '如果用户选择了YES,则将中文标点转换为英文标点
myArray1 = ChineseInterpunction
myArray2 = EnglishInterpunction
strFind = "“(*)”"
strRep = """\1"""
Case vbNo '如果用户选择了NO,则将英文标点转换为中文标点
myArray1 = EnglishInterpunction
myArray2 = ChineseInterpunction
strFind = """(*)"""
strRep = "“\1”"
End Select
Application.ScreenUpdating = False '关闭屏幕更新
For n = 0 To UBound(ChineseInterpunction) '从数组的下标到上标间作一个循环
With ActiveDocument.Content.Find
.ClearFormatting '不限定查找格式
.MatchWildcards = False '不使用通配符
'查找相应的英文标点,替换为对应的中文标点
.Execute findtext:=myArray1(n), replacewith:=myArray2(n), Replace:=wdReplaceAll
End With
Next
With ActiveDocument.Content.Find
.ClearFormatting '不限定查找格式
.MatchWildcards = True '使用通配符
.Execute findtext:=strFind, replacewith:=strRep, Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

Sub 图片版式转换()
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-12-11 5:28:26
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0281^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'Option Explicit Dim oShape As Variant, shapeType As WdWrapType
On Error Resume Next
If MsgBox("Y将图片由嵌入式转为浮动式,N将图片由浮动式转为嵌入式", 68) = 6 Then
shapeType = Val(InputBox(Prompt:="请输入图片版式:0=四周型,1=紧密型, " & vbLf & _
"3=衬于文字下方,4=浮于文字上方", Default:=0))
For Each oShape In ActiveDocument.InlineShapes
Set oShape = oShape.ConvertToShape
With oShape
Select Case shapeType
Case 0, 1
.WrapFormat.Type = shapeType
Case 3
.WrapFormat.Type = 3
.ZOrder 5
Case 4
.WrapFormat.Type = 3
.ZOrder 4
Case Else
Exit Sub
End Select
.WrapFormat.AllowOverlap = False '不允许重叠
End With
Next
Else
For Each oShape In ActiveDocument.Shapes
oShape.ConvertToInlineShape
Next
End If
End Sub

Sub 设置图片大小为原始大小()
Dim n '图片个数
Dim picwidth
Dim picheight
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Reset
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
ActiveDocument.Shapes(n).Select
Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopClientHeigh
Selection

.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopClientwidth
Next n
End Sub

下面的代码可以代替16楼的，操作更方便
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub setpicsize_1() '设置图片大小为当前的百分比
Dim n '图片个数
Dim beilv
Dim picwidth
Dim picheight
On Error Resume Next '忽略错误 ' If MsgBox("确定要改变文档中图片大小？", 68) = 6 Then
beilv = Val(InputBox(Prompt:=" 请输入数字，然后按“确定”，文档中所有图形、图片和文本框的大小将按输入的数字以相同的宽高比缩放。 " & vbLf & vbLf & _
" 退出按“取消”。", Default:=0.8))
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
picheight = ActiveDocument.InlineShapes(n).Height
picwidth = ActiveDocument.InlineShapes(n).Width
ActiveDocument.InlineShapes(n).Height = picheight * beilv '设置高度倍数
ActiveDocument.InlineShapes(n).Width = picwidth * beilv '设置宽度倍数
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
picheight = ActiveDocument.Shapes(n).Height
picwidth = ActiveDocument.Shapes(n).Width
ActiveDocument.Shapes(n).Height = picheight * beilv '设置高度倍数
ActiveDocument.Shapes(n).Width = picwidth * beilv '设置宽度倍数
Next n
' Else
' End If
End Sub

Sub mySaveAs()
'

Dim i As Long, st As Single, mypath As String, fs As FileSearch
Dim myDoc As Document, n As Integer
Dim strpara1 As String, strpara2 As String, docname As String, a

On Error GoTo hd
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选定任一文件，确定后将重命名全部WORD文档"
If .Show <> -1 Then Exit Sub
st = Timer
mypath = .InitialFileName
End With

Application.ScreenUpdating = False
If Dir(mypath & "另存为", vbDirectory) = "" Then MkDir mypath & "另存为" '另存为文档的保存位置
Set fs = Application.FileSearch
With fs
.NewSearch
.LookIn = mypath
.FileType = msoFileTypeWordDocuments
If .Execute(msoSortByFileName) > 0 Then
For i = 1 To .FoundFiles.Count
If InStr(fs.FoundFiles(i), "~$") = 0 Then
Set myDoc = Documents.Open(.FoundFiles(i), Visible:=False)
With myDoc
strpara1 = Replace(.Paragraphs(1).Range.Text, Chr(13), "")
strpara1 = Left(strpara1, 10)
strpara2 = Replace(.Paragraphs(2).Range.Text, Chr(13), "")
If Len(strpara1) < 2 Or Len(strpara2) < 2 Then GoTo hd
docname = strpara1 & "_" & strpara2
docname = CleanString(docname)
For Each a In Array("\", "/", ":", "*", "?", """ ", "<", " >", "|")
docname = Replace(docname, a, "")
Next
.SaveAs mypath & "另存为\" & docname & ".doc"
n = n + 1
.Close
End With
End If
Next
End If
End With
MsgBox "共处理了" & fs.FoundFiles.Count & "个文档，保存于目标文件夹的名称为“另存为”的下一级文件夹中。" _
& vbCrLf & "处理时间：" & Format(Timer - st, "0") & "秒。"
Application.ScreenUpdating = True
Exit Sub

hd:
MsgBox "运行

出现意外，程序终止！" & vbCrLf & "已处理文档数：" & n _
& vbCrLf & "出错文档：" & vbCrLf & fs.FoundFiles(i)
If Not myDoc Is Nothing Then myDoc.Close
End Sub

这段代码是我请 @sylun 为我编写的，很好用。
这段代码可以不打开文档提取指定文件夹的WORD文档的中的第1段的前10个字符和第2段落的文字作为并被提取文档的“另存为”文件的文件名，如果想修改提取的文字内容，可修改

strpara1 = Replace(.Paragraphs(1).Range.Text, Chr(13), "")
strpara1 = Left(strpara1, 10)
strpara2 = Replace(.Paragraphs(2).Range.Text, Chr(13), "")

这三行。前两行是提取第一段的前10字符，后一行是提取第二段的内容。如果文档标题是第一段，第二段是作者，把strpsra1＝Left(strpara1, 10)一行删除，如果没有标题，第一段是一大段内容，把strpara2一行删除。