Word 宏命令大全

Posted 2020-08-22 beiwenwoshishui

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.MoveRight 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 Selection.Font.NameOther = "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.TypeText 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 oShape 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(VBA.CCur(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(",", ".", ",", ";", ":", "?", "!", "…", "-", "~", "(", ")", "&lt;", "&gt;") ‘提示用户交互的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一行删除。