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

Question

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

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

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

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

Answer 1

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

手順は、

①元の幅・高さを取得する

②元のフォントサイズのままAutoSizeする

③AutoSize後の幅・高さにより処理を分岐
 ③_A： AutoSizeにより元の幅・高さよりも小さくなった場合
  ⇒フォントサイズを１つずつ上げていく
  ⇒元の幅・高さを超えない最大フォントまで繰り返す

 ③_B： AutoSizeにより幅・高さのどちらか一方でも大きくなった場合
  ⇒フォントサイズを１つずつ下げていく
  ⇒元の幅・高さに収まるフォントサイズになるまで繰り返す

という流れです。

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

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

Comments

[5hh]

ご回答ありがとうございました。変更したい対象の説明が不足して申し訳ありません。質問内容を一部修正させていただきました。
変更したいのはword.shape in section.Headers(wdHeaderFooterFirstPage).range.ShapeRange

ご教示頂いた方法で試したところ、下記のエラーが出てしましました。
newSize = .TextFrame2.TextRange.Font.sizeのところ
run-time error "445":
object doesn't support this action

[jawa]

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

[5hh]

ご教示頂いた方法で試したのですが、
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]

PowerPlusWaterMarkObjectを対象に処理しようとされていますが、これは「透かし」ですよね？

今回行いたいことは、透かしの文字サイズをページサイズに合わせて調整したいということでしょうか？

当方Office2010環境なので環境の違いがあるかもしれませんが、透かしは一般的なシェイプとは違い、サイズ変更ができるようなものではないようです。
ですので、そもそもフォントサイズにあわせたAutoSize自体ができそうにありません。
この時点で私の提案した方法は破綻していますね(^_^;

ttyp03さんの方法で.TextEffect.FontSizeを設定してあげれば、透かしのフォントサイズプロパティは変更されるようです。
ただ、それだけではプロパティの値が変わるだけで実際の見た目に反映されないようです。
変更後文書を保存して開き直しても、フォントサイズプロパティは変更されているのに、やはり表示には反映されないようです。

「ページレイアウト」－「透かし」－「ユーザー定義の透かし」から透かし設定画面を開き、「適用」すれば反映されるのですが。。

[jawa]

どうやら「透かし」というのはヘッダーに書かれたワードアートらしいです。
ワードアートはフォントサイズを変更しても枠のサイズに合わせて自動調整してしまうので、フォントサイズの変更が反映されないのはおそらくこのためでしょう。
試しに「透かし」の幅と高さをページサイズにあわせて変更したところ、文字もこれにあわせて表示されました。
```
shp.Width = ActiveDocument.Sections(1).PageSetup.PageWidth
shp.Height = ActiveDocument.Sections(1).PageSetup.PageHeight
```

ただ、ワードアートなので縦横比を維持せずに伸縮してしまうのと、枠自体が斜めにしてあったりすると上記ではページからはみ出てしまう、など問題はあります。

[5hh]

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

Answer 2

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

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

Word用

For Each sh In Sections(1).Headers(wdHeaderFooterFirstPage).Shapes
    sh.TextFrame.MarginLeft = 0
    sh.TextFrame.MarginTop = 0
    sh.TextFrame.MarginRight = 0
    sh.TextFrame.MarginBottom = 0
    l = Len(sh.TextFrame.TextRange.Text) - 1
    w = sh.Width
    h = sh.Height
    s = w / l
    If s > h Then s = h
    sh.TextFrame.TextRange.Font.Size = s
Next

Comments

[5hh]

ご回答ありがとうございました。変更したい対象の説明が不足して申し訳ありません。質問内容を一部修正させていただきました。
変更したいのはword.shape in section.Headers(wdHeaderFooterFirstPage).range.ShapeRange

ご教示頂いた方法で試してみましたが、見た目上は何も変更が実施されていませんでした。

[ttyp03]

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

[5hh]

ご教示頂いた方法で試してみたところ、
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]

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

[5hh]

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