【Word VBA】1行に収まるようフォントサイズを縮小するWordマクロ（その２）

2016年9月22日

, ,

この1ヶ月半ほど、イベントの手伝いをしていました。その中で、名札の作成に関わってまして、またまたマクロが活躍しました。

以前紹介した「【コード】1行に収まるようフォントサイズを縮小する」を応用して、差し込み印刷機能で作成した名札を自動で修正するマクロをつくってみました。

名札が数百枚もあるような場合に便利だと思います。

このマクロでできること

差し込み印刷機能を使うと、名前や会社名を自動的に名札に挿入できます。

そのときに、文字数が多すぎて複数行になってしまう箇所だけ、文字サイズを小さくしてその項目を1行に収めます。

文書中の「メイン文書」箇所のみ実行できます。

差し込み印刷の文書

差し込み印刷

結果の表示

差し込んだ結果をWord文書にします。

差し込み印刷

マクロ実行前

会社名が長いと改行されてしまいかっこわるい！会社名は特に注意が必要です。

差し込み印刷

マクロ実行後

1行に収まります。めでたしめでたし。

差し込み印刷

マクロの解説

文書中のすべての段落について処理をしたいので、For Each...Loopステートメントを使っています。

ステータスバーにプログレスバーを表示しています。

「【コード】1行に収まるようフォントサイズを縮小する」のコードを、今回実務で使ってみて使いづらいところがあったので少し修正しました。

マクロ

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
Sub 段落を1行に収めるマクロ2()
 
　Dim myPara As Paragraph
　Dim i As Long
　Dim iMax As Long
　Dim objUndoRec As UndoRecord
 
　'-------------------------------------------
　'Undoで一回で元に戻す設定(Word 2010以降対応）
　'-------------------------------------------
　Set objUndoRec = Application.UndoRecord
　objUndoRec.StartCustomRecord "段落を1行に収める"
 
　iMax = ActiveDocument.Paragraphs.Count
　i = 1
 
　For Each myPara In ActiveDocument.Paragraphs
　　Call Process(myPara.Range)
　　i = i + 1
　　Application.StatusBar = _
　　　　"処理中..." & _
　　　　String((CInt(i / iMax * 10)), "■") & _
　　　　String(10 - CInt(i / iMax * 10), "□")
　Next
 
　'-------------------------------------------
　'Undoで一回で元に戻す設定(Word 2010以降対応）
　'-------------------------------------------
　Application.ScreenRefresh
　DoEvents
　objUndoRec.EndCustomRecord
　Set objUndoRec = Nothing
 
　MsgBox "終了しました。"
 
End Sub
 
Private Sub Process(myRange As Range)
 
　Dim LineStart As Long '先頭の文字の行番号
　Dim LineEnd As Long　 '末尾の文字の行番号
 
　'段落末尾の改行記号を除外
　myRange.End = myRange.End - 1
 
　'ソフトリターンがあれば除外
　If InStr(1, myRange.Text, vbVerticalTab) > 0 Then
　　Exit Sub
　End If
 
　'行内配置図があれば除外
　If myRange.InlineShapes.Count > 0 Then
　　Exit Sub
　End If
 
　'文字がなければ除外
　If myRange.Start = myRange.End Then
　　Exit Sub
　　
　Else
 
　　'先頭文字の行番号を取得
　　LineStart = myRange.Information(wdFirstCharacterLineNumber)
 
　　'末尾文字の行番号を取得
　　LineEnd = myRange.Characters.Last.Information(wdFirstCharacterLineNumber)
 
　　Do While LineStart <> LineEnd
 
　　　If myRange.Text = "" Then
　　　　Exit Do
　　　Else
　　　　'フォントサイズが1の場合には段落を明るい緑色で着色
　　　　If myRange.Font.Size = 1 Then
　　　　　myRange.HighlightColorIndex = wdBrightGreen
　　　　　Exit Do
　　　　End If
 
　　　　'フォントサイズを縮小
　　　　With myRange.Font
　　　　　.Size = .Size - 0.5
　　　　End With
 
　　　　'末尾の文字の行番号を取得
　　　　LineEnd = myRange.Characters.Last.Information(wdFirstCharacterLineNumber)
 
　　　End If
 
　　Loop
　　DoEvents
 
　End If
 
End Sub

-コード
-, ,

S