趣味プログラミングblog

---

①ユーザーフォームのソース

Option Explicit

Private Sub AddNoButton_Click()
Call ポート番号加算(AddTextBox)
End Sub

Private Sub ClearNumberButton_Click()
Call ポート番号ClearNo

End Sub

Private Sub CommandButton1_Click()
Dim LineOpt As Long, DirOpt As Long, FigureOpt As Long
If OptionButton1.Value = True Then LineOpt = 1
If OptionButton2.Value = True Then LineOpt = 2

If OptionButton4.Value = True Then DirOpt = 1 '左右
If OptionButton6.Value = True Then DirOpt = 2 '上下
If OptionButton5.Value = True Then DirOpt = 3 '自動

If RadiationFlag.Value = True Then FigureOpt = 1 '放射
If PararelFlag.Value = True Then FigureOpt = 2 '並行

Call オートシェイプをコネクタで繋ぐ(LineOpt, DirOpt, FigureOpt)

End Sub

Private Sub CommandButton12_Click()
Me.Hide
'Unload Me
End Sub

Private Sub CommandButton13_Click()
Call ポート番号2nマイナス1

End Sub

Private Sub CommandButton14_Click()
Call ポート番号2nマイナス1戻し

End Sub

Private Sub CommandButton15_Click()
Call コネクタオブジェクトの接続リスト用リネーム
End Sub

Private Sub CommandButton16_Click()
'TextBoxPortName
If TextBoxPortName.Value = "" Then
MsgBox "設定する名称を入力ボックスに入れてください"
Exit Sub
End If
Call 機器名とポート名を設定(TextBoxPortName.Value)

End Sub

Private Sub CommandButton17_Click()

Call 機器名とポート名を設定
End Sub

'Private Sub CommandButton17_Click()
' Dim DirOpt As Long
' If OptionButton4.Value = True Then DirOpt = 1 '左右
' If OptionButton6.Value = True Then DirOpt = 2 '上下
' If OptionButton5.Value = True Then DirOpt = 3 '自動
' If OptionButton1.Value = True Then Call オートシェイプをコネクタで繋ぐ(1, DirOpt, 1)
' If OptionButton2.Value = True Then Call オートシェイプをコネクタで繋ぐ(2, DirOpt, 1)
'
'End Sub

Private Sub CommandButton2_Click()
Call 自動作成したコネクタを全削除

End Sub

Private Sub CommandButton3_Click()
Call つないだコネクタを消す

End Sub

Private Sub CommandButton4_Click()
Call コネクタ始点変更

End Sub

Private Sub CommandButton5_Click()
Call コネクタ終点変更

End Sub

Private Sub CommandButton6_Click()
Call ポート番号減算

End Sub

Private Sub CommandButton7_Click()
Call ポート番号加算

End Sub

Private Sub OptionButton7_Click()

End Sub

Private Sub OptionButton8_Click()

End Sub

Private Sub Set21Button_Click()
Call ポート番号21

End Sub

Private Sub Set45Button_Click()
Call ポート番号45

End Sub


Private Sub SetNoButton_Click()
Call ポート名設定(SetTextBox.Value)

End Sub

Private Sub SetUpNoButton_Click()
Call ポート番号set通番

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Click()

End Sub

---

②モジュールのコード
Option Explicit
Const adjustNum = 5 / 100 'アジャスタの分母　小さい方がずれる

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

Sub ViewShapeControllForm()
ShapeControllForm.Show vbModeless '・・・ モードレス表示 シート操作可能


End Sub

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

Dim slctshpCount As Long: slctshpCount = Selection.ShapeRange.Count
If slctshpCount < 2 Or VarType(Selection) <> vbObject Then
MsgBox "２つ以上のオートシェイプを選択してください。"
Exit Sub
End If

'LineOpt コネクタ形状オプション 1:直線 2:鍵式、3:カーブ
Dim ConstLineName As String
If LineOpt = 1 Then
ConstLineName = "myCn_" & "Straight "
ElseIf LineOpt = 2 Then
ConstLineName = "myCn_" & "Elbow "
ElseIf LineOpt = 3 Then
ConstLineName = "myCn_" & "Curve "
Else
End '規定外オプションは終了
End If


