LoginSignup
5
5

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 3 years have passed since last update.

@nkay

【PowerPoint VBA】まともな『オブジェクトの整列』（左揃え等）コマンドを作成する

Posted at

まともな『オブジェクトの整列』（左揃え等）コマンドを作成する

この記事はPowerPointLabsというアドインに触発されて書きました。

動機

PowerPointで複数のオブジェクトを一直線上に並べたいとき、「書式タブ > 配置グループ > 配置」内の左揃えとか上下中央揃えとかを選択するのが普通です（以下、標準コマンド）。
⇒オブジェクトを整列または配置する - Office サポート

しかし、この標準コマンドには、いくつかの不便な点があります。したがってVBAでこの不満点を解消した新しい『オブジェクトの整列』コマンドを作成することを試みます。

標準コマンドの不便なところ

標準コマンドの不満点について記します。

整列の基準を指定できない

例えばAdobe Illustratorの場合、オブジェクトを複数選択しているときに、選択したオブジェクトのどれか一つをもう一度クリックするとキーオブジェクトとなります。この状態で整列コマンドを使用するとキーオブジェクトに従って整列されます。
⇒Illustrator でオブジェクトを移動、整列、分布させる方法 #オブジェクトの整列と分布

PowerPointではキーオブジェクトを任意で選ぶことができず、左揃えコマンドは最も左に位置するオブジェクトが、下揃えコマンドは最も下に位置するオブジェクトが、強制的にキーオブジェクトになります。中央揃えコマンドは全体の中央が基準となるようです。

Align1.jpg

これは大変不便であります。

回転された、長方形でないオブジェクトを整列できない

長方形でないオブジェクトを回転させると、オブジェクト本体の端の位置と、見た目上の端の位置がずれます。こういう図形は整列しようとすると架空の頂点を基準にしてくるため失敗します。

Align2.jpg

見た目上の位置で揃えてほしいと人々は願うことでしょう。

ぬるっと動く

標準コマンドはなにやらぬるっと動きますが、こんな機能は必要ありません。

整列コマンドの作成

方針

最も基本的なものとして、まず左揃えコマンドを作成します。

キーオブジェクトについてですが、Illustratorのようにオブジェクト群を選択後にキーオブジェクトを選ぶチャンスが与えられるところまで実装するのは面倒なので、代替として、ここでは複数選択されたオブジェクト群のうち最後に選択したオブジェクトをキーオブジェクトにすることとします。
これはつまり対象のオブジェクトの数が膨大であっても、マウスでそれらを矩形選択した後にキーにしたいオブジェクトに対して「Shift+クリック」を2回行うことでキーオブジェクトにすることができる、ということであります。

1.選択オブジェクトの取得

まず選択したオブジェクトを取得します。
どうやらこれはActiveWindow.Selection.ShapeRangeに存在するようです。型はShapeRange型で、これは配列のようになっており、複数選択されている場合は選択した順に格納されています。

Dim SelectedShapes As ShapeRange
Set SelectedShapes = ActiveWindow.Selection.ShapeRange

ただし、「何も選択していない」「スライドを選択している」場合はこれだとエラーが出ますので、まずActiveWindow.Selectionの型（ppselectiontype）をチェックしないといけないようです。

ppselectiontype 値 説明
ppselectionnone 0 何も選択していない状態
ppselectionslides 1 スライドを選択している状態
ppselectionshapes 2 図形を選択している状態
ppselectiontext 3 文字列を選択している状態

文字列を選択している場合は、その図形を選択している状態ともとってくれるようです。

Dim SelectedShapes As ShapeRange

If ActiveWindow.Selection.Type = ppSelectionNone _
Or ActiveWindow.Selection.Type = ppSelectionSlides Then
    Exit Sub
End If

Set SelectedShapes = ActiveWindow.Selection.ShapeRange

「何も選択していない」「スライドを選択している」場合は何もしないで終了する処理にしました。かしこまった人は疑似Try-Catch文を書いたりエラーメッセージを出したりするのかもしれませんが、不正な処理である理由が自明なのでまあいらないでしょう。

2.キーオブジェクトの取得

前項で述べたとおりShapeRangeは選択した順に図形が格納されているので、最後に格納されている図形がキーオブジェクトになります。また、ShapeRange型は.Countプロパティで選択した図形の数を取得できます。
したがって以下のようになります。

