【Word VBA/マクロ】よく使用するコード、便利コード

簡単なコードが意外と出て来ないので、よく使用するコードをまとめておきます。
段落、図、表、ヘッダーフッター構文はこちら
検索の基本構文はこちら

Sub 文書の先頭に移動()
    ActiveDocument.Range(0, 0).Select
End Sub

Sub 文書の最後に移動()
    ActiveDocument.Bookmarks("\EndOfDoc").Select
End Sub

Sub 文頭まで選択拡張()
'本文にカーソルがある時は文書の最初まで選択範囲が拡張
    Selection.StartOf wdStory, wdExtend
End Sub

Sub 文末まで選択拡張
'本文にカーソルがある時は文書の末尾まで選択範囲が拡張
    Selection.EndKey wdStory, wdExtend
End Sub

Sub 文頭に移動()
'本文にカーソルがある時は文書の最初まで移動
    Selection.StartOf wdStory, wdMove
End Sub

Sub 文末に移動()
'本文にカーソルがある時は文書の最後に移動
    Selection.EndKey Unit:=wdStory
End Sub

Sub 文末に移動2()
'本文にカーソルがあるときは文書の最後に移動
    With Selection
        .MoveEnd wdStory
        .Collapse wdCollapseEnd
    End With
End Sub

Sub 段落全体選択()
    With Selection
        .SetRange .Paragraphs(1).Range.Start, _
            .Paragraphs.Last.Range.End
    End With
End Sub

Sub 段落全体選択2()
'カーソルの段落を最初から最後まで選択
    With Selection
        .StartOf wdParagraph, wdExtend
        .EndOf wdParagraph, wdExtend
    End With
End Sub

Sub 最終段落削除()
    ActiveDocument.Paragraphs.Last.Range.Delete
End Sub

Sub 範囲を右にずらす()
    Dim rng As Range
'…省略…
    rng.MoveStart wdCharacter, 1
'…省略…
End Sub

Sub 段落末にカーソルを移動()
    With Selection
        .MoveEnd Unit:=wdParagraph
        .MoveEnd Unit:=wdCharacter, Count:=-1
        .Collapse wdCollapseEnd
    End With
End Sub

Sub 段落末にカーソルを移動2()
    With Selection
        .MoveEndUntil vbCr
        .Collapse wdCollapseEnd
    End With
End Sub

Sub アクティブページを選択()
    ActiveDocument.Bookmarks("\Page").Select
End Sub

Sub 最初の段落を取得() 
    Dim rngParagraph As Range
    Set rngParagraph = ActiveDocument.Paragraphs(1).Range
End Sub

Sub カーソル位置から段落記号の前まで選択()
  With Selection.Range
     .MoveEndUntil vbCr
    .Select
  End With
End Sub

Sub 本文全てコピー()
    ActiveDocument.Content.Copy
End Sub

Sub 指定した文字列の総バイト数取得()
    Debug.Print LenB(StrConv(文字列, vbFromUnicode))
End Sub

Sub 文頭の場合()
    Dim rng As Range
    '…省略…    
    '検索結果が文頭の場合などに使用
    If rng.Start = ActiveDocument.Range.Start Then
　　'…省略…    
    End If
End Sub

Sub 文末の場合()
    Dim rng As Range, para As Paragraph
    '…省略…    
    If rng .End = ActiveDocument.Range.End Then
　'…省略…    
    End If
End Sub

Sub 最終段落を取得()
    Dim par As Paragraph
    Set par = ActiveDocument.Paragraphs.Last    
End Sub

Sub 選択段落の文字を表示()
    Dim par As Paragraph    
    For Each par In Selection.Paragraphs
        MsgBox par.Range.Text
    Next
End Sub

Sub Rangeオブジェクト作成_文書先頭～10文字()
 　Dim rngDoc As Range
 　Set rngDoc = ActiveDocument.Range(Start:=0, End:=10)
End Sub

Sub Rangeオブジェクトの再定義()
'選択範囲をRangeオブジェクトに定義した後、
'SetRange メソッドを使用して、10文字分拡張した範囲を
'Rangeオブジェクトに再定義します。
    Dim rng As Range
    Set rng = Selection.Range    
    rng.SetRange Start:=rng.Start, _
    End:=rng.End + 10
