質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.51%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

2回答

14356閲覧

VBAでshapeの大きさに合わせてtextのフォントサイズを変更する方法

5hh

総合スコア13

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2016/09/08 04:21

編集2016/09/09 06:46

###前提・実現したいこと
VBAでwordのshapeの大きさにあわせてtextのフォントサイズを変更する方法を実装したいですが、
何か方法が合ったりしますでしょうか。

変更したい対象:
shape in section.Headers(wdHeaderFooterFirstPage).range.ShapeRange

###試したこと
Shape.TextFrame.AutoSizeでフォントの大きさ似あわせてフレームのサイズを変更すること
が可能ですが、その逆を実現したい。

###補足情報
実行環境:office 2013,2016

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

ベストアンサー

AutoSizeを利用した方法をご紹介します。

手順は、

①元の幅・高さを取得する ②元のフォントサイズのままAutoSizeする ③AutoSize後の幅・高さにより処理を分岐 ③_A: AutoSizeにより元の幅・高さよりも小さくなった場合 ⇒フォントサイズを1つずつ上げていく ⇒元の幅・高さを超えない最大フォントまで繰り返す ③_B: AutoSizeにより幅・高さのどちらか一方でも大きくなった場合 ⇒フォントサイズを1つずつ下げていく ⇒元の幅・高さに収まるフォントサイズになるまで繰り返す

という流れです。

下記は少し長いですが上記手順をコード化したものです。

Sub test() 'AutoFontSize ThisDocument.Shapes(1) Dim shp As Shape For Each shp In ThisDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Shapes 'Range.ShapeRange AutoFontSize shp Next End Sub Sub AutoFontSize(shp As Shape) Dim orgH As Double '元の高さ Dim orgW As Double '元の幅 Dim newH As Double 'AutoSize後の高さ Dim newW As Double 'AutoSize後の幅 Dim newSize As Double Dim addMode As Integer 'サイズ変更モード With shp 'シェイプの元のサイズを記憶 orgH = .Height orgW = .Width '元のフォントサイズのままAutoSize .TextFrame.AutoSize = True 'AutoSize後のサイズを取得 newH = .Height newW = .Width If (orgH >= newH) And (orgW >= newW) Then '幅も高さも小さくなった場合 addMode = 1 'フォントを大きくするモード Else '幅または高さが大きくなった場合 addMode = 2 'フォントを小さくするモード End If '現在のフォントサイズを格納 'newSize = .TextFrame2.TextRange.Font.Size shp.Select newSize = Int(Selection.Font.Size) Do 'サイズ変更 Select Case addMode Case 1 'フォントを上げるモード If newSize > 99 Then Exit Do Else 'フォントサイズを+1 '.TextFrame2.TextRange.Font.Size = .TextFrame2.TextRange.Font.Size + 1 .TextFrame.AutoSize = False Selection.Font.Size = Selection.Font.Size + 1 .TextFrame.AutoSize = True End If Case Else 'フォントを下げるモード If newSize < 2 Then Exit Do Else 'フォントサイズを-1 '.TextFrame2.TextRange.Font.Size = .TextFrame2.TextRange.Font.Size - 1 .TextFrame.AutoSize = False Selection.Font.Size = Selection.Font.Size - 1 .TextFrame.AutoSize = True End If End Select '変更後のフォントでAutoSize '.TextFrame.AutoSize 'AutoSize後のサイズを取得 newH = .Height newW = .Width Select Case addMode Case 1 'フォントを上げるモード If (orgH >= newH) And (orgW >= newW) Then '幅も高さも小さくなった場合、まだ小さい。⇒ループ継続 Else '大きくなりすぎた為、前回のフォントサイズが最適。⇒ループ終了 Exit Do End If Case Else 'フォントを下げるモード If (orgH >= newH) And (orgW >= newW) Then '幅も高さも小さくなった場合 '現在のフォントサイズが最適。⇒ループ終了 'newSize = .TextFrame2.TextRange.Font.Size newSize = Selection.Font.Size Exit Do Else '幅または高さが大きくなった場合、まだ大きい。⇒ループ継続 End If End Select '現在のフォントサイズを格納 'newSize = .TextFrame2.TextRange.Font.Size newSize = Selection.Font.Size Loop '最適フォントサイズを適用 .TextFrame.AutoSize = False ' .TextFrame2.TextRange.Font.Size = newSize Selection.Font.Size = newSize '元のサイズに戻す .Height = orgH .Width = orgW End With End Sub

投稿2016/09/08 07:21

編集2016/09/09 08:07
jawa

総合スコア3013

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

5hh

2016/09/09 06:52

ご回答ありがとうございました。変更したい対象の説明が不足して申し訳ありません。質問内容を一部修正させていただきました。 変更したいのはword.shape in section.Headers(wdHeaderFooterFirstPage).range.ShapeRange ご教示頂いた方法で試したところ、下記のエラーが出てしましました。 newSize = .TextFrame2.TextRange.Font.sizeのところ run-time error "445": object doesn't support this action
jawa

2016/09/09 07:50