Dim SelectedShapes As ShapeRange
Dim MaxNum As Long
Dim KeyShape As Shape

If ActiveWindow.Selection.Type = ppSelectionNone _
Or ActiveWindow.Selection.Type = ppSelectionSlides Then
    Exit Sub
End If

Set SelectedShapes = ActiveWindow.Selection.ShapeRange
MaxNum = SelectedShapes.Count

Set KeyShape = SelectedShapes(MaxNum)

今回左揃えですので、キーオブジェクトの左座標を取得します。Shape型は、.Leftプロパティにスライドの左端からの距離、.Top属性に上端からの距離が格納されています。

Dim SelectedShapes As ShapeRange
Dim MaxNum As Long
Dim KeyShape As Shape
Dim KeyPoint As Double

If ActiveWindow.Selection.Type = ppSelectionNone _
Or ActiveWindow.Selection.Type = ppSelectionSlides Then
    Exit Sub
End If

Set SelectedShapes = ActiveWindow.Selection.ShapeRange
MaxNum = SelectedShapes.Count

Set KeyShape = SelectedShapes(MaxNum)
KeyPoint = KeyShape.Left

3.オブジェクト群をキーオブジェクトの位置に移動

まず最初に選択したオブジェクトについて考えます。.Leftプロパティは代入もできるので、そこに先程取得したKeyPointを入れるだけです。

Dim SelectedShapes As ShapeRange
Dim MaxNum As Long
Dim KeyShape As Shape
Dim KeyPoint As Double
Dim FirstSelectShape As Shape

If ActiveWindow.Selection.Type = ppSelectionNone _
Or ActiveWindow.Selection.Type = ppSelectionSlides Then
    Exit Sub
End If

Set SelectedShapes = ActiveWindow.Selection.ShapeRange
MaxNum = SelectedShapes.Count

Set KeyShape = SelectedShapes(MaxNum)
KeyPoint = KeyShape.Left

Set FirstSelectShape = SelectedShapes(1)
FirstSelectShape.Left = KeyPoint

同じ処理をSelectedShapesの最後（キーオブジェクト）以外に対して行えばいいので、For文をつかって、

Dim SelectedShapes As ShapeRange
Dim MaxNum As Long
Dim KeyShape As Shape
Dim KeyPoint As Double
Dim TempShape As Shape

If ActiveWindow.Selection.Type = ppSelectionNone _
Or ActiveWindow.Selection.Type = ppSelectionSlides Then
    Exit Sub
End If

Set SelectedShapes = ActiveWindow.Selection.ShapeRange
MaxNum = SelectedShapes.Count

Set KeyShape = SelectedShapes(MaxNum)
KeyPoint = KeyShape.Left

For i = 1 To MaxNum - 1
    Set TempShape = SelectedShapes(i)
    TempShape.Left = KeyPoint
Next i

とりあえず一段落ですが、これではまだ回転された図形に対しては正常な動作が行なえません。

4.回転された長方形のオブジェクトに対する処理

Shape.Leftには、「回転されていない場合の左端の位置」が格納されています。「回転された図形の見た目上の左端の位置」はどのように取得すればよいのでしょうか。
図形を回転しても中心座標は変化しないので、Shape.LeftとShape.Widthより中心座標を求め、そこから回転図形の見た目上の幅を引いて左端の位置を求めます。
長方形のオブジェクトの場合は、回転角度がわかれば三角関数より見た目上の幅を求められます。

言葉でいうより以下のコードを見たほうが早いでしょう。

