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(",", ".", ",", ";", ":", "?", "!", "…", "-", "~", "(", ")", "<", ">")
'提示用戶交互的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一行刪除。
