1、   為宏命令指定快捷鍵。
在WORD中，操作可以通過菜單項或工具欄按鈕實現(xiàn)，如果功能項有對應(yīng)的快捷鍵的話，利用快捷鍵可以快速實現(xiàn)我們需要的功能。如最常見的CTRL＋O、CTRL＋A等等。WORD已經(jīng)為很多功能指定了快捷鍵，可以大大提高WORD的操作速度，比用鼠標(biāo)操作快捷很多。

而我們自己編輯或者錄制的宏，可以用菜單項操作完成，也可以為這些命令設(shè)置按鈕，通過工具欄按鈕操作，如果為這些常用的宏指定合適的快捷鍵，會為我們提供很大的便利。

如何為功能項設(shè)置快捷鍵或修改功能項已有的快捷鍵，需要對 WORD進(jìn)行自定義設(shè)置。
在WORD主界面中，點擊“工具”菜單下的“自定義”菜單項， 在“自定義”對話框中，點擊“鍵盤”，如下圖所示：

2、   舉例說明
WORD打開狀態(tài)下，按ALT＋F11，打開VBA編輯器，粘貼如下代碼


Sub 英文引號轉(zhuǎn)中文雙引號()
'
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


保存后，再打開“自定義”等命令可以出現(xiàn)下圖：

這時按你要指定的快捷鍵，一一般要跟CTRL、ALT和SHIFT結(jié)合，可選取一個兩個或者三個，再加上某一個字母。上例我為選定的宏指定的快捷鍵為ALT+"，因為"與'是在同一鍵上，實際操作是按三個鍵。如果“目前指定到”項為[未指定]，選擇是保存常規(guī)模板“NORMAL”還是本文檔，點“指定”，然后關(guān)閉。每次按ALT+"，就會執(zhí)行這段VBA命令。

3、   指定快捷鍵，盡量不要使用WORD已經(jīng)使用的快捷鍵，如果一定使用，那么該快捷鍵將不再指定給原有的功能命令。指定的快捷鍵要方便記憶，要有一定的規(guī)律。
4、如果對WORD默認(rèn)為功能命令指定的快捷鍵或自己指定的快捷鍵不滿意，可以進(jìn)入“自定義鍵盤”對話框，在“當(dāng)前快捷鍵”列表中，選中要刪除的快捷鍵，此時“刪除”按鈕被激活，點擊“刪除”，指定的功能命令的快捷鍵就被刪除了。

也可為符號和樣式指定快捷，這里不再多說了，下面就放幾段宏命令。如有錯誤，務(wù)必指出。如有侵權(quán)，請告知，馬上刪除。

常規(guī)設(shè)置下標(biāo)的過程：輸入，選定，設(shè)定下標(biāo)，取消選定，設(shè)置非下標(biāo)，繼續(xù)輸入。下面的命令設(shè)置光標(biāo)前一個字符為下標(biāo)，并繼續(xù)輸入時保持設(shè)置前的格式。后面的例子不再解釋。
Sub Macro1()
'
' Macro1 Macro
' 設(shè)置光標(biāo)前一個字符為下標(biāo),快捷鍵為"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
' 設(shè)置光標(biāo)前一個字符為上標(biāo),快捷鍵為"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
' 設(shè)置光標(biāo)前一個字符為斜體,快捷鍵為"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
' 調(diào)整中西文字符間距,快捷鍵為"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
' 設(shè)置光標(biāo)前一個文字加著重號,快捷鍵為"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
' 調(diào)整中文和數(shù)字符間距,快捷鍵為"Alt+N"
'
If Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = False Then
Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = True
Else
Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = False
End If
End Sub

設(shè)置分式的宏命令：A為分子，B為分母，輸入A,B（注意AB之間的逗號為英文逗號）。如果分子是ABC，分母是DG，輸入ABC,DG按住SHIFT，按左方向鍵，選定剛才輸入的字符，留3個不選，執(zhí)行下面的命令。

Sub 分式()
'
' 分式 Macro
' 設(shè)置選定分?jǐn)?shù),快捷鍵為"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
' 設(shè)置選定的兩個字母上加弧
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()
'根據(jù)文檔字符數(shù)中重復(fù)頻率排序字符并計數(shù)
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* 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 & "個不重復(fù)的字符,用時" & VBA.Format(Timer - st, "0.00") & "秒"
End Sub