Excelとはいろいろ挙動が異なるようですね。 Word用にコード修正してみましたのでご確認ください。
5hh

2016/09/14 03:51

ご教示頂いた方法で試したのですが、 For Each sp In .Headers(wdHeaderFooterFirstPage).Shapes str = sp.Name If InStr(str, "PowerPlusWaterMarkObject") > 0 Then Call AutoFontSize(sp) End If Next AutoFontSize関数のshp.Selectのところ、run-time error '-2147024891 (80070005)' This member cannot be accessed in this view.のエラーに遭遇しました。
jawa

2016/09/14 12:52

PowerPlusWaterMarkObjectを対象に処理しようとされていますが、これは「透かし」ですよね? 今回行いたいことは、透かしの文字サイズをページサイズに合わせて調整したいということでしょうか? 当方Office2010環境なので環境の違いがあるかもしれませんが、透かしは一般的なシェイプとは違い、サイズ変更ができるようなものではないようです。 ですので、そもそもフォントサイズにあわせたAutoSize自体ができそうにありません。 この時点で私の提案した方法は破綻していますね(^_^; ttyp03さんの方法で.TextEffect.FontSizeを設定してあげれば、透かしのフォントサイズプロパティは変更されるようです。 ただ、それだけではプロパティの値が変わるだけで実際の見た目に反映されないようです。 変更後文書を保存して開き直しても、フォントサイズプロパティは変更されているのに、やはり表示には反映されないようです。 「ページレイアウト」-「透かし」-「ユーザー定義の透かし」から透かし設定画面を開き、「適用」すれば反映されるのですが。。
jawa

2016/09/14 12:59

どうやら「透かし」というのはヘッダーに書かれたワードアートらしいです。 ワードアートはフォントサイズを変更しても枠のサイズに合わせて自動調整してしまうので、フォントサイズの変更が反映されないのはおそらくこのためでしょう。 試しに「透かし」の幅と高さをページサイズにあわせて変更したところ、文字もこれにあわせて表示されました。 ``` shp.Width = ActiveDocument.Sections(1).PageSetup.PageWidth shp.Height = ActiveDocument.Sections(1).PageSetup.PageHeight ``` ただ、ワードアートなので縦横比を維持せずに伸縮してしまうのと、枠自体が斜めにしてあったりすると上記ではページからはみ出てしまう、など問題はあります。
5hh

2016/09/16 01:46

枠のサイズに合わせて自動調整に合わせて自動調整するということですね、大変参考になりました。後はなんとかなりそうです。
guest

0

完ぺきではないですが、こんな感じでどうでしょうか。

VBA

1With Shapes(1) 2 l = Len(.TextEffect.Text) 3 w = .Width - .TextFrame.MarginLeft - .TextFrame.MarginRight 4 h = .Height - .TextFrame.MarginTop - .TextFrame.MarginBottom 5 s = w / l 6 If s > h Then s = h 7 .TextEffect.FontSize = s 8End With

Word用

VBA

1For Each sh In Sections(1).Headers(wdHeaderFooterFirstPage).Shapes 2 sh.TextFrame.MarginLeft = 0 3 sh.TextFrame.MarginTop = 0 4 sh.TextFrame.MarginRight = 0 5 sh.TextFrame.MarginBottom = 0 6 l = Len(sh.TextFrame.TextRange.Text) - 1 7 w = sh.Width 8 h = sh.Height 9 s = w / l 10 If s > h Then s = h 11 sh.TextFrame.TextRange.Font.Size = s 12Next

投稿2016/09/08 05:31

編集2016/09/09 07:55
ttyp03

総合スコア16996

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

5hh

2016/09/09 06:49

ご回答ありがとうございました。変更したい対象の説明が不足して申し訳ありません。質問内容を一部修正させていただきました。 変更したいのはword.shape in section.Headers(wdHeaderFooterFirstPage).range.ShapeRange ご教示頂いた方法で試してみましたが、見た目上は何も変更が実施されていませんでした。
ttyp03

2016/09/09 07:57

WordのVBAということですね。 手直してしてみましたが、Shapeの扱いがExcelほど柔軟じゃないのでかなり精度が落ちます。 あとrange.ShapeRangeを使うとうまく参照できなかったのでshapesに置き換えています。
5hh

2016/09/14 03:47

ご教示頂いた方法で試してみたところ、 For Each sp In .Headers(wdHeaderFooterFirstPage).Shapes str = sp.Name If InStr(str, "PowerPlusWaterMarkObject") > 0 Then sp.TextFrame.TextRange.Font.size = 100 End If Next sp.TextFrame.TextRange.Font.size = 100の行で、run-time error '5917' This object does not support attached text.のエラーに遭遇しました。
ttyp03

2016/09/14 03:54

うーん、手元の環境がOffice2010なので挙動が違うのでしょうかね。 もしくはこちらが考えている図形の使い方をしていないか。
5hh

2016/09/14 07:08

ちなみにsp.TextEffect.FontSizeのプロパティも変更して見たのですが、こちらはエラーはでないものの、何も効果がないように見えました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.51%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問