'FigureOpt 接続オプション 1:放射状（1->2,3,4,5,6) 2:パラレル(1->4,2->5,3->6)
If FigureOpt <> 1 And FigureOpt <> 2 Then
End '規定外オプションは終了
ElseIf FigureOpt = 2 And slctshpCount \ 2 = 1 Then
MsgBox "パラレル(1→4, 2→5, 3→6)で接続する場合は、偶数個指定してください"
End
End If

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

'-----------------------------------------------------------オプション開始
Dim stcPos As Long, edcPos As Long '上下スタイルか左右スタイルか
Dim ComShpNo As Long
If FigureOpt = 1 Then
ComShpNo = 2
Else
ComShpNo = 1 + slctshpCount / 2
End If

If DirectionOpt = 1 Then
If Selection.ShapeRange(ComShpNo).Top > Selection.ShapeRange(1).Top Then
stcPos = 3: edcPos = 1
Else
stcPos = 1: edcPos = 3
End If '上下スタイル終了
Else 'DirectionOpt = 2 (３はreconectするかどうか)
If Selection.ShapeRange(ComShpNo).Left > Selection.ShapeRange(1).Left Then
stcPos = 4: edcPos = 2
Else
stcPos = 2: edcPos = 4
End If '左右スタイル終了
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 shpArr() As Shape: ReDim shpArr(slctshpCount)
Dim cnt As Long, Shp As Shape
For Each Shp In Selection.ShapeRange
cnt = cnt + 1
Set shpArr(cnt) = Shp
Next Shp

Dim forEndCount As Long, NameArray() As String
If FigureOpt = 1 Then
forEndCount = slctshpCount
ReDim NameArray(slctshpCount - 2)
Else
forEndCount = slctshpCount / 2
ReDim NameArray(slctshpCount / 2 - 1)
End If

'コネクタを作っていく開始
Dim shp1 As Shape
For i = 1 To forEndCount
'cnt = cnt + 1
If FigureOpt = 1 And i = 1 Then
'Set shp1 = shp
ElseIf FigureOpt = 1 Or i <= slctshpCount / 2 Then
maxNum = maxNum + 1

'コネクタを作る
With ActiveSheet.Shapes.AddConnector(LineOpt, 0, 0, 0, 0) 'LineOpt　1:直線 2:鍵式、3:カーブ
'コネクタの色や太さを変更
.Line.EndArrowheadStyle = Con_arrowheadStyle
.Line.EndArrowheadLength = Con_arrowheadLength
.Line.EndArrowheadWidth = Con_arrowheadWidth
.Line.Weight = Con_LineWeight '太さ
.Line.ForeColor.RGB = RGB(Con_R, Con_G, Con_B) '光の三原色
.Line.Transparency = Con_Transparency '0.0 (不透明) ～ 1.0 (透明)
.Name = ConstLineName & maxNum

'シェイプ同士を繋ぐ 'コネクト位置　１：上、２：左、３：下、４：右
If FigureOpt = 1 Then
.ConnectorFormat.BeginConnect shpArr(1), stcPos '最初にクリックしたものから
.ConnectorFormat.EndConnect shpArr(i), edcPos '他のシェイプへ
NameArray(i - 2) = ConstLineName & maxNum
ElseIf FigureOpt = 2 And i <= slctshpCount / 2 Then
.ConnectorFormat.BeginConnect shpArr(i), stcPos '前半半分にクリックしたものから
.ConnectorFormat.EndConnect shpArr(i + slctshpCount / 2), edcPos '後半半分へ
NameArray(i - 1) = ConstLineName & maxNum
End If
If DirectionOpt = 3 Then .RerouteConnections '位置を自動判定

End With
End If
Next i

'Shape.Select [Replace:=True/False]
'http://blog.livedoor.jp/qoozy/archives/52567093.html

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




Sub コネクタ終点変更()
On Error Resume Next 'オブジェクトを選ばず使えるように
Dim Shp As Shape, EndShape As Shape, EndSite As Long

For Each Shp In Selection.ShapeRange
'If Left(shp.Name, 5) = "myCn_" Then
Set EndShape = Shp.ConnectorFormat.EndConnectedShape
EndSite = Shp.ConnectorFormat.EndConnectionSite
Shp.ConnectorFormat.EndConnect EndShape, EndSite Mod 4 + 1
' End If
Next Shp
End Sub
Sub コネクタ始点変更()
On Error Resume Next 'オブジェクトを選ばず使えるように
Dim Shp As Shape, BeginShape As Shape, BeginSite As Long