End Sub

Sub Rangeオブジェクト作成_2つめの段落先頭～3つめの段落最後まで()
    Dim doc As Document
    Dim rngDoc As Range
    Set doc = ActiveDocument
    Set rngDoc = doc.Range(Start:=doc.Paragraphs(2). _
    Range.Start, End:=doc.Paragraphs(3).Range.End)
End Sub

Sub 表のデータを配列に格納()
    Dim r_cnt As Long, c_cnt As Long
    Dim tbl As Table
    Dim arr() As String
    Dim r As Long, c As Long
    On Error Resume Next
    If Selection.Information(wdWithInTable) = False Then
        MsgBox "表にカーソルを置いて実行してください"
        Exit Sub
    End If
    
    Set tbl = Selection.Tables(1)
    r_cnt = tbl.Rows.Count
    c_cnt = tbl.Columns.Count

    ReDim arr(1 To r_cnt, 1 To c_cnt) As String

    For r = 1 To r_cnt
        For c = 1 To c_cnt
            Dim txt As String
            txt = tbl.Cell(r, c).Range.Text
            arr(r, c) = Left(txt, Len(txt) - 2)
        Next c
    Next
End Sub

Sub Excel操作()
'VBAのGetObject関数を使って、起動済みExcelの
'Applicationオブジェクトへの参照を取得します。
Dim exApp As Excel.Application
On Error GoTo ErrHandl
    Set exApp = GetObject(Class:="Excel.Application")
Exit Sub
ErrHandl:
    Select Case Err.Number
        Case 429
            MsgBox "Excelが起動していないようです"
        Case 4248
            MsgBox "Excelファイルが開かれていないようです"
        Case Else
            MsgBox Err.Description & vbCrLf & Err.Number
    End Select
End Sub

検索、段落、表、図、ヘッダーフッターの基本構文は、次の2つの記事へ移動しました。
rapoppo.hatenadiary.jp

rapoppo.hatenadiary.jp

【Word VBA/マクロ】使用スタイルのリスト表示

サンプルコードでできること

使用しているスタイルの一覧を取得して、メッセージボックスに表示します。

Sub getStyleList_Activedocument()
    Dim strList As String
    strList = getStyleList(ActiveDocument)
    MsgBox strList
End Sub

Private Function getStyleList(dc As Document) As String
'使用した段落スタイルの一覧を取得します。
    Dim para As Paragraph, styleList As String
    Dim stl As Variant
    Dim dic As Scripting.Dictionary
    Set dic = New Scripting.Dictionary

    For Each para In dc.Paragraphs
        If dic.Exists(para.Style.NameLocal) = False Then
            dic.Add para.Style.NameLocal, ""
        End If
    Next
    
    For Each stl In dic.Keys
        styleList = styleList & stl & vbCrLf
    Next
    getStyleList = styleList
End Function

コードの説明

Wordではスタイルウインドウに「使用中のスタイル」を表示できます。
そのリストを取得するコードでいいと思ったのですが、「見出し 1」など使用されていないスタイルも含まれるようです。

