【コード】1行に収まるようフォントサイズを縮小するWordマクロ(その2)

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

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

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

このマクロでできること

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

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

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

差し込み印刷の文書

差し込み印刷

結果の表示

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

差し込み印刷

マクロ実行前

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

差し込み印刷

マクロ実行後

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

差し込み印刷

マクロの解説

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

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

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

マクロ


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

トップへ戻る