図面の説明を全自動で書き込むWORDマクロ

(´・ω・`今回は特許の話……というか専門的なとこなので知らない人は無視してください。
前に図面の説明を全自動で書き込むマクロを作ったのであげておきます。
使いたい人はWORDのマクロに直接書き込んでください。たぶん使えます……使えなかったらごめーんね。

(´・ω・`)⊃使い方は以下の通りです。
明細書内の”図1は~” ”図2は~” と書かれている部分を自動的に抽出して図面の説明にしてくれます。図1に示すように~は抽出しません。つまり図○はって語句を抽出してます。図1~4とかいてもOKです。連続して抽出します。


Sub 図説マクロ()
'If Flg_Conv = 1 Then
' MsgBox " OK", , Msg_Title
'Else
' MsgBox "見あたりません。", , Msg_Title
'End If
' 図説マクロ Macro
' myRange.InsertAfter Text:="【図面の簡単な説明】" + StrConv(kopy, vbWide)


Dim AddStr
Dim kopy
Dim Flg_Conv
Dim i
Dim j
Dim stopj
Dim strA
Dim strA2
Dim save_strA2
Dim stopstr
Dim copy As String
Dim precopy As String
Dim jamp
Dim kuri
Dim kaisu
Dim jamp2
stopj = 120
jamp = 0
jamp2 = 0
strA = 1
strA2 = 1
save_strA2 = 1
stopstr = 200
kopy = "1"
Flg_Conv = 0
kuri = 0
' "図1は"を検索
Do While strA <= stopstr
Set myRange = ActiveDocument.Range()
With myRange.Find
.ClearFormatting
.Text = "図" + StrConv(strA, vbWide) + "は"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
If .Execute = True Then
jamp = 1
' 番号が無いなら終わり用
Else
jamp2 = 1

End If
End With
' "図1~"を検索

With myRange.Find
.ClearFormatting
.Text = "図" + StrConv(strA, vbWide) + "~"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
If .Execute = True Then
jamp = 2
Else
If jamp2 = 1 Then
strA = stopstr
End If
End If
End With


' "図1~i"を検索
If jamp = 2 Then

i = 1
strA2 = strA
Do While i < 10

With myRange.Find
.ClearFormatting
.Text = "図" + StrConv(strA, vbWide) + "~" + StrConv(strA2, vbWide)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
If .Execute = True Then
' MsgBox StrConv(strA, vbWide), , Msg_Title
' MsgBox StrConv(strA2, vbWide), , Msg_Title
jamp = 1
kuri = 1
save_strA2 = strA2
End If
End With
strA2 = strA2 + 1
i = i + 1
Loop
End If





' "【図面の簡単な説明"を検索し、前に図の説明を追加

If jamp = 1 Then

j = 1
Do While j <= stopj
myRange.MoveEnd unit:=wdCharacter, Count:=1
'”。”が含まれていないか
If InStr(myRange.Text, "。") > 0 Then
jamp = 1
j = stopj
End If
j = j + 1
Loop

' myRange.Text = Replace(myRange.Text, vbVerticalTab, "")
copy = myRange.Text
' 1回目の検索
If strA = 1 Then
With myRange.Find
.ClearFormatting
.Text = "【図面の簡単な説明】"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
.Execute
End With

' 図iの場合
If kuri = 0 Then

myRange.InsertAfter Text:=vbNewLine + "   【0000】"
myRange.InsertAfter Text:=vbNewLine + "  【図" + StrConv(strA, vbWide) + "】" + copy
precopy = "  【図" + StrConv(strA, vbWide) + "】" + copy
End If
' 図i~jの場合
If kuri = 1 Then

For kaisu = 1 To save_strA2 - strA + 1
myRange.InsertAfter Text:=vbNewLine + "  【図" + StrConv(strA + kaisu - 1, vbWide) + "】" + copy
precopy = "  【図" + StrConv(strA + kaisu - 1, vbWide) + "】" + copy
Next kaisu
strA = save_strA2
' MsgBox StrConv(strA, vbWide), , Msg_Title

End If


' 2回目以降の検索
Else

With myRange.Find
.ClearFormatting
.Text = precopy
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
.Execute
End With
' 図iの場合
If kuri = 0 Then
myRange.InsertAfter Text:=vbNewLine + "  【図" + StrConv(strA, vbWide) + "】" + copy
precopy = "  【図" + StrConv(strA, vbWide) + "】" + copy
End If

' 図i~jの場合
If kuri = 1 Then

For kaisu = 1 To save_strA2 - strA + 1
myRange.InsertAfter Text:=vbNewLine + "  【図" + StrConv(strA + kaisu - 1, vbWide) + "】" + copy
precopy = "  【図" + StrConv(strA + kaisu - 1, vbWide) + "】" + copy
Next kaisu
strA = save_strA2
' MsgBox StrConv(strA, vbWide), , Msg_Title

End If
End If
End If
' 初期化
jamp = 0
jamp2 = 0
kuri = 0
strA = strA + 1
Loop

'清書

For strA = 1 To stopstr
'"【図" + StrConv(strA, vbWide) + "】図"で検索
With myRange.Find
.ClearFormatting
.Text = "【図" + StrConv(strA, vbWide) + "】図"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
If .Execute = True Then

With .Parent
Flg_Conv = 1
j = 1
Do While j <= stopj
myRange.MoveEnd unit:=wdCharacter, Count:=1
'”は”が含まれていないか
If InStr(myRange.Text, "は") > 0 Then
jamp = 1
j = stopj
End If
j = j + 1
Loop


.Delete
AddStr = "【図" + StrConv(strA, vbWide) + "】 "
.Font.Reset
.InsertAfter (AddStr)
.Move
End With

Else
jamp2 = 1
End If

End With
'" 、”を入れる人用の清書
With myRange.Find
.ClearFormatting
.Text = "【図" + StrConv(strA, vbWide) + "】 、"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
If .Execute = True Then

With .Parent
Flg_Conv = 1
.Delete
AddStr = "【図" + StrConv(strA, vbWide) + "】 "
.Font.Reset
.InsertAfter (AddStr)
.Move
End With

Else
If jamp2 = 1 Then
strA = stopstr
End If
End If
End With
'初期化
jamp2 = 0
Next strA

End Sub
にほんブログ村 株ブログへ にほんブログ村 株ブログ タイ株へ

株×ブログ!銘柄NAVI
プロフィール

弓原宗介

Author:弓原宗介
(´・ω・`)株と作成しているゲームアプリについての話題をとりとめもなく掲載しております。
連絡先:メール muhoo01a@gmail.com

ブログ村
カテゴリ
月別アーカイブ
リンク
スポンサードリンク
検索フォーム
RSSリンクの表示