Sub yy()
'本代碼旨在解決WORD中數(shù)據(jù)轉(zhuǎn)化為千分位
'數(shù)據(jù)限定要求:-922,337,203,685,477.5808 到 922,337,203,685,477.5807
'轉(zhuǎn)化結(jié)果1000以上數(shù)據(jù)以千分位計算,小數(shù)點右側(cè)保留二位小數(shù);1000以下數(shù)據(jù)不變
Dim myRange As Range, i As Byte, myValue As Currency
On Error Resume Next
Application.ScreenUpdating = False '關(guān)閉屏幕更新
NextFind: Set myRange = ActiveDocument.Content '定義為主文檔文字部分
With myRange.Find '查找
.ClearFormatting '清除格式
.Text = "[0-9]{4,15}" '4到15位數(shù)據(jù)
.MatchWildcards = True '使用通配符
Do While .Execute '每次查找成功
i = 2 '起始值為2
'如果是有小數(shù)點
If myRange.Next(wdCharacter, 1) = "." Then
'進(jìn)行一個未知循環(huán)
While myRange.Next(wdCharacter, i) Like "#"
i = i + 1 '只要是[0-9]任意數(shù)字則累加
Wend
'重新定義RANGE對象
myRange.SetRange myRange.Start, myRange.End + i - 1
End If
myValue = VBA.Val(myRange) '保險起見轉(zhuǎn)換為數(shù)據(jù),也可省略
myRange = VBA.Format(myValue, "Standard") '轉(zhuǎn)為千分位格式
GoTo NextFind '轉(zhuǎn)到指定行
Loop
End With
Application.ScreenUpdating = True '恢復(fù)屏幕更新
End Sub

Sub setpicsize_1() '設(shè)置圖片大小為當(dāng)前的百分比
Dim n '圖片個數(shù)
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 '設(shè)置高度
ActiveDocument.InlineShapes(n).Width = picwidth * 0.5 '設(shè)置寬度
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 '設(shè)置高度倍數(shù)
ActiveDocument.Shapes(n).Width = picwidth * 0.5 '設(shè)置寬度倍數(shù)
Next n

Else End If
End Sub

Sub setpicsize_2() '設(shè)置圖片大小為固定值
Dim n '圖片個數(shù)
On Error Resume Next '忽略錯誤
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes類型圖片
ActiveDocument.InlineShapes(n).Height = 400 '設(shè)置圖片高度為 400px
ActiveDocument.InlineShapes(n).Width = 300 '設(shè)置圖片寬度 300px
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes類型圖片
ActiveDocument.Shapes(n).Height = 400 '設(shè)置圖片高度為 400px
ActiveDocument.Shapes(n).Width = 300 '設(shè)置圖片寬度 300px
Next n
End Sub

Sub 圖片版式轉(zhuǎn)換()
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* 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將圖片由嵌入式轉(zhuǎn)為浮動式,N將圖片由浮動式轉(zhuǎ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()
'把數(shù)字轉(zhuǎn)化為漢字大寫人民幣
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) '四舍五入保留小數(shù)點后兩位
'判斷是否在表格中
If .Information(wdWithInTable) Then _
.MoveRight Unit:=wdCell Else .MoveRight Unit:=wdCharacter
'對數(shù)據(jù)進(jìn)行判斷,是否在指定的范圍內(nèi)
If VBA.Abs(Numeric) > 2147483647 Then MsgBox "數(shù)值超過范圍!", _
vbOKOnly + vbExclamation, "Warning": Exit Sub
IntPart = Int(VBA.Abs(Numeric)) '定義一個正整數(shù)
Odd = VBA.IIf(IntPart = 0, "", "圓") '定義一個STRING變量
'插入中文大寫前的標(biāo)簽
Label = VBA.IIf(Numeric = VBA.Abs(Numeric), "人民幣金額大寫:　", "人民幣金額大寫:　負(fù)")
'對小數(shù)點后面二位數(shù)進(jìn)行擇定
DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100
Select Case DecimalPart
Case Is = 0 '如果是0,即是選定的數(shù)據(jù)為整數(shù)
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) & "角" '轉(zhuǎn)換為角的中文大寫
Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "分" '轉(zhuǎn)換為分的中文大寫
End Select
'指定區(qū)域插入中文大寫格式的域
Set MyField = .Fields.Add(Range:=.Range, Text:="= " & IntPart & " \*CHINESENUM2")
MyField.Select '選定域(最后是用指定文本覆蓋選定區(qū)域)
'如果僅有角分情況下,Mychinese為""
MyChinese = VBA.IIf(MyField.Result <> "零", MyField.Result, "")
.Text = Label & MyChinese & Oddment
End With
Else
MsgBox "您沒有選擇數(shù)字。"
End If End Sub

