Power Point(パワーポイント)VBAで、交差するコネクタの片方をアーチ型に自動編集する
今まで使ったことが無かったのですが、Power Point にもVBAがあります。2018年9月現在、その使用方法について↓こちらで連載が始まっています。大変分かり易く、目が離せません。
tonari-it.com
これらの連載記事を参考に、日頃不便に思っていたことの自動化に挑戦しました。こんな感じで。
Power Point でフローチャートなどを書く時、線が交差していると、とても見にくく感じます。
そこで、水平線に垂直線をアーチ形状で跨がせるマクロを作成してみました。
[標準モジュール]
Option Explicit Enum ErrorType ShapeTypeError = 1 VerticalTiltError HolizontalTiltError UnidentifiedError End Enum Sub StepOver() Dim ShapeRanges As ShapeRange On Error Resume Next Set ShapeRanges = ActiveWindow.Selection.ShapeRange If Err.Number = -2147188160 Then MsgBox "オートシェイプが選択されていません。" Exit Sub End If On Error GoTo 0 If ShapeRanges.Count <> 2 Then MsgBox "コネクタを2本選択したうえで、再度実行してください。" Exit Sub End If Dim shape As shape Dim SC As ShapeClass Set SC = New ShapeClass For Each shape In ShapeRanges If shape.Height > shape.Width Then Set SC.V = shape Else Set SC.H = shape End If Next Dim ErrMsg(4) As String ErrMsg(1) = "直線以外が選択されています。" ErrMsg(2) = "垂直線が傾いています。" ErrMsg(3) = "水平線が傾いています。" ErrMsg(4) = "エラー発生(直線以外が選択されている、など)。" If SC.Check <> 0 Then MsgBox ErrMsg(SC.Check) Exit Sub End If Call SC.DrawHalfArc Call SC.AdjustLength Call SC.ConnectShape End Sub
描画用のクラスモジュールです。名前はShapeClassとしました。
[クラスモジュール]
Option Explicit Public V As shape Public H As shape Public H_Splited_Left As shape Public H_Splited_Right As shape Public radius As Double Public HalfArc As shape Private Sub Class_Initialize() radius = 8 End Sub Private Property Get BeginAngle() As Long BeginAngle = 180 End Property Private Property Get EndAngle() As Long EndAngle = 0 End Property Private Property Get origin_point_x() As Double origin_point_x = V.Left End Property Private Property Get origin_point_y() As Double origin_point_y = H.Top End Property Public Function DrawHalfArc() As Boolean Dim myLeft As Double: myLeft = origin_point_x Dim myTop As Double: myTop = origin_point_y - radius * 2 Dim myWidth As Double: myWidth = radius * 2 Dim myHeight As Double: myHeight = radius * 2 Dim Arc As shape On Error GoTo er: Set Arc = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex).Shapes. _ AddShape(msoShapeArc, _ myLeft, _ myTop, _ myWidth, _ myHeight) Arc.Adjustments.Item(1) = BeginAngle Arc.Adjustments.Item(2) = EndAngle Set HalfArc = Arc DrawHalfArc = True Exit Function er: DrawHalfArc = False End Function Public Sub AdjustLength() Set H_Splited_Right = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex).Shapes. _ AddConnector(msoConnectorStraight, _ origin_point_x + radius * 2, _ H.Top, _ H.Left + H.Width, _ H.Top) H_Splited_Right.Line.Weight = H.Line.Weight H_Splited_Right.Line.ForeColor = H.Line.ForeColor Set H_Splited_Left = H H_Splited_Left.Width = origin_point_x - radius * 2 - H_Splited_Left.Left End Sub Public Function Check() As Long On Error GoTo er: If Not V.Name Like "Straight Connector*" Then Check = ShapeTypeError ElseIf Not H.Name Like "Straight Connector*" Then Check = ShapeTypeError ElseIf V.Width > 0 Then Check = VerticalTiltError ElseIf H.Height > 0 Then Check = HolizontalTiltError Else Check = 0 End If If H.Left + H.Width < V.Left Then H.Width = V.Left + 2 * radius + 30 - H.Left End If Exit Function er: Check = UnidentifiedError End Function Public Sub ConnectShape() H_Splited_Left.ConnectorFormat.EndConnect HalfArc, 1 H_Splited_Right.ConnectorFormat.BeginConnect HalfArc, 3 End Sub
二本の線を選択し、「StepOver」を実行します。↓ 結果はこちらです。
今日は時間が無くなってしまったので、詳細は明日以降に。
参考まで。