Sub DrawLinesBasedOnShapes()
Dim shp As Shape
Dim newLine As Shape
Dim i As Integer
Dim leftPos As Single, rightPos As Single
Dim midYPos As Single
Dim shapesArr() As Shape
Dim activeSlide As Slide
' 現在のアクティブなスライドを設定
Set activeSlide = ActiveWindow.View.Slide
' 1つの図形の場合
If ActiveWindow.Selection.ShapeRange.Count = 1 Then
Set shp = ActiveWindow.Selection.ShapeRange(1)
Set newLine = activeSlide.Shapes.AddLine(shp.Left, shp.Top + shp.Height + 28.35, shp.Left + shp.Width, shp.Top + shp.Height + 28.35)
With newLine.Line
.ForeColor.RGB = RGB(192, 192, 192) ' 灰色
.Weight = 1
End With
' 2つ以上の図形の場合
ElseIf ActiveWindow.Selection.ShapeRange.Count > 1 Then
' 配列を初期化
ReDim shapesArr(1 To ActiveWindow.Selection.ShapeRange.Count)
' 選択した図形を配列に入れる
For i = 1 To ActiveWindow.Selection.ShapeRange.Count
Set shapesArr(i) = ActiveWindow.Selection.ShapeRange(i)
Next i
' 選択した図形の間に線を引く
For i = 1 To UBound(shapesArr) - 1
' 左と右の図形を見つける
If shapesArr(i).Left < shapesArr(i + 1).Left Then
leftPos = shapesArr(i).Left + shapesArr(i).Width
rightPos = shapesArr(i + 1).Left
Else
leftPos = shapesArr(i + 1).Left + shapesArr(i + 1).Width
rightPos = shapesArr(i).Left
End If
' 上の図形の下端と次の図形の上端のちょうど中間の位置を計算
midYPos = (shapesArr(i).Top + shapesArr(i).Height + shapesArr(i + 1).Top) / 2
' 線を追加
Set newLine = activeSlide.Shapes.AddLine(leftPos, midYPos, rightPos, midYPos)
With newLine.Line
.ForeColor.RGB = RGB(192, 192, 192) ' 灰色
.Weight = 1
End With
Next i
End If
End Sub