【Word VBA】「図面の簡単な説明」の自動作成Wordマクロ

2011年2月12日

,

ひさしぶりに、また特許関連のマクロです。

この種のマクロはかなり需要があって、いろいろな方々が作られていると思います。

今回紹介するのは、泥臭く処理をするマクロです。

工夫すればもう少し短くなると思いますが、ひとまず動いているのでこれでよしとします。

まだRangeオブジェクトを覚える前に、Selectionオブジェクトを用いて作成したものをベースにして、最近kinuasa さんから教えていただいたカーソル位置の記憶をRangeオブジェクトで実行しています。

また、ワイルドカード検索 も実施していますので、参考にしてみてください。

当時、自分の覚え書き用に、コメント文をたくさんいれました。

比較的わかりやすいマクロだと思います。
どうぞご利用ください。

こういうものを、勉強会で題材にしたら、いろいろな実現方法がでてきそうで面白いでしょうね。

用途

特許明細書を作成しているときに、【図面の簡単な説明】の記述を、明細書中有の説明文から自動で作成します。

サンプル文は、ネットにある特許明細書からコピーしてお試しください。
たとえば、フェイスマスク 。

使い方

特許明細書を表示した状態で、このマクロを実行します。

マクロ実行時のカーソル位置はどこにあってもかまいません。
実行後に、現在のカーソル位置に自動的に戻るような設定になっています。

また、取り出される図面の説明は、かならずしも図面番号の順番になっているわけでもありませんし、重複して取り出される可能性もあります。

あくまでも、「図●●は、～。」という文章を文書の頭から順番に探してそれを見つけた順番に表示しているだけです。

また、「図１はパソコン専用モニターの外観図です。」のように「図１は」の後に読点が書かれていない場合も検索できませんのでご了承ください。

これについては、別の記事でご説明します。

プログラムの解説

表示してあるWord文書の特許明細書に記載されている「図●●は、～です。」の文章を自動で検出して、その内容を記憶します。

すべて記録したのち、【図面の簡単な説明】の次の行の【段落番号】の後に記憶した図の説明をすべて書き出します。

記憶する数は、１００としてあります。図１（ａ）、図１（ｂ）は２つと数えられますから、必要に応じて数を修正してみてください。

プログラム

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
Sub Patent_Drawings()
 
　Dim i As Integer　　　 '図面の説明文の数
　Dim n As Integer　　　 '数を数える変数
　Dim SE As Long　　　　 '選択文字列の末尾の位置
　Dim myFIG_Num(1 To 100) As String　'図の番号
　Dim myBody(1 To 100) As String　　 '図の説明
　Dim myRange As Range　 'カーソルの位置を記憶するオブジェクト
　
　On Error GoTo ErrorHandler
　
　'初期設定
　Set myRange = Selection.Range
　i = 0
　
　'画面更新オフ
　Application.ScreenUpdating = False
　
　'移動_文頭
　Selection.HomeKey Unit:=wdStory
　
　'検索（ワイルドカード検索）
　Selection.Find.ClearFormatting
　Selection.Find.Replacement.ClearFormatting
　With Selection.Find
　　　.Text = "図[0-9a-zA-Z\(\)０-９ａ-ｚＡ-Ｚ）（]{1,}は、"
　　　.Forward = True
　　　.Wrap = wdFindStop
　　　.Format = False
　　　.MatchCase = False
　　　.MatchWholeWord = False
　　　.MatchByte = False
　　　.MatchAllWordForms = False
　　　.MatchSoundsLike = False
　　　.MatchFuzzy = False
　　　.MatchWildcards = True
　End With
　
　Selection.Find.Execute
　
　Do While Selection.Find.Found = True
　
　　　i = i + 1
　　　SE = Selection.End
　　
　　　'「図●●」の選択
　　　Selection.End = Selection.End - 2
　　　myFIG_Num(i) = Selection.Text
　　
　　　'「図●●」の説明文の選択
　　　Selection.Expand Unit:=wdSentence
　　　Selection.Start = SE
　　　myBody(i) = Selection.Text
　　
　　　'選択解除
　　　Selection.Collapse Direction:=wdCollapseEnd
　　
　　　'検索実行
　　　Selection.Find.Execute
　
　Loop
　
　'移動_文頭
　Selection.HomeKey Unit:=wdStory
　
　'検索（あいまい検索）
　Selection.Find.ClearFormatting
　Selection.Find.Replacement.ClearFormatting
　With Selection.Find
　　　.Text = "【図面の簡単な説明】*【[０-９]{4}】"
　　　.Forward = True
　　　.Wrap = wdFindStop
　　　.Format = False
　　　.MatchCase = False
　　　.MatchWholeWord = False
　　　.MatchByte = False
　　　.MatchAllWordForms = False
　　　.MatchSoundsLike = False
　　　.MatchFuzzy = False
　　　.MatchWildcards = True
　End With
　
　Selection.Find.Execute
　
　'見つかったとき
　If Selection.Find.Found = True Then
　　　'選択解除
　　　Selection.Collapse Direction:=wdCollapseEnd
　　　Selection.Font.ColorIndex = wdRed
　　
　　　For n = 1 To i
　　　　　'改行
　　　　　Selection.TypeParagraph
　　　　　'文字入力
　　　　　Selection.TypeText Text:="　　【" & myFIG_Num(n) & "】" & myBody(n)
　　　Next
　　
　'見つからなかったとき
　Else
　　　MsgBox "【図面の簡単な説明】が見つかりません。"
　End If
　
　'検索条件をあいまい検索に変更
　With Selection.Find
　　　.ClearFormatting
　　　.Replacement.ClearFormatting
　　　.Text = ""
　　　.Replacement.Text = ""
　　　.MatchWildcards = False
　　　.MatchFuzzy = True
　End With
　
　'カーソル位置を元の場所に戻す
　myRange.Select
　
　'Rangeオブジェクトの解除
　Set myRange = Nothing
　
　'画面更新オン
　Application.ScreenUpdating = True
　
　On Error GoTo 0
　Exit Sub
　
ErrorHandler:
　　　　　MsgBox "エラーが発生したので終了します。"
　　　　　End
 
End Sub

関連記事

誰も教えてくれなかった Word効率アップ術 （ワイルドカードに関する書籍）

-コード
-,

S