Private Function GetVisualPointsByRotation(ByRef shapeA As Shape) As Collection
    Dim degRotation As Double, radRotation As Double
    Dim VisualWidth As Double, VisualHeight As Double
    Dim VisualLeft As Double, VisualTop As Double
    Dim PI As Double
    Dim VisualPoints As Collection

    PI = 4 * Atn(1)
    degRotation = shapeA.rotation
    radRotation = degRotation * PI / 180

    If degRotation = 0 Or degRotation = 180 Then
        VisualWidth = shapeA.Width
        VisualHeight = shapeA.Height
    ElseIf degRotation = 90 Or degRotation = 270 Then
        VisualWidth = shapeA.Height
        VisualHeight = shapeA.Width
    ElseIf degRotation > 0 And degRotation < 90 Then
        VisualWidth = shapeA.Height * Sin(radRotation) + shapeA.Width * Cos(radRotation)
        VisualHeight = shapeA.Height * Cos(radRotation) + shapeA.Width * Sin(radRotation)
    ElseIf degRotation > 90 And degRotation < 180 Then
        VisualWidth = shapeA.Height * Sin(radRotation) - shapeA.Width * Cos(radRotation)
        VisualHeight = -shapeA.Height * Cos(radRotation) + shapeA.Width * Sin(radRotation)
    ElseIf degRotation > 180 And degRotation < 270 Then
        VisualWidth = -shapeA.Height * Sin(radRotation) - shapeA.Width * Cos(radRotation)
        VisualHeight = -shapeA.Height * Cos(radRotation) - shapeA.Width * Sin(radRotation)
    ElseIf degRotation > 270 And degRotation < 360 Then
        VisualWidth = -shapeA.Height * Sin(radRotation) + shapeA.Width * Cos(radRotation)
        VisualHeight = shapeA.Height * Cos(radRotation) - shapeA.Width * Sin(radRotation)
    End If
    VisualLeft = shapeA.Left + shapeA.Width / 2 - VisualWidth / 2
    VisualTop = shapeA.Top + shapeA.Height / 2 - VisualHeight / 2

    Set VisualPoints = New Collection
    VisualPoints.add VisualLeft, "Left"
    VisualPoints.add VisualTop, "Top"
    VisualPoints.add VisualWidth, "Width"
    VisualPoints.add VisualHeight, "Height"
    Set GetVisualPointsByRotation = VisualPoints
End Function

便利なので高さや幅の情報も含めたCollectionで返しています。

5.回転された長方形でないオブジェクトに対する処理

いろいろ調べ考えた結果、見た目が全く同じ図形を複製することになりました。

Private Function GetVisualPoints(ByRef shapeA As Shape) As Collection
    Dim shapeB As Shape
    Dim node As ShapeNode
    Dim i As Long
    Dim nodePoints() As Double
    Dim VisualPoints As Collection

    If shapeA.Type = msoAutoShape Or shapeA.Type = msoFreeform Then
        Set shapeB = shapeA.Duplicate(1)
        shapeB.Left = shapeA.Left
        shapeB.Top = shapeA.Top
        If shapeA.Type = msoAutoShape Then
            shapeB.Nodes.Insert 1, msoSegmentLine, msoEditingAuto, 0, 0
            shapeB.Nodes.Delete 2
        End If

        ReDim nodePoints(1 To shapeB.Nodes.Count, 0 To 1)
        For i = 1 To shapeB.Nodes.Count
            Set node = shapeB.Nodes(i)
            nodePoints(i, 0) = node.points(1, 1)
            nodePoints(i, 1) = node.points(1, 2)
        Next i

        shapeB.rotation = 0
        For i = 1 To shapeB.Nodes.Count
            shapeB.Nodes.SetPosition i, nodePoints(i, 0), nodePoints(i, 1)
        Next i

        Set VisualPoints = New Collection
        VisualPoints.add shapeB.Left, "Left"
        VisualPoints.add shapeB.Top, "Top"
        VisualPoints.add shapeB.Width, "Width"
        VisualPoints.add shapeB.Height, "Height"
        shapeB.Delete
    Else
        Set VisualPoints = GetVisualPointsByRotation(shapeA)
    End If
    Set GetVisualPoints = VisualPoints
End Function

順を追って説明します。

If shapeA.Type = msoAutoShape Or shapeA.Type = msoFreeform Then
    Set shapeB = shapeA.Duplicate(1)
    shapeB.Left = shapeA.Left
    shapeB.Top = shapeA.Top
    If shapeA.Type = msoAutoShape Then
        shapeB.Nodes.Insert 1, msoSegmentLine, msoEditingAuto, 0, 0
        shapeB.Nodes.Delete 2
    End If
    '...
Else
    Set VisualPoints = GetVisualPointsByRotation(shapeA)
End If

PowerPointでは、図形を挿入するとmsoAutoShapeという型のShapeになります。msoAutoShapeのノードを編集（図形を右クリックすると頂点を編集というコマンドがあります）すると、msoFreeformという型に自動的に変身します。上記の部分では対象の図形を複製したのち、msoFreeformに変換しています。
なお、msoAutoShapeやmsoFreeform以外のオブジェクトは基本的に長方形なので先程のGetVisualPointsByRotationで処理します。

