厳密に言うと(言わなくても:D)やっぱり Shape を繋ぐのだが。
誰も昨日のが前フリだとは思わなかったに違いない...私もだけど。
今日のは Sheet モジュールに置いて、BeforeDoubleClick イベントで起動。
直線コネクタを軌跡の替わりにしてセルとセルを繋ぐ...
ように見せかけてセルに被せた Rectangle を Connect してみるのである。
仮の直線コネクタの始点をポイントするために、Win32API の mouse_event を使ってます。
コメントにも書いてますが本来は SendInput を使うのが望ましいみたい。
とりあえず簡易版で。
軌跡用に直線コネクタを使ったのは、Line だとクリック&ドラッグでの描画になるのに対し、クリック&ムーブ&クリックで描画できるからなのです。
でも、もしかして『 Zoom の拡大率によってはドラッグしないといけない時もある』というようなバグが潜んでる?
そんな情報あったっけっかなぁ...
あと、隣接するセル同士をコネクトするとちとヘンです。
RerouteConnections メソッドを使ってるからなのでしょうけど。
解消するにはもうひと工夫必要みたいですね...。でも、それほど実用的とも思えないのでとりあえずこの辺りで :D
誰も昨日のが前フリだとは思わなかったに違いない...私もだけど。
今日のは Sheet モジュールに置いて、BeforeDoubleClick イベントで起動。
直線コネクタを軌跡の替わりにしてセルとセルを繋ぐ...
ように見せかけてセルに被せた Rectangle を Connect してみるのである。
仮の直線コネクタの始点をポイントするために、Win32API の mouse_event を使ってます。
コメントにも書いてますが本来は SendInput を使うのが望ましいみたい。
とりあえず簡易版で。
'SheetModule Option Explicit Private Declare Sub mouse_event Lib "user32.dll" ( _ ByVal dwFlags As Long, _ ByVal dx As Long, _ ByVal dy As Long, _ ByVal cButtons As Long, _ ByVal dwExtraInfo As Long) Private Declare Function GetAsyncKeyState Lib "user32.dll" ( _ ByVal vKey As Long) As Long Private Const MOUSEEVENTF_LEFTUP = &H4 Private Const MOUSEEVENTF_LEFTDOWN = &H2 Private Const VK_LBUTTON = &H1 '------------------------------------------------- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim rEnd As Range '終点セル Dim flg As Boolean 'マウスクリック判定 Dim msg As String 'メッセージ用 Dim i As Long Cancel = True '直線コネクタを使ってマウスの軌跡線にしてみた CommandBars.FindControl(ID:=1042).accDoDefaultAction '簡易的なもの。推奨はSendInput(?) Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0) Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0) '本来はDo Loopでいいはずなのだが... For i = 1 To 1000 DoEvents flg = (GetAsyncKeyState(VK_LBUTTON) < 0&) If flg Then Exit For Next '終点セルのセット With Me.Shapes With .Item(.Count) If flg Then If .VerticalFlip Then If .HorizontalFlip Then Set rEnd = .TopLeftCell Else Set rEnd = Me.Cells(.TopLeftCell.Row, _ .BottomRightCell.Column) End If Else If .HorizontalFlip Then Set rEnd = Me.Cells(.BottomRightCell.Row, _ .TopLeftCell.Column) Else Set rEnd = .BottomRightCell End If End If End If .Delete End With End With If flg Then '起点セル,終点セルを元にShape描画 Call spConnect(Target, rEnd) Else 'バグがありそうなのでその対策。 With ActiveWindow If .Zoom > 100 Then .Zoom = 100 msg = " with Zoom 100" End If End With MsgBox "Retry" & msg End If Set rEnd = Nothing End Sub '------------------------------------------------- Private Sub spConnect(ByRef rBgn As Range, ByRef rEnd As Range) Dim sp(2) As Shape Dim i As Long With Me.Shapes '起点セル Set sp(0) = .AddShape(msoShapeRectangle, _ rBgn.Left, rBgn.Top, rBgn.Width, rBgn.Height) '終点セル Set sp(1) = .AddShape(msoShapeRectangle, _ rEnd.Left, rEnd.Top, rEnd.Width, rEnd.Height) 'カギ線コネクタ Set sp(2) = .AddConnector(msoConnectorElbow, 0, 0, 0, 0) End With For i = 0 To 1 With sp(i) .Fill.Visible = msoFalse .Placement = xlMoveAndSize .Line.Weight = 1 .Line.ForeColor.RGB = vbBlue End With Next With sp(2) With .ConnectorFormat .BeginConnect sp(0), 4 .EndConnect sp(1), 2 End With .Line.Weight = 1 .Line.ForeColor.RGB = vbBlue '最短経路で再接続 .RerouteConnections End With Set sp(0) = Nothing Set sp(1) = Nothing Set sp(2) = Nothing End Sub
軌跡用に直線コネクタを使ったのは、Line だとクリック&ドラッグでの描画になるのに対し、クリック&ムーブ&クリックで描画できるからなのです。
でも、もしかして『 Zoom の拡大率によってはドラッグしないといけない時もある』というようなバグが潜んでる?
そんな情報あったっけっかなぁ...
あと、隣接するセル同士をコネクトするとちとヘンです。
RerouteConnections メソッドを使ってるからなのでしょうけど。
解消するにはもうひと工夫必要みたいですね...。でも、それほど実用的とも思えないのでとりあえずこの辺りで :D