趣味プログラミングblog

---

Sub オートシェイプを直線で繋ぐ()
オートシェイプをコネクタで繋ぐ (1)
End Sub
Sub オートシェイプを鍵線で繋ぐ()
オートシェイプをコネクタで繋ぐ (2)
End Sub
Sub オートシェイプを曲線で繋ぐ()
オートシェイプをコネクタで繋ぐ (3)
End Sub


Sub オートシェイプをコネクタで繋ぐ(ConnectorOpt As Long)

'ConnectorOpt コネクタ形状オプション 1:直線 2:鍵式、3:カーブ
If ConnectorOpt <> 1 And ConnectorOpt <> 2 And ConnectorOpt <> 3 Then
End '規定外オプションは終了
End If

On Error GoTo ERR1 'オブジェクト未選択対策

'-----------------------------------------------------------オプション開始
Dim stcPos As Long, edcPos As Long '上下スタイルか左右スタイルか
If Selection.ShapeRange(2).Top > Selection.ShapeRange(1).Top Then
stcPos = 3: edcPos = 1
Else
stcPos = 1: edcPos = 3
End If '上下スタイル終了

' If Selection.ShapeRange(2).Left > Selection.ShapeRange(1).Left Then
' stcPos = 4: edcPos = 2
' Else
' stcPos = 2: edcPos = 4
' End If '左右スタイル終了

'コネクタスタイル
Const Con_arrowheadStyle = 1 '1:矢印なし, 2:三角矢印, 3:開いた矢印, 4:鋭い矢印, 5:ひし型, 6:円形矢印
Const Con_arrowheadLength = 2 '1:短い, 2:普通, 3:広い
Const Con_arrowheadWidth = 1
Const Con_LineWeight = 3 '太さ
Const Con_R = 0: Const Con_G = 0: Const Con_B = 0 'RGB(0, 0, 0) '光の三原色
Const Con_Transparency = 0 ' .Line.Transparency = 0 '0.0 (不透明) ～ 1.0 (透明)

'-----------------------------------------------------------オプション終了

'まず、コネクタ名の開始番号をチェック
Dim maxNum As Long, tarNum As Long
Dim spPos As Long, shapeName As String

Dim i As Long
For i = 1 To ActiveSheet.Shapes.Count 'シート内の名前をチェック
shapeName = ActiveSheet.Shapes(i).Name
If Left(shapeName, 5) = "myCn_" Then
spPos = InStrRev(shapeName, " ")
tarNum = Mid(shapeName, spPos + 1, 4)
If tarNum > maxNum Then maxNum = tarNum 'tarnumの最大値を探す
End If
Next i
Debug.Print "maxNum=" & maxNum


Dim cnt As Long 'インデックス番号
cnt = Selection.ShapeRange.Count 'まず選択中のシェイプを選択した順に取得（何もしなくても選択順になる）
If cnt < 2 Then
MsgBox "２つ以上のオートシェイプを選択してください。"
Exit Sub
End If


Dim NameArray() As String
ReDim NameArray(cnt - 2)

'コネクタを作っていく開始
Dim shp As Shape, shpCnt As Long, shp1 As Shape
For Each shp In Selection.ShapeRange
shpCnt = shpCnt + 1
If shpCnt > 1 Then
maxNum = maxNum + 1
'コネクタを作る
With ActiveSheet.Shapes.AddConnector(ConnectorOpt, 0, 0, 0, 0) 'ConnectorOpt　1:直線 2:鍵式、3:カーブ
'コネクタの色や太さを変更
.Line.EndArrowheadStyle = Con_arrowheadStyle
.Line.EndArrowheadLength = Con_arrowheadLength
.Line.EndArrowheadWidth = Con_arrowheadWidth
'.Line.Visible = msoTrue '非表示にはしないでしょ
.Line.Weight = Con_LineWeight '太さ
.Line.ForeColor.RGB = RGB(Con_R, Con_G, Con_B) '光の三原色
.Line.Transparency = Con_Transparency '0.0 (不透明) ～ 1.0 (透明)

'シェイプ同士を繋ぐ
.ConnectorFormat.BeginConnect shp1, stcPos '最初にクリックしたものから
.ConnectorFormat.EndConnect shp, edcPos '他のシェイプへ
'コネクト位置　１：上、２：左、３：下、４：右
'.RerouteConnections '位置を自動判定
.Name = "myCn_" & "Straight " & maxNum
NameArray(shpCnt - 2) = "myCn_" & "Straight " & maxNum
End With
Else
Set shp1 = shp
End If
Next

ActiveSheet.Shapes(NameArray(0)).Select Replace:=True
For i = 1 To UBound(NameArray)
ActiveSheet.Shapes(NameArray(i)).Select Replace:=False
Next i
Exit Sub

ERR1:
MsgBox "２つ以上のオートシェイプを選択してください。"

End Sub