For Each Shp In Selection.ShapeRange
'If Left(shp.Name, 5) = "myCn_" Then
Set BeginShape = Shp.ConnectorFormat.BeginConnectedShape
BeginSite = Shp.ConnectorFormat.BeginConnectionSite
Shp.ConnectorFormat.BeginConnect BeginShape, BeginSite Mod 4 + 1
'End If
Next Shp
End Sub

Sub 負アジャストソート()
On Error Resume Next 'オブジェクトを選ばず使えるように
Dim Shp As Shape, i As Long

For Each Shp In Selection.ShapeRange
Shp.Adjustments.Item(1) = Shp.Adjustments.Item(1) - i * adjustNum
i = i + 1
Next Shp
End Sub

Sub 負アジャストバイアス()
On Error Resume Next 'オブジェクトを選ばず使えるように
Dim Shp As Shape, i As Long

For Each Shp In Selection.ShapeRange
Shp.Adjustments.Item(1) = Shp.Adjustments.Item(1) - 1 * adjustNum
i = i + 1
Next Shp
End Sub
Sub 正アジャストソート()
On Error Resume Next 'オブジェクトを選ばず使えるように
Dim Shp As Shape, i As Long

For Each Shp In Selection.ShapeRange
Shp.Adjustments.Item(1) = Shp.Adjustments.Item(1) + i * adjustNum
i = i + 1
Next Shp
End Sub
Sub 正アジャストバイアス()
On Error Resume Next 'オブジェクトを選ばず使えるように
Dim Shp As Shape, i As Long

For Each Shp In Selection.ShapeRange
Shp.Adjustments.Item(1) = Shp.Adjustments.Item(1) + 1 * adjustNum
i = i + 1
Next Shp
End Sub

Sub つないだコネクタを消す()
Dim maxNum As Long, tarNum As Long
Dim spPos As Long, shapeName As String, maxShape As Shape

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の最大値を探す
Set maxShape = ActiveSheet.Shapes(i)
End If
End If
Next i
If maxShape Is Nothing Then
Else
maxShape.Delete
End If
End Sub

Sub 自動作成したコネクタを全削除()
Dim i As Long, tarShape As Shape, BeginShape As Shape, EndShape As Shape
For i = ActiveSheet.Shapes.Count To 1 Step -1
Set tarShape = ActiveSheet.Shapes(i)

If Left(tarShape.Name, 5) = "myCn_" Then
tarShape.Delete
End If
Next i
End Sub


Sub ポート番号45()
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = 45
End If

End With
Next
End Sub
Sub ポート番号21()
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = 21
End If

End With
Next
End Sub

Sub ポート名設定(strPortName As String)
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = strPortName
End If

End With
Next
End Sub
Sub ポート番号加算(Optional aNum As Long = 1)
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = .TextFrame.Characters.Text + aNum
End If

End With
Next
End Sub
Sub ポート番号減算(Optional aNum As Long = 1)
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = .TextFrame.Characters.Text - aNum
End If
End With
Next
End Sub
Sub ポート番号2nマイナス1()
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = 2 * .TextFrame.Characters.Text - 1
End If
End With
Next
End Sub
Sub ポート番号2nマイナス1戻し()
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = (.TextFrame.Characters.Text + 1) / 2
End If
End With
Next
End Sub
Sub ポート番号set通番()
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
Dim cnt As Long
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
cnt = cnt + 1
.TextFrame.Characters.Text = cnt
End If
End With
Next
End Sub
Sub ポート番号ClearNo()
On Error Resume Next
Dim i As Long 'インデックス番号 、シェープループ変数
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If Len(.TextFrame.Characters.Text) < 4 Then
.TextFrame.Characters.Text = ""
End If
End With
Next
End Sub





Sub 機器名とポート名を設定(Optional objName As String)

' On Error GoTo ERR1
Dim strPort As String ', objName As String,
If objName = "" Then
objName = Selection.ShapeRange(1).TextFrame.Characters.Text
End If
Debug.Print objName


