【Word VBA】コメントを書き出すWordマクロ（その３） 特許明細書仕様

2018年1月16日

, , , , ,

かつて紹介した「【コード】コメントを書き出すWordマクロ（その３） ページ番号付き 」を特許明細書用に改良しました。

最近の翻訳案件で、Word文書に挿入したコメントを別紙に書き出す際、特許用の段落番号（括弧で囲まれた4桁の数字）が表示されると便利だと感じました。

上書き翻訳ツールを使って翻訳をする場合、バイリンガルファイルにコメントを挿入しながら翻訳を進めます。

このときに挿入したコメントを書き出す際に挿入されるページ番号や行番号は、バイリンガルファイルのものとなります。

したがって原文や訳文のページ番号・行番号とは異なるため、クライアントに提出する際に意味を成しません。

そこで、今回のマクロでは、コメントを挿入した箇所の段落番号や見出しを一覧表に表示するようにしました。

今後、関連するアドイン（上書き翻訳ツール、ベリーベンリなマクロ集など）に本機能を追加していきます。

最近紹介した「【コード】カーソルがある箇所の特許段落番号を取得するWordマクロ 」でも同じ考え方のコードを使っています。

このマクロでできること

特許明細書中にコメントがある場合、コメントが挿入されている段落番号や見出しを書き出します。上書き翻訳ツールでバイリンガルファイルになっている場合にも同様に使えます。

実行前

実行後

マクロの解説

上記の表のとおり、5列目に段落番号を挿入します。

42行目で、GetHeading のファンクションを呼び出して段落番号を取得します。

これ以外は、これまで紹介したマクロと同じです。

マクロ


Sub コメント書出し_特許()

　Dim i As Integer
　Dim actDoc As Document
　Dim newDoc As Document
　Dim myTable As Table

　If ActiveDocument.Comments.Count = 0 Then
　　MsgBox "このファイルにはコメントがありません。終了します。", vbInformation, "お知らせ"
　　Exit Sub
　End If

　'オブジェクト変数の設定
　Set actDoc = ActiveDocument
　Set newDoc = Documents.Add
　Set myTable = newDoc.Tables.Add(Range:=Selection.Range, _
　　　　　　　NumRows:=actDoc.Comments.Count + 1, NumColumns:=5)

　'表の項目を追記
　With myTable
　　.Cell(1, 1).Range.Text = "P."
　　.Cell(1, 2).Range.Text = "行"
　　.Cell(1, 3).Range.Text = "対象部分"
　　.Cell(1, 4).Range.Text = "コメント"
　　.Cell(1, 5).Range.Text = "段落"
　　.Rows(1).Select
　　With Selection
　　　.ParagraphFormat.Alignment = wdAlignParagraphCenter
　　　.Collapse direction:=wdCollapseStart
　　End With
　End With
 
　'ページ番号とコメントを表に記入
　For i = 1 To actDoc.Comments.Count
　　With actDoc.Comments(i)
　　　myTable.Cell(i + 1, 1).Range.Text = .Scope.Information(wdActiveEndPageNumber)
　　　myTable.Cell(i + 1, 2).Range.Text = .Scope.Information(wdFirstCharacterLineNumber)
　　　myTable.Cell(i + 1, 3).Range.Text = .Scope.Text
　　　myTable.Cell(i + 1, 4).Range.Text = .Range.Text
　　　myTable.Cell(i + 1, 5).Range.Text = GetHeading(.Scope)
　　End With
　Next i
 
　'表のスタイルを設定
　With myTable
　　.Style = "表 (格子)"
　　.AutoFitBehavior (wdAutoFitContent)
　End With

　'オブジェクト変数の解放
　Set actDoc = Nothing
　Set newDoc = Nothing

End Sub

Function GetHeading(myRange As Range) As String

　Dim myPara As Paragraph
　Dim myParaRange As Range
　
　Set myPara = myRange.Paragraphs(1)
　
　Do
　　
　　If myPara Is Nothing Then
　　　myParaRange.SetRange 0, 0
　　　Exit Do
　　End If
　　
　　Set myParaRange = myPara.Range
　　
　　myParaRange.MoveStartWhile Cset:=vbTab & Chr(32) & Chr(-32448)

　　If myParaRange.Characters.First.Text Like "[【^[]" Then
　　　myParaRange.MoveEndUntil Cset:="】]", Count:=wdBackward
　　　Exit Do
　　Else
　　　Set myPara = myPara.Previous
　　End If
　
　Loop
　
　GetHeading = myParaRange.Text
　
　Set myPara = Nothing
　Set myParaRange = Nothing
　
End Function

-コード
-, , , , ,