Connector length

[Jason F.]

Visio2007. Line connector based upon the dynamic connector.

I am using the line connector to "trace" a cable path for cables in a
datacenter. I'd like to get the length of the cable, but the size/position
window reports the length in straight line distance between the two
endpoints, not the sum of each segment.

I played with the shape sheet a little, and can cause a sum of the segments
using scratch cells, and I don't see how to "dynamically" add scratch entries
based upon the number of lines in the geometry section.

Lots and lots of connectors would make opening each shape sheet tedious.
What I'd like is for the text for the conneotr to display the sum of the
segments.

I do have a "box" shape that displays the "length" by inserting the
geometry/length field, this doesn't work as the length is point-point, not
the sum of segments. What formula could I use to insert into the custom
forumla dialog box when inserting a field in the connector's text box?

Sorry for the randomness,

Jason.

 

[AlEdlund]

It can be done with code (a macro is below). There is a visio function
available (lengthiu).
hth,
al


Sub Macro1()

Dim vsoPage As Visio.Page
Dim vsoShape As Visio.Shape
Dim strText As String
Dim UndoScopeID1 As Long

UndoScopeID1 = Application.BeginUndoScope("Manual select")

Set vsoPage = Visio.ActivePage
For Each vsoShape In vsoPage.Shapes
' if the shape has a beginx cell then it is 1d and probably a line
' or connector
If vsoShape.CellExists("beginx", False) Then
If vsoShape.Text = "" Then
strText = vsoShape.NameU
Else
strText = vsoShape.Text
End If
'
strText = strText & " is " & ComputeLineLength(vsoShape) & " ft
long"
MsgBox strText
Dim vsoCell As Visio.Cell
If vsoShape.CellExists("prop.CableLength", False) Then
Set vsoCell = vsoShape.Cells("prop.cablelength")
strText = CStr(vsoShape.LengthIU)
vsoCell.Formula = strText
End If
End If

Next vsoShape

Application.EndUndoScope UndoScopeID1, True

End Sub

Public Function ComputeLineLength(ByVal shpObj As Visio.Shape) As
Double

Dim lngBaseX As Double
Dim lngBaseY As Double
Dim lngNewX As Double
Dim lngNewY As Double
Dim deltaX As Double
Dim deltaY As Double
Dim lngLength As Double
Dim intCurrGeomSect As Integer
Dim intCtr As Integer
Dim intSects As Integer
Dim intRows As Integer

On Error GoTo CatchError

' assign lengthiu to working length
lngLength = shpObj.LengthIU
' if not equal zero (i.e. not a point) then
' the v2003 bug is fixed
If lngLength <> 0 Then
' remembering that internal it is in inches not feet
ComputeLineLength = lngLength / 12
Exit Function
Else
' well we have to do it the hard way by reading geometry
' get the number of geometry sections
intSects = shpObj.GeometryCount
' we only expect to find one in a line (index 0)
If intSects = 1 Then
intCurrGeomSect = visSectionFirstComponent + 0
intRows = shpObj.RowCount(intCurrGeomSect)
' row label starts at 1
For intCtr = 2 To intRows - 1
' get the previous row
lngBaseX = shpObj.CellsSRC(intCurrGeomSect,
intCtr - 1, visX).ResultIU
lngBaseY = shpObj.CellsSRC(intCurrGeomSect,
intCtr - 1, visY).ResultIU
' get the new position
lngNewX = shpObj.CellsSRC(intCurrGeomSect,
intCtr, visX).ResultIU
lngNewY = shpObj.CellsSRC(intCurrGeomSect,
intCtr, visY).ResultIU
' figure the changes and convert to absolute
deltaX = lngNewX - lngBaseX
deltaY = lngNewY - lngBaseY
lngLength = lngLength + Sqr((deltaX * deltaX) +
(deltaY * deltaY))
Next intCtr
End If
' remembering that internal it is in inches not feet
ComputeLineLength = lngLength / 12
End If

Exit Function
CatchError:

MsgBox "error in compute line"

End Function