Powerpointで袋文字をワンクリックで設定するマクロ

パワーポイント/Powerpointを使っていますか？

普段ビジネスで使っている人は、Word/Excel並に利用する頻度が高いソフトだと思っています。

背景があるときに文字が溶け込んでしまって見づらい現象とか、あるあるネタだと思います。

そんなときに利用する「袋文字」を、ワンクリックで設定するマクロを組んだのでご紹介します。

袋文字って何？
袋文字を一発で設定するマクロ
Appendix
このマクロって、どうやって設定するの？
別にマクロにしなくて良くない？
いちいちファイルにマクロ設定したくないんだけど……
まとめ

袋文字って何？

百聞は一見にしかず。こういうやつです。

パッと見、上は文字が背景に溶け込んでわかりづらくなってますが、下は見やすくなっていると思います。

そもそも、ここまで背景が主張してくることはそんなになさそうですが笑

背景画像の明度を意識してパワポ作ればいいんですが……
デザインセンスがあるわけではないので、黒一色で構成するときには必須のテクニックになります。

袋文字を一発で設定するマクロ

Sub 袋文字作成_10()
    Call make_fukuromoji(10)
End Sub


Function make_fukuromoji(weight)

    Dim n As Long
    
    '選択中のスライド番号を取得
    n = ActiveWindow.Selection.SlideRange.SlideIndex

    For Each shp In ActiveWindow.Selection.ShapeRange
        
        '選択中のテキストボックスをコピー
        With ActiveWindow.Selection
    
            'テキストボックスが選択されていない場合はマクロを終了
            If shp.HasTextFrame = msoFalse Or shp.TextFrame.HasText = msoFalse Then
                Exit Function
            End If
        
            With shp
                'テキストボックスの名前を仮で決める
                .Name = "txt1"
                '最前面へ移動
                .ZOrder msoBringToFront
                'テキストボックスをコピー
                .Copy
                'テキストボックスの位置を代入
                x = .Top
                y = .Left
            End With
        End With
    
    
        'コピーした元のテキストボックスを複製して袋文字にする
        With ActivePresentation.Slides(n).Shapes.Paste
            'テキストボックスの名前を仮で決める
            .Name = "txt2"
            '背面へ移動
            .ZOrder msoSendBackward
            'テキストボックス移動
            .Top = x
            .Left = y
            '文字線幅
            .TextFrame2.TextRange.Font.Line.weight = weight
            '文字色を白にする
            .TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
            .TextFrame2.TextRange.Font.Line.ForeColor.RGB = RGB(255, 255, 255)
        End With
        
        'テキストボックスをグループ化
        With ActivePresentation.Slides(n).Shapes
            .Range(Array("txt1", "txt2")).Group
            .Range("txt1").Name = .Range("txt1").Id
            .Range("txt2").Name = .Range("txt2").Id
        End With

    Next shp
End Function

コピペでOKです。