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

2014年3月26日

, ,

Wordで表を作成する場合に、項目名が一行に収まるようにフォントのサイズを調整することありませんか？

そのようなときに、このマクロが役に立ちます。

ただいま、翻訳イベントの準備に関わっているのですが、そのイベントの特別企画として、「名刺サイズ広告 」というものがあります。

Excelに記載されたデータを自動的に取り込んでWordの表にするマクロで広告を作成しています。

このマクロを作成したときに、1行に文字を収める方法を探しました。

どうやらWordの機能にはないようなのでマクロで作りました。

このマクロでできること

カーソルのある段落の文字列が1行に収まるようにフォントを自動で縮小させます。

マクロの解説

段落の先頭の文字と末尾の文字の行の値を比較し、同じになるまで段落のフォントサイズを縮小します。

行番号の取得には、Information プロパティを用いています。

フォントサイズの縮小には、Shrink メソッドを用いています。

なお、フォントサイズの縮小は、以下のようにも書き換えられます。

myRange.Font.Size = myRange.Font.Size - 0.5

マクロ


Sub 段落を1行に収めるマクロ()

　Dim PosStart As Long '先頭の文字の行番号
　Dim PosEnd As Long　 '末尾の文字の行番号
　Dim myRange As Range
　
　'myRangeオブジェクトをカーソル位置の段落に設定
　Set myRange = Selection.Range
　myRange.Expand unit:=wdParagraph
　
　'改行記号を除外
　myRange.End = myRange.End - 1
　
　'先頭文字の行番号を取得
　PosStart = myRange.Information(wdFirstCharacterLineNumber)
　
　'末尾文字の行番号を取得
　PosEnd = myRange.Characters.Last.Information(wdFirstCharacterLineNumber)
　　
　Do While PosStart <> PosEnd
　　
　　If myRange.Font.Size = 1 Then
　　　MsgBox "フォントサイズは１です。終了します。"
　　　Exit Do
　　End If
　　
　　'フォントサイズを縮小
　　myRange.Font.Shrink
　　
　　'末尾の文字の行番号を取得
　　PosEnd = myRange.Characters.Last.Information(wdFirstCharacterLineNumber)
　
　Loop

　'myRangeオブジェクトを解放
　Set myRange = Nothing

End Sub

翻訳イベントへの参加受付中！

いきなりですが（笑）、宣伝です。このマクロを作成することになった翻訳イベントの件。

ただいま、6月の翻訳イベント（IJET-25） への参加を募集中！

4月10日までなら、5000円お得な早割にてお申し込みをいただけます。

すでに100名以上の方からのお申し込みをいただきました。

「名刺サイズ広告 」にも、多くの参加を表明いただいています！

この2日間のイベントでは、フリーランスで仕事を獲得するためのウェブマーケティング 、PC専門家による肩こり腰痛軽減法 、資産形成のための投資術 、ストレス管理術 など、今まで通翻訳学校ではありそうでなかったセッションも目白押し！

翻訳者ではなく、その道の専門家が登壇されるというのも興味深いです。

こんな豪華なイベントはなかなか開催されないと思います。

翻訳者の方々のみならず、特許技術者、フリーランスで活躍されているライターの方も、ツールマニアの方（笑）も、パソコンを使った知的労働に携わるすべての方にお勧めの2日間になっていると思います。

楽しみですね。

お申し込みをお待ちしています！

-コード
-, ,