You'd have to do it with code. You can get a selection of shapes from
Visio - ie: the shapes selected on a page. Something like this, in VBA:
dim sel as visio.selection
set sel = Visio.ActiveWindow.Selection
Then you can walk the shapes:
Dim shp as Visio.Shape
For each shp in sel
' total the lengths
dTot = dTot + shp.LengthIU
Next
In Visio 2003, there's a bug where LengthIU doesn't work for non-closed
shapes. Al Edlund posted a workaround in a forum that I Googled. Give it a
shot:
--
Hope this helps,
Chris Roth
Visio MVP
LengthIU Workaround
----------------------------------
lengthiu stopped working in v2003 (a known issue). to get the actual length
takes a little code. You can catch it with a macro similar to this.
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
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
