こんにちは、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に繋ぐ関係を示す数値を入力。
矢印は現れない。
どこを直すのが良いのか。
挑戦は続く。
乞うご期待！
Comments