ものづくり：スケジュール表、ステップ4の前に 苦戦続く

　こんにちは、Dancing Shigekoです！

　昨日に続き、テキストボックス同士を繋ぐ挑戦。→昨日のトライ

　矢印を表示させるプログラムを入れてみた。

---

Dim tbNames As Collection

Private Sub Worksheet_Change(ByVal Target As Range)

Dim txt As String

Dim tb As Shape

Dim arrow As Shape

Dim tempShape As Shape

Dim tempWidth As Double

Dim tempHeight As Double

Dim padding As Double

Dim cell As Range

Dim tbName As String

Dim rowNum As Long

Dim colA As Long, colB As Long, colC As Long

Dim NewSheet As Worksheet

' パディングを設定

padding = 10

' A1, A2の変更を監視

If Not Intersect(Target, Me.Columns("A:D")) Is Nothing Then

' 新しいシートを作成または取得

On Error Resume Next

Set NewSheet = ThisWorkbook.Sheets("TextBoxSheet")

On Error GoTo 0

If NewSheet Is Nothing Then

Set NewSheet = ThisWorkbook.Sheets.Add

NewSheet.Name = "TextBoxSheet"

' 罫線を消す

NewSheet.Cells.Borders.LineStyle = xlNone

End If

' テキストボックスの名前を保持するコレクションを初期化

Set tbNames = New Collection

For Each cell In Target

' テキストボックスの名前を設定

tbName = "MyTextBox" & cell.row

' テキストボックスが存在するか確認

On Error Resume Next

Set tb = NewSheet.Shapes(tbName)

On Error GoTo 0

' テキストボックスが存在しない場合は作成

If tb Is Nothing Then

Set tb = NewSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100 + (cell.row - 1) * 100, 200, 50)

tb.Name = tbName

End If

' セルの行番号と列番号を取得

rowNum = cell.row

colA = 1

colB = 2

colC = 3

' セルの内容を取得してテキストボックスに設定

txt = Me.Cells(rowNum, colA).Value & vbCrLf & Me.Cells(rowNum, colB).Value & vbCrLf & Me.Cells(rowNum, colC).Value

tb.TextFrame.Characters.text = txt

' 一時的なテキストボックスを作成してサイズを計算

Set tempShape = Me.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)

tempShape.TextFrame.Characters.text = txt

tempShape.TextFrame.AutoSize = True

tempWidth = tempShape.Width

tempHeight = tempShape.Height

tempShape.Delete

' テキストボックスのサイズを設定

tb.Width = tempWidth + padding

tb.Height = tempHeight + padding

' テキストボックスの名前をコレクションに追加

tbNames.Add tbName

Next cell

' 矢印の作成と接続

If Me.Range("D2").Value = 1 Then

Dim i As Integer

For i = 1 To tbNames.Count - 1

Dim tb1 As Shape

Dim tb2 As Shape

Set tb1 = NewSheet.Shapes(tbNames(i))

Set tb2 = NewSheet.Shapes(tbNames(i + 1))

' 矢印の作成

Set arrow = NewSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0)

arrow.Name = "Arrow" & i

' 矢印の接続

arrow.ConnectorFormat.BeginConnect tb1, 2 ' 2は右側

arrow.ConnectorFormat.EndConnect tb2, 4 ' 4は左側

arrow.RerouteConnections

Next i

End If

End If

End Sub

---

　そして実行。

　ところが・・・さらに文字列を入れていき、D2に繋ぐ関係を示す数値を入力。

　矢印は現れない。

　どこを直すのが良いのか。

　挑戦は続く。

　乞うご期待！