その他のマクロ(Word用)

 

Wordメニューへのマクロボタン登録例です

 マクロの登録手順は ここ を参考にしてください。

1.選択した文字列を 青色太字のゴシック体にする
2.出願書類の項目抜けを検査する(新様式対応)
3.請求項番号の連続性を検査する
4.明細書中のすべての図番号を青色の太字ゴシックに一括変換する
5.アクティブの画面を左右の二画面表示にする(注:デュアルディスプレイ専用)

 1.選択した文字列を 青色太字のゴシック体にする

Sub 図番号太字()
'
'
図番号太字 Macro
'
作成日 03/09/07 作成者 岡田
'-----------------------------------------------------------
'
 選択した文字列を太字ゴシック体に変換する(図番号に適用)
'-----------------------------------------------------------
Dim myRange As Range
Set myRange = ActiveDocument.Range(Start:=Selection.Start, End:=Selection.End)
If Selection.Start <> Selection.End Then
With Selection.Font
.NameFarEast = "
MS ゴシック"
.Bold = True
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.ColorIndex = wdBlue
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 1.5
.Scaling = 100
.Position = 0
.Kerning = 1
.Animation = wdAnimationNone
.DisableCharacterSpaceGrid = False
.EmphasisMark = wdEmphasisMarkNone
'
選択を解除する
Selection.Collapse wdCollapseEnd
End With
End If
End Sub

 上に戻る

 2.出願書類の項目抜けを検査する(新様式対応)             

