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

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

ただいまの
回答率

88.81%

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

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 7,040

5hh

score 13

前提・実現したいこと

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

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

試したこと

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

補足情報

実行環境:office 2013,2016

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

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

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

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

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/14 21:52

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

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

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


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

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

    キャンセル

  • 2016/09/14 21:59

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

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

    キャンセル

  • 2016/09/16 10:46

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

    キャンセル

0

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

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/09/14 12: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.のエラーに遭遇しました。

    キャンセル

  • 2016/09/14 12:54

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

    キャンセル

  • 2016/09/14 16:08

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

    キャンセル

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

  • ただいまの回答率 88.81%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る