ReDim nodePoints(1 To shapeB.Nodes.Count, 0 To 1)
For i = 1 To shapeB.Nodes.Count
    Set node = shapeB.Nodes(i)
    nodePoints(i, 0) = node.points(1, 1)
    nodePoints(i, 1) = node.points(1, 2)
Next i

上記の部分では、複製した図形のノード情報を配列としてコピーしています。

shapeB.rotation = 0
For i = 1 To shapeB.Nodes.Count
    shapeB.Nodes.SetPosition i, nodePoints(i, 0), nodePoints(i, 1)
Next i

この部分では、複製した図形を0度にした後に、先程コピーしたノード情報を復元しています。

6.完成

上記を整理して作成した、左揃え・垂直揃え・右揃えコマンドは以下のようになります。

Align.bas
'Main
Public Sub AlignLeft()
    Dim SelectedShapes As ShapeRange
    Dim MaxNum As Long
    Dim KeyPoint As Double
    Dim TargetShape As Shape
    Dim i As Long

    If ActiveWindow.Selection.Type = ppSelectionNone _
    Or ActiveWindow.Selection.Type = ppSelectionSlides Then
        Exit Sub
    End If

    Set SelectedShapes = ActiveWindow.Selection.ShapeRange
    MaxNum = SelectedShapes.Count
    If MaxNum < 2 Then
        SelectedShapes.Align msoAlignLefts, msoTrue
        Exit Sub
    End If

    KeyPoint = GetVisualPoints(SelectedShapes(MaxNum))("Left")
    For i = 1 To MaxNum - 1
        Set TargetShape = SelectedShapes(i)
        TargetShape.IncrementLeft KeyPoint - GetVisualPoints(TargetShape)("Left")
    Next i
End Sub

Public Sub AlignVerticalCenter()
    Dim SelectedShapes As ShapeRange
    Dim MaxNum As Long
    Dim KeyPoints As Collection
    Dim KeyPoint As Double
    Dim TargetShape As Shape
    Dim TargetPoints As Collection
    Dim i As Long

    If ActiveWindow.Selection.Type = ppSelectionNone _
    Or ActiveWindow.Selection.Type = ppSelectionSlides Then
        Exit Sub
    End If

    Set SelectedShapes = ActiveWindow.Selection.ShapeRange
    MaxNum = SelectedShapes.Count
    If MaxNum < 2 Then
        SelectedShapes.Align msoAlignCenters, msoTrue
        Exit Sub
    End If

    Set KeyPoints = GetVisualPoints(SelectedShapes(MaxNum))
    KeyPoint = KeyPoints("Left") + KeyPoints("Width") / 2

    For i = 1 To MaxNum - 1
        Set TargetShape = SelectedShapes(i)
        Set TargetPoints = GetVisualPoints(TargetShape)
        TargetShape.IncrementLeft KeyPoint - TargetPoints("Left") - TargetPoints("Width") / 2
    Next i
End Sub

Public Sub AlignRight()
    Dim SelectedShapes As ShapeRange
    Dim MaxNum As Long
    Dim KeyPoints As Collection
    Dim KeyPoint As Double
    Dim TargetShape As Shape
    Dim TargetPoints As Collection
    Dim i As Long

    If ActiveWindow.Selection.Type = ppSelectionNone _
    Or ActiveWindow.Selection.Type = ppSelectionSlides Then
        Exit Sub
    End If

    Set SelectedShapes = ActiveWindow.Selection.ShapeRange
    MaxNum = SelectedShapes.Count
    If MaxNum < 2 Then
        SelectedShapes.Align msoAlignRights, msoTrue
        Exit Sub
    End If

    Set KeyPoints = GetVisualPoints(SelectedShapes(MaxNum))
    KeyPoint = KeyPoints("Left") + KeyPoints("Width")

    For i = 1 To MaxNum - 1
        Set TargetShape = SelectedShapes(i)
        Set TargetPoints = GetVisualPoints(TargetShape)
        TargetShape.IncrementLeft KeyPoint - TargetPoints("Left") - TargetPoints("Width")
    Next i
End Sub

