PowerPoint VBA サンプル～フロー図のコネクタだけ選択・複数シェイプに書かれた数字を一括インクリメント

何やらTwitterでPowerPoint VBAネタがよく流れてくるので便乗してみる。

と言っても新規ネタは無いので昔Webサイトに掲載した内容の再掲。
パワーポイントVBA - You.Activate
（サイトの方のアクセスは微量なのでなかなか日の目を見ない。）

フローチャート等でコネクタだけor画像だけを選択するマクロ

パワポでフロー図を作ることもよくあると思うけれど、後から図形の枠線だけ色を変えたいとか、コネクターの線だけ太くしたいとかいうことってよくある。

そうするためには例えばCtrl + クリックでコネクタだけをチマチマ選択していく必要があるが、数が多いととても面倒くさい。

次に紹介するマクロを使うとマウスドラッグで範囲選択した後に図形かコネクターかどちらか不要な方を一発で選択解除できる。
f:id:t-hom:20180908081855g:plain

コードはこちら。
※このころの私はマルチバイト識別子がマイブーム

Sub 選択除外_図形のみ選択()
    Call 選択除外(True)
End Sub
 
Sub 選択除外_コネクターのみ選択()
    Call 選択除外(False)
End Sub
 
Private Sub 選択除外(非コネクター As Boolean)
     
    'シェイプが選択されていなければ、処理を中断する。
    If Not ActiveWindow.Selection.Type = ppSelectionShapes Then Exit Sub
     
    '残すシェイプのリストを準備
    Dim 残すリスト() As String
    ReDim 残すリスト(0)
     
    Dim 図 As Shape
 
    For Each 図 In ActiveWindow.Selection.ShapeRange
        If 図.Connector Xor 非コネクター Then
         
            '残すシェイプの末尾に図の名前を追記
            残すリスト(UBound(残すリスト)) = 図.Name
             
            '次の追記用にリストを1つ拡張
            ReDim Preserve 残すリスト(UBound(残すリスト) + 1)
        End If
    Next
     
    'ループで一個作りすぎるので、最後にマイナス１する
    ReDim Preserve 残すリスト(UBound(残すリスト) - 1)
    
    Dim 現在のスライド As Slide
    Set 現在のスライド = ActiveWindow.Selection.SlideRange(1)
     
    '残すリストの図形を選択しなおす。
    現在のスライド.Shapes.Range(残すリスト).Select
     
End Sub

複数シェイプ上の番号を簡単に増減する

フローチャート等でプロセスごとに番号を振っていて、例えば間にプロセスを挿入したり削除した場合、後続の番号が全部ずれ込んでチマチマ修正する羽目になる。
とても面倒なので、選択範囲のシェイプに書かれた番号を一括で増減できるマクロを作った。

f:id:t-hom:20180908083439g:plain

Sub 番号プラス()
    Call 番号増減(1)
End Sub
 
Sub 番号マイナス()
    Call 番号増減(-1)
End Sub
 
Private Sub 番号増減(数値)
 
    'シェイプが選択されていなければ、処理を中断する。
    If Not ActiveWindow.Selection.Type = ppSelectionShapes Then Exit Sub
     
    Dim 図 As Shape
    For Each 図 In ActiveWindow.Selection.ShapeRange
        If 図.HasTextFrame Then
            If 図.TextFrame.HasText Then
                With 図.TextFrame.TextRange
                    'Asc関数にテキストを入れると1文字目の文字コードを返す。
                    'それに指定された数値を足してChrで文字に戻したあと、
                    '2文字目以降を結合。
                    .Text = Chr(Asc(.Text) + 数値) & Mid(.Text, 2)
                End With
            End If
        End If
    Next
End Sub