Dim RC As Long, i As Long 'インデックス番号 、シェープループ変数
Dim doubleNameFlag As Long '選択以外で名前を使われているか判定
For i = 1 To ActiveSheet.Shapes.Count 'シート内の名前をチェック
If ActiveSheet.Shapes(i).Name = objName Then doubleNameFlag = 1
Next i
For i = 1 To Selection.ShapeRange.Count '選択したオブジェクトの名前をチェック
If Selection.ShapeRange(i).Name = objName Then doubleNameFlag = 0
Next i
If doubleNameFlag = 1 Then
RC = MsgBox("入力した機器名は、すでに使用されています。実行しますか？", vbYesNo)
If RC = vbNo Then Exit Sub
End If
Dim j As Long: Const debugFlag = 1
For i = 1 To Selection.ShapeRange.Count '選択順 = i
With Selection.ShapeRange(i)
If i > 1 Then
strPort = Format(.TextFrame.Characters.Text, "00")
For j = 1 To ActiveSheet.Shapes.Count 'シート内の名前をチェック
If ActiveSheet.Shapes(i).Name = objName & "_" & strPort Then doubleNameFlag = 1
Next j
For j = 1 To Selection.ShapeRange.Count '選択したオブジェクトの名前をチェック
If Selection.ShapeRange(i).Name = objName & "_" & strPort Then doubleNameFlag = 0
Next j
If doubleNameFlag = 0 Or debugFlag = 1 Then
.Name = objName & "_" & strPort
Else
MsgBox "ポート名が重複したため停止します。" & Chr(10) & objName & "_" & strPort
Exit Sub
End If
Else 'i = 1 最初に機器オブジェクトを選択

.Name = objName
End If
End With
Next
Exit Sub
End Sub



Sub ChangeCellStyle(tRange As Range, Shp As Shape)

Dim myColor As Long
Dim LDS As Long: LDS = LDS2BL(Shp.Line.DashStyle)
Dim bw As Long
If LDS > 9 Then
bw = Int(LDS / 10)
LDS = LDS Mod 10
Else
bw = 0
End If
If Shp.TextFrame2.HasText Then
tRange = Shp.TextFrame2.TextRange.Text
tRange.Font.Color = Shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB
Else
tRange = "'-"
tRange = "'-"
End If

Call ChangeFillColor(tRange, Shp.Fill.ForeColor.RGB, Shp.Fill.Transparency)
If LDS = 3 Then LDS = -4115
If bw = 3 Then bw = -4138
Call ChangeBorderColor(tRange, Shp.Line.ForeColor.RGB, Shp.Line.Transparency, LDS, bw)
End Sub

Sub GetChangeColor(tRange As Range, myColor As Long) 'myColor = Shp.Fill.ForeColor.RGB
Dim R As Long: R = myColor Mod 256
Dim G As Long: G = Int(myColor / 256) Mod 256
Dim B As Long: B = Int(myColor / 256 / 256) Mod 256

tRange = "'(" & R & "," & G & "," & B & ")"

End Sub

Sub ChangeFillColor(tRange As Range, myColor As Long, Trnsprncy As Double) 'myColor = Shp.Fill.ForeColor.RGB
Dim R As Long: R = myColor Mod 256: R = R + (255 - R) * Trnsprncy
Dim G As Long: G = Int(myColor / 256) Mod 256: G = G + (255 - G) * Trnsprncy
Dim B As Long: B = Int(myColor / 256 / 256) Mod 256: B = B + (255 - B) * Trnsprncy
tRange.Interior.Color = RGB(R, G, B)
End Sub

Sub ChangeBorderColor(tRange As Range, myColor As Long, Trnsprncy As Double, BL As Long, bw As Long)
Dim R As Long: R = myColor Mod 256: R = R + (255 - R) * Trnsprncy
Dim G As Long: G = Int(myColor / 256) Mod 256: G = G + (255 - G) * Trnsprncy
Dim B As Long: B = Int(myColor / 256 / 256) Mod 256: B = B + (255 - B) * Trnsprncy
tRange.Borders.Color = RGB(R, G, B)
tRange.Borders.LineStyle = BL
If bw <> 0 Then tRange.Borders.Weight = bw
End Sub
Function LDS2BL(LDS As Long)