Sub ToggleInterpunction() '中英文標(biāo)點互換
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
'定義一個中文標(biāo)點的數(shù)組對象
ChineseInterpunction = Array("、", "。", "，", "；", "：", "？", "！", "……", "—", "～", "（", "）", "《", "》")
'定義一個英文標(biāo)點的數(shù)組對象
EnglishInterpunction = Array(",", ".", ",", ";", ":", "?", "!", "…", "-", "~", "(", ")", "<", ">")
'提示用戶交互的MSGBOX對話框
msgResult = MsgBox("您想中英標(biāo)點互換嗎?按Y將中文標(biāo)點轉(zhuǎn)為英文標(biāo)點,按N將英文標(biāo)點轉(zhuǎn)為中文標(biāo)點!", vbYesNoCancel)
Select Case msgResult
Case vbCancel
Exit Sub '如果用戶選擇了取消按鈕,則退出程序運行
Case vbYes '如果用戶選擇了YES,則將中文標(biāo)點轉(zhuǎn)換為英文標(biāo)點
myArray1 = ChineseInterpunction
myArray2 = EnglishInterpunction
strFind = "“(*)”"
strRep = """\1"""
Case vbNo '如果用戶選擇了NO,則將英文標(biāo)點轉(zhuǎn)換為中文標(biāo)點
myArray1 = EnglishInterpunction
myArray2 = ChineseInterpunction
strFind = """(*)"""
strRep = "“\1”"
End Select
Application.ScreenUpdating = False '關(guān)閉屏幕更新
For n = 0 To UBound(ChineseInterpunction) '從數(shù)組的下標(biāo)到上標(biāo)間作一個循環(huán)
With ActiveDocument.Content.Find
.ClearFormatting '不限定查找格式
.MatchWildcards = False '不使用通配符
'查找相應(yīng)的英文標(biāo)點,替換為對應(yīng)的中文標(biāo)點
.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 '恢復(fù)屏幕更新
End Sub

Sub 圖片版式轉(zhuǎn)換()
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* 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將圖片由嵌入式轉(zhuǎn)為浮動式,N將圖片由浮動式轉(zhuǎ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 設(shè)置圖片大小為原始大小()
Dim n '圖片個數(shù)
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() '設(shè)置圖片大小為當(dāng)前的百分比
Dim n '圖片個數(shù)
Dim beilv
Dim picwidth
Dim picheight
On Error Resume Next '忽略錯誤 ' If MsgBox("確定要改變文檔中圖片大?。?/SPAN>", 68) = 6 Then
beilv = Val(InputBox(Prompt:="　　請輸入數(shù)字，然后按“確定”，文檔中所有圖形、圖片和文本框的大小將按輸入的數(shù)字以相同的寬高比縮放。 " & 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 '設(shè)置高度倍數(shù)
ActiveDocument.InlineShapes(n).Width = picwidth * beilv '設(shè)置寬度倍數(shù)
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 '設(shè)置高度倍數(shù)
ActiveDocument.Shapes(n).Width = picwidth * beilv '設(shè)置寬度倍數(shù)
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 & "個文檔，保存于目標(biāo)文件夾的名稱為“另存為”的下一級文件夾中。" _
& vbCrLf & "處理時間：" & Format(Timer - st, "0") & "秒。"
Application.ScreenUpdating = True
Exit Sub

hd:
MsgBox "運行出現(xiàn)意外，程序終止！" & vbCrLf & "已處理文檔數(shù)：" & n _
& vbCrLf & "出錯文檔：" & vbCrLf & fs.FoundFiles(i)
If Not myDoc Is Nothing Then myDoc.Close
End Sub

這段代碼是我請 @sylun 為我編寫的，很好用。
這段代碼可以不打開文檔提取指定文件夾的WORD文檔的中的第1段的前10個字符和第2段落的文字作為并被提取文檔的“另存為”文件的文件名，如果想修改提取的文字內(nèi)容，可修改

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

這三行。前兩行是提取第一段的前10字符，后一行是提取第二段的內(nèi)容。如果文檔標(biāo)題是第一段，第二段是作者，把strpsra1＝Left(strpara1, 10)一行刪除，如果沒有標(biāo)題，第一段是一大段內(nèi)容，把strpara2一行刪除。