Add arrow to middle of connector?

[JuneTheSecond]

You need to move arrow on the connector back or forth, when connectors are crossing each other.
Here is adjustable arrow on connector.
Right click menu on a connector moves arrow back or forth, and resets to the center.

[JuneTheSecond]

You might need more functionality, when one segment is too long.
You wish to move arrow on one segment back and forth.
Here added menues "Back on Segment", and so on.

[JuneTheSecond]

If you need more quick access to arrow on connecotor,
please, enable VBA macro and press direct shortcut keys.

[Jumpy]

Hello June,

very nice solution, that makes me rethink, what I have done in my solution. Maybe I generate sth. new of both ways, when there's time, because I'm not satisfied with the current version.

I used a filled triangle shape (my "arrowhead"), which calls a makro on drop, to see, if the arrow is placed on a certain type of connector ("Leitung"). It then turns the arrowhead in the right direction and places it in the centre of the connector segment it was droped on. It is still a separate shape, so when moving the connector the arrowhead stays behind. Therefore it is only used in the final stages of a drawing, when the layout is complete. The reason, why I stay with an extra shape (not grouped to the connector) is that I can move the shape slightly afterwards if neccessary and align it with a arrowhead on a connector that runs parallel(?alongside?) the first connector. Also I can place more than one arrowhead on the same path segment (if it's a long one that may become neccessary).

Here's the code I use for this. Maybe someone gets an idea:

Code Select Expand


Public Sub Pfeil_Drop(dropee As Visio.Shape)
'*********************************************************
'* Drop Makro für Arrow-Heads                            *
'* Startet from Callthis-Fkt. in Arrowhead-Shape         *
'* Makro only tests, if arrowhead is droped on connector *
'* ("Leitung"). If yes is starts a further makro         *
'*********************************************************
Dim shp As Visio.Shape
On Error Resume Next
For Each shp In ActivePage.Shapes
If shp.DistanceFrom(dropee, 0) <= 0 And shp <> dropee Then         'Hit
  If shp.CellExists("User.Typ", False) Then
   If shp.Cells("User.Typ").ResultStr(0) = "Leitung" Then
    Pfeil_Leitung dropee, shp
    Exit Sub
   End If
  End If
End If
Next

End Sub

Public Sub Pfeil_Leitung(ByVal Pfeil As Visio.Shape, ByVal Leitung As Visio.Shape, Optional Range As Integer = 2)
'******************************************************
'* Makro for arrowhead placement on connector segment *
'* Startet from Makro Pfeil_Drop                      *
'******************************************************

Dim vsoShape As Visio.Shape
Dim adblXYPoints() As Double
Dim strPointsList As String
Dim intOuterLoopCounter As Integer
Dim intInnerLoopCounter, Pfadsegment, Segmentanzahl, a, b, i As Integer
Dim X(50), Y(50), PX, PY As Double

Pfadsegment = 0
PX = Pfeil.Cells("PinX").Result("MM")
PY = Pfeil.Cells("PinY").Result("MM")

'Here the points along the path are sored in X(i)/Y(i) Variables
'---------------------------------------------------------------------------------------
    Set vsoShape = Leitung
    For intOuterLoopCounter = 1 To vsoShape.Paths.Count

        vsoShape.Paths(intOuterLoopCounter).Points 0.5, adblXYPoints
        a = 1
        b = 1
        For intInnerLoopCounter = LBound(adblXYPoints) To UBound(adblXYPoints)
            If a Mod 2 = 1 Then
             X(b) = (adblXYPoints(intInnerLoopCounter) * 25.4)
            Else
             Y(b) = (adblXYPoints(intInnerLoopCounter) * 25.4)
             b = b + 1
            End If
            strPointsList = strPointsList & a & ": " & (adblXYPoints(intInnerLoopCounter) * 25.4) & Chr(10)
            a = a + 1
        Next intInnerLoopCounter
    If Trim(X(1)) = Trim(Leitung.Cells("BeginX").Result("MM")) And Trim(Y(1)) = Trim(Leitung.Cells("BeginY").Result("MM")) Then
     intOuterLoopCounter = vsoShape.Paths.Count
    End If
    Next intOuterLoopCounter
       
Segmentanzahl = b - 2
'---------------------------------------------------------------------------------------


'Now analyse, on witch segment of the connector the arrowhead was droped
'---------------------------------------------------------------------------------------
For i = 1 To Segmentanzahl
If X(i + 1) - X(i) = 0 Then                        'vertical Segment
If PX > X(i) - Range And PX < X(i) + Range Then   'Test if arrowhead on X coordinate
  If Y(i + 1) - Y(i) > 0 Then                      'Direction "up"
   If PY < Y(i + 1) And PY > Y(i) Then             'arrowhead in Y Intervall
    Pfadsegment = i
    i = Segmentanzahl
   End If
  ElseIf Y(i + 1) - Y(i) < 0 Then                  'Direction "down"
   If PY > Y(i + 1) And PY < Y(i) Then             'arrowhead in Y Intervall
    Pfadsegment = i
    i = Segmentanzahl
   End If
  Else
  'Nix tun
  End If
End If
ElseIf Y(i + 1) - Y(i) = 0 Then                    'horizontal Segment
If PY > Y(i) - Range And PY < Y(i) + Range Then   'Test if arrowhead on Y coordinate
  If X(i + 1) - X(i) > 0 Then                      'Direction "right"
   If PX < X(i + 1) And PX > X(i) Then             'arrowhead in X Intervall
    Pfadsegment = i
    i = Segmentanzahl
   End If
  ElseIf X(i + 1) - X(i) < 0 Then                  'Direction "left"
   If PX > X(i + 1) And PX < X(i) Then             'arrowhead in X Intervall
    Pfadsegment = i
    i = Segmentanzahl
   End If
  Else
  'Nix tun
  End If
End If
Else                                       'Diagonales Segment
'is ignored, but could be captured
End If
Next i
'---------------------------------------------------------------------------------------

'Now place arrowhead in the middle of the Pathsegment (in the right direction)
'---------------------------------------------------------------------------------------
If Pfadsegment = 0 Then Exit Sub '...oder auch nicht ;-)

If X(Pfadsegment) - X(Pfadsegment + 1) = 0 Then     'vertical Segment
Pfeil.Cells("PinX").Result("MM") = X(Pfadsegment)
  Pfeil.Cells("PinY").Result("MM") = Y(Pfadsegment) + (Y(Pfadsegment + 1) - Y(Pfadsegment)) / 2
  If Y(Pfadsegment + 1) - Y(Pfadsegment) > 0 Then   'up
   Pfeil.Cells("Angle").Result("deg") = 0
  Else                                              'down
   Pfeil.Cells("Angle").Result("deg") = 180
  End If
Else                                                'horizontal Segment
Pfeil.Cells("PinY").Result("MM") = Y(Pfadsegment)
  Pfeil.Cells("PinX").Result("MM") = X(Pfadsegment) + (X(Pfadsegment + 1) - X(Pfadsegment)) / 2
  If X(Pfadsegment + 1) - X(Pfadsegment) > 0 Then   'right
   Pfeil.Cells("Angle").Result("deg") = -90
  Else                                              'left
   Pfeil.Cells("Angle").Result("deg") = 90
  End If
End If

'Give it the right color based on temperature (interesting only for my solution)
Pfeil.Cells("Prop.Temperatur").Result("") = Leitung.Cells("Prop.Temperatur").Result("")

'---------------------------------------------------------------------------------------

End Sub