Select Case LDS
Case 1: LDS2BL = 1 '実線　xlContinuous/xlThin
Case 11: LDS2BL = 12 '点線 xlContinuous/xlHairline 2 11　薄い線　丸点線　 LDS2BL = 2 '点線

Case 10: LDS2BL = 2 '点線 3 10　四角点線　 LDS2BL = 2 '点線 xlDot/xlThin

Case 4: LDS2BL = 3 '破線 xlDash '-4115/xlThin
Case 5: LDS2BL = 4 '　一点鎖線 xlDashDot/xlThin


Case 7: LDS2BL = 33 ' 6 7　長破線 破線 xlDash/xlMedium
Case 8: LDS2BL = 34 '7 8　長一点鎖線 xlDashDot/xlMedium
Case 9: LDS2BL = 35 '8 9　長二点鎖線 xlDashDotDot/xlMedium
Case -2: LDS2BL = -4142 'なし
Case -4118: LDS2BL = 2 '点線
Case -4115: LDS2BL = 3 '破線
Case Else
Debug.Print "Case Else @ function LDS2BL ", "LDS=" & LDS
LDS2BL = -4142 'なし


End Select
'https://www.tipsfound.com/vba/07010
' 定数名 値 説明 例 Borders.LineStyle = xlContinuous
'xlContinuous 1 実線 1
'xlDash -4115 破線 2
'xlDashDot 4 一点鎖線 3
'xlDashDotDot 5 二点鎖線 4
'xlDot -4118 点線 5
'xlDouble -4119 二重線 6
'xlSlantDashDot 13 斜め斜線 7
'xlLineStyleNone -4142 なし

'定数名 値 説明 例　Borders.Weight = xlThin
'xlHairline 1 極細 8
'xlThin 2 細 9
'xlMedium -4138 中 10
'xlThick 4 太 11


'https://officedic.com/excel-vba-autoshape-line/
' DashStyleの定数一覧
'定数 値 説明
'msoLineSolid 1 実線
'msoLineSquareDot 2 点線 (角)
'msoLineRoundDot 3 点線 (丸)
'msoLineDash 4 破線
'msoLineDashDot 5 一点鎖線
'msoLineDashDotDot 6 二点鎖線
'msoLineLongDash 7 長破線
'msoLineLongDashDot 8 長鎖線


'
End Function
Sub コネクタオブジェクトの接続リスト用リネーム()
On Error Resume Next: Const debugFlag = 1

