Расчет длин кабелей в визио Опции

[S-cream]

У мну потребность в рисовании минимальная, поэтому я макросами не заморачивался, но Lione огромное спасибки. Забью, пусть будет.

[Костян челябинск...]

Dimka1, Гость_Lione_*, Спасибо вам. Еще не пробовал, но, думаю, получится

[Гость_Тим_*]

Выбираете "Вид", "Макрос"

Введите любое имя макроса и нажать кнопку создать.
Появится окно MS Visual Basic. Туда копируете

Sub Измерение_длин()
Dim lenth As Double
lenth = 0
Dim vsoShape As Visio.Shape
For Each vsoShape In Application.ActiveWindow.Selection
lenth = lenth + vsoShape.LengthIU
Next
'Корректировка масштаба
lenth = lenth / (0.393700787401575 - 0.000000000000001 / 5) ' перевод из внутренних ед измерения
MsgBox (lenth)
End Sub

закрываете окно.


Дальше выделяете любую линию на чертеже, выбираете вид/макрос и выполнить. Всплывёт окно с указанием длинны.


Все на примитивном уровне.

Dimka1, спасибо, вставил и поехало!

[Костян челябинск...]

А вот у меня не очень. Но разбираться было некогда. Еще раз попробую, отпишусь

[Гость_ssv Владикавказ_*]

За измерение длины кривых не скажу, а длины (в соответствие с мсштабом) прямых отрезков отражаются в левом нижнем углу. У меня стоит Визио 2007, до этого пользовался ещё с 98 Виндой, версию Визио не помню, но там тоже, по-моему, такая примочка была.

вывод длин линий по каждому цвету



Sub dl()
Dim sel As Selection
Dim snap1 As Shape
Set sel = ActiveWindow.Selection
If sel.Count < 0 Then ' если не выделено ничего или больше одного будет сообщение
MsgBox "Нужно выделить лишь одну линию!"
Exit Sub
End If
Dim colors(100)
Dim dls(100) As Double
Dim vsoShape As Visio.Shape
Dim dl_s As Double
Application.ActiveWindow.SelectAll
For Each vsoShape In Application.ActiveWindow.Selection
If InStr(vsoShape.Name, "ssv_") <> 0 Then vsoShape.Delete
Next
i = 0
Application.ActiveWindow.SelectAll
For Each vsoShape In Application.ActiveWindow.Selection
If InStr(vsoShape.Name, "ssv_") <> 0 Then vsoShape.Delete
If InStr(vsoShape.Name, "connector") <> 0 Then
color_s = vsoShape.CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU
dl_s = Round(KabLength(vsoShape) * 10) / 10
j = 0
Do
j = j + 1
Loop While colors(j) <> color_s And j < 100
If j < 100 Then dls(j) = dls(j) + dl_s Else i = i + 1: colors(i) = color_s: dls(i) = dls(i) + dl_s
End If
Next
a = ""
For j = 1 To i
Set shp = ActivePage.DrawLine(-100, -j * 20, 0, -j * 20)
shp.Name = "ssv_" & shp.Name
shp.Text = dls(j) / 1000 & " м"
shp.CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = colors(j)
shp.CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "40 pt"
shp.Cells("LineWeight") = 0.5
Next
End Sub

Function KabLength(Shap As Shape) As Double
Dim i As Integer
Dim Summa As Double ' сумма длин
Dim dx As Double, dy As Double ' определяем разности координат между концами отрезка
Dim nRows As Integer ' счетчик количества изломов линии
nRows = Shap.RowCount(visSectionFirstComponent) - 1
Summa = 0
For i = 1 To nRows - 1 ' пошагово перебираются узлы линии и вычисляются расстояния между узлами:
dx = (Shap.CellsSRC(visSectionFirstComponent, i, 0) - Shap.CellsSRC(visSectionFirstComponent, i + 1, 0)) * 0.0254 * 1000 ' по оси X
dy = (Shap.CellsSRC(visSectionFirstComponent, i, 1) - Shap.CellsSRC(visSectionFirstComponent, i + 1, 1)) * 0.0254 * 1000 ' по оси Y
Summa = Summa + Sqr(dx ^ 2 + dy ^ 2) ' Вычисляем длину текущего отрезка и прибавляем к сумме длин предыдущих отрезков
Next
KabLength = Summa
End Function