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

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

最近の翻訳案件で、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

トップへ戻る