[Word]実用(?)マクロ集

Public Sub FieldUnlink()
    Selection.Fields.Unlink
End Sub

Private Sub AddFieldAsConst(Field As String)
    With Selection
        .Fields.Add(Range:=.Range, Type:=wdFieldEmpty, Text:=Field).Unlink
    End With
End Sub

Public Sub AddNumPages()
    AddFieldAsConst "NUMPAGES  "
End Sub

Public Sub AddTime()
    AddFieldAsConst "TIME  \@ ""AMPMh時m分s秒"" "
End Sub

Private Sub AddFieldAsConst(Field As String)
    Dim NewField As Field
    Set NewField = Selection.Fields.Add(Range:=Selection.Range, Type:=wdFieldEmpty, Text:=Field)
    NewField.Unlink
End Sub

Option Explicit
Option Base 1

Private Const MAX As Integer = 255  '記録できる最大量
Private RangeStack(MAX) As Range    '記録のための配列
Private seekNo As Integer           '直前にジャンプした記録番号
Private num As Integer              '記録数

'位置の記録。最終の記録番号の後に追加されます。
Public Sub RecordRangeStack()
    If num >= MAX Then              '記録数確認
        MsgBox "記録することが出来ません。", vbOKOnly, "記録容量オーバー"
    Else
        num = num + 1               '記録数の増加
        seekNo = 0                  'ジャンプ位置の初期化。次回、ジャンプするときは
                                    '直前に記録したところにジャンプします。
        Set RangeStack(num) = Selection.Range   '位置の記録
    End If
End Sub

'位置記録の消去。直前にジャンプした記録番号を消去し、
'番号をつめます。
Public Sub DeleteRangeStack()
    Dim i As Integer
    If num <= 0 Then                '記録の有無のチェック
        MsgBox "記録がありません。", vbOKOnly, "記録なし"
    Else
        If seekNo < num Then
            '直前にジャンプした番号に+1の番号に記録した位置をコピーします。
            'これを最後の記録-1まですることによって、記録が1つ減ることになります。
            For i = seekNo To num - 1
                Set RangeStack(i) = RangeStack(i + 1)
            Next i
        End If
        Set RangeStack(num) = Nothing   '最終記録位置の消去
        num = num - 1                   '記録数の減少
    End If
End Sub

'位置記録へのジャンプ。新しい記録から徐々に古い記録までジャンプします。
Public Sub SeekRangeStack()
    If num <= 0 Then                '記録の有無のチェック
        MsgBox "記録がありません。", vbOKOnly, "記録なし"
    Else
        seekNo = seekNo - 1         '一つ古い記録へ移動
        If seekNo < 1 Then seekNo = num '1より小さい(1番目へのジャンプの後)なら、
                                        '最新記録位置へ移動
        RangeStack(seekNo).Select       '記録位置の選択
    End If
End Sub

Sub CO2()
    Const Text As String = "CO2"
    Const Dummy As String = "e"
    Const LenDummy As Integer = 1
    Dim LenText As Long, r As Range
    LenText = Len(Text)
    Application.ScreenUpdating = False
    With Selection
        .TypeText Text & Dummy
        .MoveLeft wdCharacter, LenText + LenDummy, wdExtend
        ActiveDocument.Range(.Start, .End - LenDummy).Font.Reset '元の書式を生かす場合は不要
        .Characters(3).Font.Subscript = True
        .Collapse wdCollapseEnd
        .TypeBackspace
    End With
    Application.ScreenUpdating = True
End Sub

Sub ColorCheck()
    Dim bgc As Word.WdColorIndex
    Application.ScreenUpdating = False
    Selection.Collapse wdCollapseStart
    Do While Selection.Range.HighlightColorIndex = wdNoHighlight
        Selection.MoveRight wdCharacter, 1, wdMove
    Loop
    Application.ScreenUpdating = True
End Sub

Sub ColorCheck2()
    Dim check As Boolean, col As WdColorIndex
    Application.ScreenUpdating = False
    Selection.Collapse wdCollapseStart
    Selection.MoveRight wdCharacter, 1, wdExtend
    col = Selection.Range.HighlightColorIndex
    If col <> wdNoHighlight Then            '既に色がついている部分ならとばす。
        Selection.EndKey wdStory, wdExtend
        SubColorCheck Selection.Range, col
    End If
    Selection.EndKey wdStory, wdExtend
    check = SubColorCheck(Selection.Range)
    Selection.Collapse wdCollapseStart
    Application.ScreenUpdating = True
    If check = False Then MsgBox "見つかりませんでした。"   '見つからなかったときの処理
End Sub

Private Function SubColorCheck(r As Range, Optional DefaultColor As WdColorIndex = wdNoHighlight) As Boolean
    Const MultipleColor As Long = 9999999
    Dim Center As Long
    Dim col As WdColorIndex
    col = r.HighlightColorIndex
    If col = MultipleColor Then     '色付き/無しの部分を両方含む場合
        With r
            Center = Round((.Start + .End) / 2) '範囲を2つに分けてさらに検索を実施
            If SubColorCheck(ActiveDocument.Range(.Start, Center), DefaultColor) Then
                SubColorCheck = True    '前半にあった場合
            Else    '前半になかった場合は後半についても処理を行う。
                SubColorCheck = SubColorCheck(ActiveDocument.Range(Center, .End), DefaultColor)
            End If
        End With
    Else
        If col = DefaultColor Then  '色無し(指定色)の部分のみ含む場合
            SubColorCheck = False
        Else                        '色付き(指定色以外)の部分のみ含む場合
            r.Select
            SubColorCheck = True    '見つかったので、全ての処理が終了される。
        End If
    End If
End Function

Sub ColorCheck3()
    With Selection.Find
        .ClearFormatting
        .Highlight = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = True
    End With
    Selection.Find.Execute
End Sub

Function LineCount() As Long
    Const MaxLong As Long = 2147483647
    Dim now As Range
    Dim l As Long
    Set now = Selection.Range
    Application.ScreenUpdating = False
    ActiveDocument.Range(0, 0).Select
    l = Selection.MoveDown(wdLine, MaxLong, wdMove)
    now.Select
    Application.ScreenUpdating = True
    LineCount = l + 1
End Function

Sub 行数()
    MsgBox LineCount & " 行です。"
End Sub

Sub MergeFile(Optional dummy As Integer = 0)
    Dim d As Document, nDoc As Document
    Dim s As Range
    Set nDoc = Documents.Add
    For Each d In Documents
        If Not d Is nDoc Then
            Set s = nDoc.Content
            s.Collapse Direction:=wdCollapseEnd
            s.InsertBreak wdSectionBreakNextPage
            d.Range.Copy
            Set s = nDoc.Content
            s.Collapse Direction:=wdCollapseEnd
            s.Paste
        End If
    Next d
    Selection.Delete
End Sub