Sub 項目検査()
'
'
項目検査 Macro
'
記録日 03/09/07 記録者 岡田
'-------------------------------------------
'
出願書類の項目抜け等を検査する
'-------------------------------------------
Dim SerchWord(35) As String
Dim errSerchWord(35) As String
Dim MsgTitle As String
Dim errNumber As Integer
Dim myRange As Range
Dim i As Integer
Dim errFlg As Integer
Dim MsgBoxString As String
Dim myWildLengs As String
Dim myStringLengs As Integer
MsgTitle = "
おしらせ"
errNumber = 1
'---
願書の検査項目 ---------------------
SerchWord(0) = "
【書類名】 {1,}特許願"
SerchWord(1) = "
【整理番号】"
SerchWord(2) = "
【提出日】"
SerchWord(3) = "
【あて先】"
SerchWord(4) = "
【国際特許分類】"
SerchWord(5) = "
【発明者】"
SerchWord(6) = "
【特許出願人】"
SerchWord(7) = "
【代理人】"
SerchWord(8) = "
【手数料の表示】"
SerchWord(9) = "
【予納台帳番号】"
SerchWord(10) = "
【納付金額】"
SerchWord(11) = "
【提出物件の目録】"
SerchWord(12) = "
【物件名】 {1,}特許請求の範囲"
SerchWord(13) = "
【物件名】 {1,}明細書"
SerchWord(14) = "
【物件名】 {1,}図面"
SerchWord(15) = "
【物件名】 {1,}要約書"
SerchWord(16) = "
【包括委任状番号】"
'--
特許請求の範囲の検査項目--------------
SerchWord(17) = "
【書類名】 {1,}特許請求の範囲"
SerchWord(18) = "
【請求項1】"
'--
明細書の検査項目 --------------------
SerchWord(19) = "
【書類名】 {1,}明細書"
SerchWord(20) = "
【発明の名称】"
SerchWord(21) = "
【技術分野】"
SerchWord(22) = "
【背景技術】"
SerchWord(23) = "
【発明の開示】"
SerchWord(24) = "
【発明が解決しようとする課題】"
SerchWord(25) = "
【課題を解決するための手段】"
SerchWord(26) = "
【発明の効果】"
SerchWord(27) = "
【発明を実施するための最良の形態】"
SerchWord(28) = "
【図面の簡単な説明】"
SerchWord(29) = "
【符号の説明】"
'--
図面/要約書の検査項目 -------------
SerchWord(30) = "
【書類名】 {1,}図面"
SerchWord(31) = "
【書類名】 {1,}要約書"
SerchWord(32) = "
【要約】"
SerchWord(33) = "
【課題】"
SerchWord(34) = "
【解決手段】"
SerchWord(35) = "
【選択図】"
imax = 35
'------------------------------------
Set myRange = ActiveDocument.Range()
For i = 0 To imax
With myRange.Find
.ClearFormatting
.Text = SerchWord(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
.MatchByte = False
.MatchFuzzy = False
If .Execute = False Then
errFlg = 1
errNumber = errNumber + 1
errSerchWord(i) = SerchWord(i)
End If
End With
Next
'------------------------------------
MsgBoxString = "
項目検査を完了しました。 "
If errFlg = 1 Then
MsgBoxString = MsgBoxString + "
以下の " + StrConv(errNumber - 1, vbNarrow) + " 個の項目が見あたらない又は項目の書き方が間違っています。" + vbCrLf
For i = 0 To imax
If errSerchWord(i) <> "" Then
myWildLengs = InStr(errSerchWord(i), "{1,}")
If myWildLengs <> 0 Then '
ワイルドカードがあれば
myStringLengs = Len(errSerchWord(i)) '
ワイルドカードまでの文字数を取得し
errSerchWord(i) = Left(errSerchWord(i), myWildLengs - 1) _
+ "
  " + Right(errSerchWord(i), myStringLengs - myWildLengs - 3) 'ワイドカードを削除した文字列を生成する
End If
If Len(MsgBoxString) < 480 Then
MsgBoxString = MsgBoxString + vbCrLf + "
            " + errSerchWord(i)
Else
MsgBoxString = MsgBoxString + vbCrLf + vbCrLf + "
                        " + "− 以下省略 −"
Exit For
End If
End If
Next
Else
MsgBoxString = MsgBoxString + "
異常はありません。"
End If
MsgBox MsgBoxString, , MsgTitle
End Sub

 {1,}はワイルドカード
 書式 △{n,}
     △:検索文字(上の例では全角スペース)
     n:検索文字の最低数

 上に戻る

 3.請求項番号の連続性を検査する               

'Sub 請求項検査()
'
'
請求項検査 Macro
'
作成日 03/09/09 作成者 岡田
'------------------------------------------------
'
請求項の番号が順番に振られているか調べます。
'------------------------------------------------
Dim myMsg As String
Dim hit As Integer
Dim oldVal As Integer
Dim keyword As String
Dim Seiku_Num As Integer
hit = 0
oldVal = 0
keyword = "
【請求項*"
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = keyword
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Do While Selection.Find.Execute = True
'
ヒットした数を加算
hit = hit + 1
'
請求項番号を太字にして色(ピンク)を付ける
' Selection.Font.Name = "
MS ゴシック"
' Selection.Font.Bold = True
' Selection.Font.ColorIndex = wdPink
'
請求項番号を抜き出して数値に変換
Seiku_Num = Val(Format(Mid(Selection.Text, 5, Len(Selection.Text) - 5), "#0"))
'---------
請求項番号の連続性を検査 -----------
If oldVal + 1 = Seiku_Num Then
oldVal = Seiku_Num
myMsg = "<<
正常 >> 請求項の番号が連続しています。 請求項の数は " & hit & " です。"
Else
myMsg = "<<
異常 >> 請求項の番号が連続していません。 確認してください。"
End If
'
選択を解除
Selection.Collapse wdCollapseEnd
Loop
MsgBox myMsg, , "
おしらせ"
End Sub

 上に戻る

 4.明細書中のすべての図番号を青色の太字ゴシックに一括変換する  説明

Sub 図番号フォント一括()
'
'
図番号フォント一括変換 Macro
'
作成日 03/09/09 作成者 岡田
'---------------------------------------------
'
明細書中のすべての図番号を検索し、太字ゴシックの
'
青色に一括変換する。
'---------------------------------------------
Dim tango As String
Dim hit As Integer
Dim myMsg As String
hit = 0
tango = "
[-]"
Start:
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = tango
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Do While Selection.Find.Execute = True
'
ヒットした数を加算
hit = hit + 1
'
ヒットした文字に色を付ける
Selection.Font.Name = "
MS ゴシック"
Selection.Font.Bold = True '
太字
Selection.Font.ColorIndex = wdBlue '
青色
'
検索文字列を確認
Loop
'
選択を解除
Selection.Collapse wdCollapseEnd
If tango = "
[-]" Then
tango = "
[-][-]"
GoTo Start
End If
myMsg = "
図番号が "
If hit = 0 Then
myMsg = myMsg & "
見つかりません。"
Else
myMsg = myMsg & hit & "
個見つかりました。 太字のゴシック体変換と色つけ(青)を完了しました。"
End If
MsgBox myMsg, , "
おしらせ"
End Sub

 上に戻る

 5.アクティブの画面を、左右の二画面表示にする(WUXGAモニター用)

Sub 二画面表示()
'
'
二画面表示 Macro
'
記録日 03/09/11 記録者 岡田
'-----------------------------------------------
'
画面を左右に表示する(デュアルディスプレイ専用)
'-----------------------------------------------
Dim L_window_W As Integer
Dim L_window_H As Integer
Dim R_window_W As Integer
Dim R_window_H As Integer
Dim myZoom As Integer
'*********
最大画面時は終了 ***********
On Error GoTo myEND
'*********
画面設定 ***********
'WindowsXP/Word2002 14inch Display Dual
'-----------------------------------
L_window_W = 720 '
左画面の横幅
L_window_H = 870 '
    高さ
R_window_W = 720 '
右画面の横幅
R_window_H = 870 '
    高さ
myZoom = 130 '
画面のズーム率
'****
すでに二画面表示なら中止 ****
If Mid(Windows(1).Caption, Len(Windows(1).Caption) - 1, 1) = ":" Then
MsgBox Left(Windows(1).Caption, Len(Windows(1).Caption) - 2) & "
は二画面になってます。", , "おしらせ"
GoTo myEND
End If
'**********
左画面 ************
With ActiveWindow
.Left = 0
.Top = 0
.Width = L_window_W
.Height = L_window_H
.View.Zoom.Percentage = myZoom
End With
'**********
右画面 ************
NewWindow
With ActiveWindow
.Left = L_window_W
.Top = 0
.Width = R_window_W
.Height = R_window_H
.View.Zoom.Percentage = myZoom
End With
'***
左画面をアクティブにする ***
Windows(Windows(1).Caption).Activate
myEND:
End Sub

1台のディスプレイ(1680×1050)に使用する場合のアレンジ
 横幅:630
 高さ:768

 上に戻る

− 明細書段落番号自動置換マクロへ −

 Minoru Okada

自作ソフト置き場に戻る

2003.9.2