段落ごとにスタイル名を取得していく無難な方法にしました。
For Eachを用いたリスト化は簡単ですが、スタイル名が重複します。
そのためDictionaryオブジェクトでスタイル名が登録されていないかチェック（dic.Exists(para.Style.NameLocal）しています。

【Word VBA/マクロ】段落書式コピー

サンプルコードでできること

選択した段落の書式を、前の段落に合わせます。

Ctrl+Shift+Cキーで段落書式コピーできますが、前の段落に移動してコピー、戻って貼り付けが意外と面倒です。
マクロをボタン化すると、ショートカットより楽です。

Sub CopyPrePaaraFormat()
    Dim preParFmt As ParagraphFormat
    Set preParFmt = _
        Selection.Paragraphs(1).Previous.Range.ParagraphFormat
    Selection.ParagraphFormat = preParFmt
End Sub

【Word VBA/マクロ】Word マクロで全角文字をさがす方法

全角チェックするとき、文字カウント機能を使用します。
全角の文字数が分かって便利ですが、全角の場所は教えてくれません。
そこで全角文字をハイライトするマクロを作り始めたのですが、何度修正しても完成しませんでした。
検索（Range.find…）だけではチェック漏れがあるため、見つかった文字を、1字ずつ全角判定が必要です。その判定方法を考えるのに苦労しました。

全角は2バイト、半角は1バイトという認識でしたが、下の画面の「±」など、半角に見える記号のバイト数をLenB(StrConv(Selection.Text, vbFromUnicode))で確認すると2バイトです。

文字カウントでは「全角文字+半角カタカナの数」は0。全角文字でないと判定されます。
半角（に見える）記号が2バイトのため、バイト数で全角判定はできません。「°」も同様です。「±」や「°」は、全角と半角の文字コードが同じです。
同じコードなら同じ文字なのか、文字カウントで全角判定の結果が違うので別の文字なのか、理解できません。

次の画像のMS明朝の「±」は全角に見えます（比較するためTimes New Romanの記号を表示しました）。この記号は、キーボードで入力後、半角変換していますが、見た目は全角と変化ありません。全角に見えても、言語は「英語（米国）」、文字カウントは全角文字数「0」です。

半角なのか疑わしいですが、言語設定が英語の場合、全角なしと判定されるようです。

言語設定と文字カウントの全角判定の結果は一致するため、「言語」による全角判定が可能です。通常は半角は「英語（米）」と表示されます。英語の言語設定は10種類以上あるため（次の図は英語の一部です）、言語確認は必要ですが、半角は「英語（米）」に自動的に設定されるようです。

私は英語以外の文書も扱うため、言語判定はやめました（他人を作成した文書を扱うため、言語が決まっていません）。
最終的には、原点に戻って、文字カウントで判定することにしました。
文字カウントを1字ずつチェックする発想がなく、今ごろ簡単な方法に気づきました。
検索で見つかった文字を、文字数カウントの「全角文字+半角カタカナの数」を取得するComputeStatistics(wdStatisticFarEastCharacters) を用いて、全角チェックするという方法です。

検索なしで、すべての文字をチェックする方法はコードがシンプルですが、時間はかかります。コードを載せますが、Findと組み合わせたほうが、時間は短縮できます。

Sub SetHighlightFullwidthChara()
    Dim rng As Range

    For Each rng In ActiveDocument.Characters
        With rng
            If rng = "　" Then
                .HighlightColorIndex = wdBrightGreen
            ElseIf .ComputeStatistics(wdStatisticFarEastCharacters) > 0 Then
                .HighlightColorIndex = wdYellow
            End If
        End With
    Next
End Sub

【Word VBA/マクロ】選択図形のアンカーロック/ロック解除（複数の図に対応）

サンプルコードでできること

選択した図のアンカーをロック（ロック解除）します。

Sub LockAnchorAllShpe()
’アンカーをロックします。
    Dim sp As Shape
    
    For Each sp In Selection.ShapeRange
        Selection.ShapeRange.LockAnchor = True
    Next
End Sub

Sub LockAnchorCancellAllShpe()
’アンカーをロック解除します。
    Dim sp As Shape
    
    For Each sp In Selection.ShapeRange
        Selection.ShapeRange.LockAnchor = False
    Next
End Sub

【Word VBA/マクロ】フォルダ内の全てのWordファイルにドキュメントプロパティの作成者名を設定

サンプルコードでできること

フォルダ内のWordファイルのドキュメントプロパティの作成者名をセットします。

Sub setDocumentProperty_Author_Folder()
    Dim Path As String, strName As String
    Dim fs As Scripting.FileSystemObject
    Dim baseFolder As Scripting.Folder
    Dim mySubFile As Scripting.File, mySubFiles As Scripting.FILES
    Dim dc As Document, hidFile As Boolean
    Dim dlg As FileDialog
    
    strName = "○○" '作成者名を代入
    
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' キャンセルボタンクリック時にマクロを終了
    If dlg.Show = False Then Exit Sub
    ' フォルダーのフルパスを変数に格納
    Path = dlg.SelectedItems(1)
    
    Set fs = New Scripting.FileSystemObject
    Set baseFolder = fs.GetFolder(Path)
    Set mySubFiles = baseFolder.FILES
    
    For Each mySubFile In mySubFiles
        hidFile = False
        '隠しファイルの判定
        If mySubFile.Attributes = 2 Or _
            mySubFile.Attributes = 34 Then
            hidFile = True
        End If
        
        If hidFile = False Then
            If fs.GetExtensionName(mySubFile.Path) = "doc" Or _
                fs.GetExtensionName(mySubFile.Path) = "docx" Then
                Documents.Open mySubFile.Path
                Set dc = ActiveDocument
                With dc
                    .BuiltInDocumentProperties("Author") = strName
                    .Close SaveChanges:=True
                End With
            End If
        End If
    Next
End Sub

【Word VBA/マクロ】指定フォルダ内のファイルからドキュメントプロパティのデータを抽出

サンプルコードでできること

フォルダ内のWordファイルから、ドキュメントプロパティのタイトル・サブタイトル・作成者を新規文書に書き出します。

Sub getDocumentPropertyList_AuthorTitleSubject_Folder()
    Dim Path As String, pgInfo As String
    Dim fs As Scripting.FileSystemObject
    Dim baseFolder As Scripting.Folder
    Dim mySubFile As Scripting.File, mySubFiles As Scripting.FILES
    Dim dc As Document, dcNew As Document
    Dim hidFile As Boolean, para As Paragraph
    Dim dlg As FileDialog, b As Boolean, bLevelList As String
    
    b = False
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' キャンセルボタンクリック時にマクロを終了
    If dlg.Show = False Then Exit Sub
    ' フォルダーのフルパスを変数に格納
    Path = dlg.SelectedItems(1)
    
    Set fs = New Scripting.FileSystemObject
    Set baseFolder = fs.GetFolder(Path)
    Set mySubFiles = baseFolder.FILES
    
    For Each mySubFile In mySubFiles
        hidFile = False
        '隠しファイルの判定
        If mySubFile.Attributes = 2 Or _
            mySubFile.Attributes = 34 Then
            hidFile = True
        End If
        
        If hidFile = False Then 
            If fs.GetExtensionName(mySubFile.Path) = "doc" Or _
                fs.GetExtensionName(mySubFile.Path) = "docx" Then
                Documents.Open mySubFile.Path, ReadOnly:=True
                Set dc = ActiveDocument
                If b = False Then
                    Set dcNew = Documents.Add 
                    b = True
                End If
                'ドキュメントプロパティの内容挿入
                getDocumentProperty_AuthorTitleSubject dc, dcNew
                dc.Close SaveChanges:=False
            End If
        End If
    Next
    
dcNew.Range(0, 0).Select
End Sub

Private Sub getDocProperty_AuthorTitle(docFrom As Document, docTo As Document)
    Dim docProp As DocumentProperty
    Dim dcPpText As String
    On Error Resume Next
    docTo.Range.Bookmarks("\EndOfDoc").Select
        With Selection
            .InsertAfter docFrom.Name & vbCrLf 'ファイル名挿入
            .Range.Font.Bold = True
            .EndKey wdStory
            .InsertAfter "Title: " & _
                docFrom.BuiltInDocumentProperties("Title").Value & vbCrLf
            .InsertAfter "Subject: " & _
                docFrom.BuiltInDocumentProperties("Subject").Value & vbCrLf
            .InsertAfter "Author: " & _
                docFrom.BuiltInDocumentProperties("Author").Value & vbCrLf
            .InsertAfter vbCr
        End With
End Sub

【Word VBA/マクロ】ドキュメントプロパティの全項目を取得

サンプルコードでできること

ドキュメントプロパティの全ての項目を新規文書に書き出します。

Sub ドキュメントプロパティ取得()
    Dim docTo As Document, docProp As DocumentProperty

    Set docTo = Documents.Add '書き出し用のファイル

    On Error Resume Next
        For Each docProp In ActiveDocument.BuiltInDocumentProperties
            Selection.InsertAfter docProp.Name & ": " & _
            docProp.Value & vbCrLf
        Next
    Selection.StartOf wdStory, wdMove ’文書先頭へ移動
End Sub

コードの説明

ActiveDocument.BuiltInDocumentPropertiesで、DocumentPropertiesオブジェクトを取得。
For Eachでタイトル、作成者など、DocumentPropertyオブジェクトの値を取得して、新規文書に書き出します。