【Word VBA】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

コメント

  1. えん より:

    お世話になります。いつも大変勉強させていただいております。
    こちらのマクロについて質問なのですが、テキストボックス上の段落についても対象にすることは難しいでしょうか。

    • 新田順也 より:

      えんさん
      コメントをどうもありがとうございます!
      テキストボックスの場合、別の処理が必要になります。
      厳密に処理をすると、「ヘッダーに書かれたグループ化されたテキストボックス1つ1つに対しても処理をする」みたいな感じになり、文書全体のどこかにあるテキストボックスを見つけて処理をする方法もありますが、そこまで細かくしないやり方(当然、処理の漏れがある)もあります。
      今後、他の方からのニーズがあるようでしたらブログ記事にします。技術的にできますが、今は記事にする時間がとれないので気長にお待ちください。

  2. えん より:

    新田様

    ご返信ありがとうございます。
    毎年、レイアウトの変わる名札のようなものを差し込み印刷で作っており、
    差し込み位置の細かな調整のために、基本的にすべて文字データの挿入はテキストボックスを使用しています。(40,50のオブジェクトがあります……笑)

    もしいつか記事が掲載される日を楽しみにしております。
    引き続きよろしくお願い致します。

    • 新田順也 より:

      えんさん
      なるほど。配置調整のためにテキストボックスを使われているのですね。
      そういう使い方もあるのですね。ヒントをありがとうございます。

トップへ戻る