'Function
Private Function GetVisualPoints(ByRef shapeA As Shape) As Collection
    Dim shapeB As Shape
    Dim node As ShapeNode
    Dim i As Long
    Dim nodePoints() As Double
    Dim VisualPoints As Collection

    If shapeA.rotation = 0 Or shapeA.rotation = 180 Then
        Set VisualPoints = New Collection
        VisualPoints.add shapeA.Left, "Left"
        VisualPoints.add shapeA.Top, "Top"
        VisualPoints.add shapeA.Width, "Width"
        VisualPoints.add shapeA.Height, "Height"
    ElseIf shapeA.Type = msoAutoShape Or shapeA.Type = msoFreeform Then
        Set shapeB = shapeA.Duplicate(1)
        shapeB.Left = shapeA.Left
        shapeB.Top = shapeA.Top
        If shapeA.Type = msoAutoShape Then
            shapeB.Nodes.Insert 1, msoSegmentLine, msoEditingAuto, 0, 0
            shapeB.Nodes.Delete 2
        End If

        ReDim nodePoints(1 To shapeB.Nodes.Count, 0 To 1)
        For i = 1 To shapeB.Nodes.Count
            Set node = shapeB.Nodes(i)
            nodePoints(i, 0) = node.points(1, 1)
            nodePoints(i, 1) = node.points(1, 2)
        Next i

        shapeB.rotation = 0
        For i = 1 To shapeB.Nodes.Count
            shapeB.Nodes.SetPosition i, nodePoints(i, 0), nodePoints(i, 1)
        Next i

        Set VisualPoints = New Collection
        VisualPoints.add shapeB.Left, "Left"
        VisualPoints.add shapeB.Top, "Top"
        VisualPoints.add shapeB.Width, "Width"
        VisualPoints.add shapeB.Height, "Height"
        shapeB.Delete
    Else
        Set VisualPoints = GetVisualPointsByRotation(shapeA)
    End If
    Set GetVisualPoints = VisualPoints
End Function

Private Function GetVisualPointsByRotation(ByRef shapeA As Shape) As Collection
    Dim degRotation As Double, radRotation As Double
    Dim VisualWidth As Double, VisualHeight As Double
    Dim VisualLeft As Double, VisualTop As Double
    Dim PI As Double
    Dim VisualPoints As Collection

    PI = 4 * Atn(1)
    degRotation = shapeA.rotation
    radRotation = degRotation * PI / 180

    If degRotation = 0 Or degRotation = 180 Then
        VisualWidth = shapeA.Width
        VisualHeight = shapeA.Height
    ElseIf degRotation = 90 Or degRotation = 270 Then
        VisualWidth = shapeA.Height
        VisualHeight = shapeA.Width
    ElseIf degRotation > 0 And degRotation < 90 Then
        VisualWidth = shapeA.Height * Sin(radRotation) + shapeA.Width * Cos(radRotation)
        VisualHeight = shapeA.Height * Cos(radRotation) + shapeA.Width * Sin(radRotation)
    ElseIf degRotation > 90 And degRotation < 180 Then
        VisualWidth = shapeA.Height * Sin(radRotation) - shapeA.Width * Cos(radRotation)
        VisualHeight = -shapeA.Height * Cos(radRotation) + shapeA.Width * Sin(radRotation)
    ElseIf degRotation > 180 And degRotation < 270 Then
        VisualWidth = -shapeA.Height * Sin(radRotation) - shapeA.Width * Cos(radRotation)
        VisualHeight = -shapeA.Height * Cos(radRotation) - shapeA.Width * Sin(radRotation)
    ElseIf degRotation > 270 And degRotation < 360 Then
        VisualWidth = -shapeA.Height * Sin(radRotation) + shapeA.Width * Cos(radRotation)
        VisualHeight = shapeA.Height * Cos(radRotation) - shapeA.Width * Sin(radRotation)
    End If
    VisualLeft = shapeA.Left + shapeA.Width / 2 - VisualWidth / 2
    VisualTop = shapeA.Top + shapeA.Height / 2 - VisualHeight / 2

    Set VisualPoints = New Collection
    VisualPoints.add VisualLeft, "Left"
    VisualPoints.add VisualTop, "Top"
    VisualPoints.add VisualWidth, "Width"
    VisualPoints.add VisualHeight, "Height"
    Set GetVisualPointsByRotation = VisualPoints
End Function
5
5
2

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
5
5

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?