Worksheets("接続図").Select
Dim i As Long, tarShape As Shape, BeginName As String, EndName As String
Dim spPos As Long, shapeNum As Long, cnt As Long
Dim oWS As Worksheet: Set oWS = Worksheets("接続リスト")
oWS.Range("B3:D" & oWS.Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
For i = 1 To ActiveSheet.Shapes.Count
Set tarShape = ActiveSheet.Shapes(i)

If Left(tarShape.Name, 5) = "myCn_" Or debugFlag = 1 Then
BeginName = tarShape.ConnectorFormat.BeginConnectedShape.Name
EndName = tarShape.ConnectorFormat.EndConnectedShape.Name
If BeginName <> "" And EndName <> "" Then
cnt = cnt + 1
spPos = InStrRev(tarShape.Name, " "): shapeNum = Mid(tarShape.Name, spPos + 1, 4)
' tarShape.Name = "myCn_" & BeginName & "→" & EndName & " " & shapeNum
oWS.Cells(shapeNum + 2, "B") = cnt
oWS.Cells(shapeNum + 2, "C") = BeginName
oWS.Cells(shapeNum + 2, "D") = EndName
oWS.Cells(shapeNum + 2, "E") = tarShape.Name
Debug.Print i, tarShape.Name & ":「" & BeginName & " 」→「" & EndName & " 」"
End If
BeginName = "": EndName = ""
End If
Next i
oWS.Select
End Sub


Function strAutoShapeType(n As Long)
Select Case n
Case 1: strAutoShapeType = "四角形"
Case 2: strAutoShapeType = "平行四辺形"
Case 3: strAutoShapeType = "台形"
Case 4: strAutoShapeType = "ひし形"
Case 5: strAutoShapeType = "角丸四角形"
Case 6: strAutoShapeType = "八角形"
Case 7: strAutoShapeType = "二等辺三角形"
Case 8: strAutoShapeType = "直角三角形"
Case 9: strAutoShapeType = "楕円"
Case 10: strAutoShapeType = "六角形"
Case 11: strAutoShapeType = "十字形"
Case 12: strAutoShapeType = "ホームベース"
Case 13: strAutoShapeType = "円柱"
Case 14: strAutoShapeType = "直方体"
Case 15: strAutoShapeType = "斜角"
Case 16: strAutoShapeType = "メモ"
Case 17: strAutoShapeType = "スマイル"
Case 18: strAutoShapeType = "ドーナツ"
Case 19: strAutoShapeType = "禁止"
Case 20: strAutoShapeType = "アーチ"
Case 21: strAutoShapeType = "ハート"
Case 22: strAutoShapeType = "稲妻"
Case 23: strAutoShapeType = "太陽"
Case 24: strAutoShapeType = "月"
Case 25: strAutoShapeType = "円弧"
Case 26: strAutoShapeType = "大かっこ"
Case 27: strAutoShapeType = "中かっこ"
Case 28: strAutoShapeType = "ブローチ"
Case 29: strAutoShapeType = "左大かっこ"
Case 30: strAutoShapeType = "右大かっこ"
Case 31: strAutoShapeType = "左中かっこ"
Case 32: strAutoShapeType = "右中かっこ"
Case 33: strAutoShapeType = "右向きブロック矢印"
Case 34: strAutoShapeType = "左向きブロック矢印"
Case 35: strAutoShapeType = "上向きブロック矢印"
Case 36: strAutoShapeType = "下向きブロック矢印"
Case 37: strAutoShapeType = "左右ブロック矢印"
Case 38: strAutoShapeType = "上下 2 方向ブロック矢印"
Case 39: strAutoShapeType = "4 方向ブロック矢印"
Case 40: strAutoShapeType = "左、右、および上の 3 方向ブロック矢印"
Case 41: strAutoShapeType = "90°の曲線に続くブロック矢印"
Case 42: strAutoShapeType = "U 字型のブロック矢印"
Case 43: strAutoShapeType = "左および上矢印の 2 方向ブロック矢印"
Case 44: strAutoShapeType = "90°の鋭角線に続くブロック矢印既定では上向きです"
Case 45: strAutoShapeType = "右カーブ ブロック矢印"
Case 46: strAutoShapeType = "左カーブ ブロック矢印"
Case 47: strAutoShapeType = "上カーブ ブロック矢印"
Case 48: strAutoShapeType = "下カーブ ブロック矢印"
Case 49: strAutoShapeType = "先にストライプの付いた右向きのブロック矢印"
Case 50: strAutoShapeType = "右向きの V 字型矢印"
Case 51: strAutoShapeType = "ホームベース"
Case 52: strAutoShapeType = "山形"
Case 53: strAutoShapeType = "右矢印の付いた吹き出し"
Case 54: strAutoShapeType = "左矢印の付いた吹き出し"
Case 55: strAutoShapeType = "上矢印の付いた吹き出し"
Case 56: strAutoShapeType = "下矢印の付いた吹き出し"
Case 57: strAutoShapeType = "左右矢印の付いた吹き出し"
Case 58: strAutoShapeType = "上下のブロック矢印の付いた吹き出し"
Case 59: strAutoShapeType = "4 方向矢印の付いた吹き出し"
Case 60: strAutoShapeType = "180°の曲線に続くブロック矢印"
Case 61: strAutoShapeType = "フローチャート　処理"
Case 62: strAutoShapeType = "フローチャート　代替処理"
Case 63: strAutoShapeType = "フローチャート　判断"
Case 64: strAutoShapeType = "フローチャート　データ"
Case 65: strAutoShapeType = "フローチャート　定義済み処理"
Case 66: strAutoShapeType = "フローチャート　内部記憶"
Case 67: strAutoShapeType = "フローチャート　書類"
Case 68: strAutoShapeType = "フローチャート　複数書類"
Case 69: strAutoShapeType = "フローチャート　端子"
Case 70: strAutoShapeType = "フローチャート　準備"
Case 71: strAutoShapeType = "フローチャート　手操作入力"
Case 72: strAutoShapeType = "フローチャート　手作業"
Case 73: strAutoShapeType = "フローチャート　結合子"
Case 74: strAutoShapeType = "フローチャート　他ページ結合子"
Case 75: strAutoShapeType = "フローチャート　カード"
Case 76: strAutoShapeType = "フローチャート　せん孔テープ"
Case 77: strAutoShapeType = "フローチャート　和接合"
Case 78: strAutoShapeType = "フローチャート　論理和"
Case 79: strAutoShapeType = "フローチャート　照合"
Case 80: strAutoShapeType = "フローチャート　分類"
Case 81: strAutoShapeType = "フローチャート　抜き出し"
Case 82: strAutoShapeType = "フローチャート　組み合わせ"
Case 83: strAutoShapeType = "フローチャート　記憶データ"
Case 84: strAutoShapeType = "フローチャート　論理積ゲート"
Case 85: strAutoShapeType = "フローチャート　順次アクセス記憶"
Case 86: strAutoShapeType = "フローチャート　磁気ディスク"
Case 87: strAutoShapeType = "フローチャート　直接アクセス記憶"
Case 88: strAutoShapeType = "フローチャート　表示"
Case 89: strAutoShapeType = "爆発 1"
Case 90: strAutoShapeType = "爆発 2"
Case 91: strAutoShapeType = "星 4"
Case 92: strAutoShapeType = "星 5"
Case 93: strAutoShapeType = "星 8"
Case 94: strAutoShapeType = "星 16"
Case 95: strAutoShapeType = "星 24"
Case 96: strAutoShapeType = "星 32"
Case 97: strAutoShapeType = "リボンの端よりも上に中央面があるリボン"
Case 98: strAutoShapeType = "リボンの端よりも下に中央面があるリボン"
Case 99: strAutoShapeType = "上カーブリボン"
Case 100: strAutoShapeType = "下カーブ リボン"
Case 101: strAutoShapeType = "縦巻き"
Case 102: strAutoShapeType = "横巻き"
Case 103: strAutoShapeType = "大波"
Case 104: strAutoShapeType = "小波"
Case 105: strAutoShapeType = "四角形吹き出し"
Case 106: strAutoShapeType = "角丸四角形吹き出し"
Case 107: strAutoShapeType = "円形吹き出し"
Case 108: strAutoShapeType = "雲形吹き出し"
Case 109: strAutoShapeType = "枠付きで、水平の吹き出し線の付いた吹き出し"
Case 110: strAutoShapeType = "斜めの直線の付いた吹き出し"
Case 111: strAutoShapeType = "折れ線の付いた吹き出し"
Case 112: strAutoShapeType = "U 字型の吹き出し線分の付いた吹き出し"
Case 113: strAutoShapeType = "水平の強調線の付いた吹き出し"
Case 114: strAutoShapeType = "斜めの吹き出し線と強調線の付いた吹き出し"
Case 115: strAutoShapeType = "折れた吹き出し線と強調線の付いた吹き出し"
Case 116: strAutoShapeType = "強調線および U 字型の吹き出し線分の付いた吹き出し"
Case 117: strAutoShapeType = "水平線の付いた吹き出し"
Case 118: strAutoShapeType = "枠および斜めの吹き出し線のない吹き出し"
Case 119: strAutoShapeType = "枠および折れた吹き出し線のない吹き出し"
Case 120: strAutoShapeType = "枠線および U 字型の吹き出し線分のない呼び出し"
Case 121: strAutoShapeType = "枠付きで、水平の強調線の付いた吹き出し"
Case 122: strAutoShapeType = "枠、斜めの直線、および強調線の付いた吹き出し"
Case 123: strAutoShapeType = "枠、折れた吹き出し線、強調線の付いた吹き出し"
Case 124: strAutoShapeType = "枠線、強調線、および U 字型の吹き出し線分の付いた吹き出し"
Case 125: strAutoShapeType = "既定の画像またはテキストのないボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 126: strAutoShapeType = "[ホーム] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 127: strAutoShapeType = "[ヘルプ] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 128: strAutoShapeType = "[情報] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 129: strAutoShapeType = "[戻る] または [前へ] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 130: strAutoShapeType = "[進む] または [次へ] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 131: strAutoShapeType = "[上旬] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 132: strAutoShapeType = "[終了] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 133: strAutoShapeType = "[戻る] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 134: strAutoShapeType = "[文書] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 135: strAutoShapeType = "[サウンド] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 136: strAutoShapeType = "[ビデオ] ボタンマウスクリックおよびマウスオーバー動作をサポートします"
Case 137: strAutoShapeType = "吹き出し"
Case 138: strAutoShapeType = "サポートされません"
Case 139: strAutoShapeType = "オフラインの記憶フローチャート記号"
Case 140: strAutoShapeType = "リボンの両端に矢印の付いた"
Case 141: strAutoShapeType = "四角形に 2 つの三角形図形を削除します斜めのストライプ"
Case 142: strAutoShapeType = "円 (円) で不足している部分です"
Case 143: strAutoShapeType = "非対称非平行辺の台形を塗りつぶす"
Case 144: strAutoShapeType = "Decagon"
Case 145: strAutoShapeType = "七角形です"
Case 146: strAutoShapeType = "Dodecagon"
Case 147: strAutoShapeType = "6 ポイントの星型です"
Case 148: strAutoShapeType = "7 番ポイントの星型です"
Case 149: strAutoShapeType = "10 ポイントの星型です"
Case 150: strAutoShapeType = "12 ポイントの星型です"
Case 151: strAutoShapeType = "1 つの丸い角を持つ四角形"
Case 152: strAutoShapeType = "2 つの丸められた角の辺を共有する四角形"
Case 154: strAutoShapeType = "スニペットの角の 1 つと 1 つの丸い角を持つ四角形"
Case 155: strAutoShapeType = "スニペットのいずれかの角を持つ四角形"
Case 156: strAutoShapeType = "辺を共有する 2 つのスニペットの角を持つ四角形"
Case 157: strAutoShapeType = "斜めにではなく、2 つの丸い角を持つ四角形"
Case 157: strAutoShapeType = "斜めにではなく、2 つのスニペット角を持つ四角形"
Case 158: strAutoShapeType = "長方形の画像フレーム"
Case 159: strAutoShapeType = "四角形の図枠の半分です"
Case 160: strAutoShapeType = "ドロップレットの水"
Case 161: strAutoShapeType = "円は、円の内部を外周上の 2 点を結ぶ直線弦を持つ円"
Case 162: strAutoShapeType = "四角形の穴を持つ四角形"
Case 163: strAutoShapeType = "加算記号 ‘＋’"
Case 164: strAutoShapeType = "減算記号 ‘－’"
Case 165: strAutoShapeType = "乗算記号 ‘×’"
Case 166: strAutoShapeType = "除算記号 ‘÷’"
Case 167: strAutoShapeType = "等価性の記号 ‘ =’ です"
Case 168: strAutoShapeType = "非等価記号 ‘≠’ です"
Case 169: strAutoShapeType = "4 つの右の三角形が四角形のパスに沿って整列4 つの ‘スニペット’ 角"
Case 170: strAutoShapeType = "4 小さい正方形、四角形を定義します"
Case 171: strAutoShapeType = "4 四半期の円、四角形を定義します"
Case 172: strAutoShapeType = "六つの歯の装置です"
Case 173: strAutoShapeType = "9 つの歯の装置"
Case 174: strAutoShapeType = "Funnel"
Case 175: strAutoShapeType = "円の図形の四半期です"
Case 176: strAutoShapeType = "円形矢印反時計回りに"
Case 177: strAutoShapeType = "円形矢印時計回りと反時計回りに両方の端点と曲線の矢印です"
Case 178: strAutoShapeType = "曲線の矢印です"
Case 179: strAutoShapeType = "雲の形です"
Case 180: strAutoShapeType = "正方形は対角線に沿って 4 つの部分に分割されます"
Case 181: strAutoShapeType = "垂直および斜めの線に沿って、6 つの部分を四角形に分割されます"
Case 182: strAutoShapeType = "正方形は 4 つの四半期に垂直方向と水平方向に分かれています"
Case 183: strAutoShapeType = "行を反転します"
Case -2: strAutoShapeType = "戻り値のみ他の状態の組み合わせを指定します"

End Select
End Function