Сделал скрипт для упрощения черчения эл. схем. Позволяет опустить расстановку различного рода соединителей в схеме, анализирует взаимное расположение линий на листе, и ставит жирные точки (обозначающие соединение проводников) в местах, где сходятся концы трех и более линий, кроме того если сходятся концы двух линий, он просто склеивает эти концы, если линия проходит через жирную точку, то разбивает линию на две линии в этой точке. Если линия проходит через конец другой линии, то разбивает линию на две части в этой точке...
Сам скрипт в листинге. Мастер лист, из которого перетаскиваются нужные точки - во вложении...
Код:
Type LineInfo
ID As Integer
XY(2, 2) As Double
Checked(2) As Boolean
End Type
Type ShapeInfo
ID As Integer
Class As Integer
PinX As Double
PinY As Double
End Type
Type EndInfo
LineIndex As Integer
StartEnd As Integer
End Type
Type NearersStorage
ToEndsCount As Integer
ToEnds(3) As EndInfo
End Type
'
' Возвращает максимум двух знач
Function Max(Val1 As Double, Val2 As Double) As Double
If Val1 > Val2 Then
Max = Val1
Else
Max = Val2
End If
End Function
'
' Минимум двух знач
Function Min(Val1 As Double, Val2 As Double) As Double
If Val1 > Val2 Then
Min = Val2
Else
Min = Val1
End If
End Function
'
' Находится ли точка XY вблизи отрезка, но не вблизи концов отрезка
Function IsNear(X As Double, Y As Double, BX As Double, BY As Double, EX As Double, EY As Double) As Integer
IsNear = False
Dim k As Double, b As Double
If GetOrientation(BX, BY, EX, EY) = 1 Then
k = (EY - BY) / (EX - BX)
b = EY - k * EX
If (X < Max(BX, EX) - 0.1) And (X > Min(BX, EX) + 0.1) And (Abs(Y - k * X - b) < 0.035) Then
IsNear = True
End If
Else
k = (EX - BX) / (EY - BY)
b = EX - k * EY
If (Y < Max(BY, EY) - 0.1) And (Y > Min(BY, EY) + 0.1) And (Abs(X - k * Y - b) < 0.035) Then
IsNear = True
End If
End If
End Function
'
' Горизонтальный или вертикальный отрезок?
Function GetOrientation(BX As Double, BY As Double, EX As Double, EY As Double) As Integer
If Abs(EX - BX) > Abs(EY - BY) Then
GetOrientation = 1
Else
GetOrientation = 2
End If
End Function
'
' В какую сторону направлен отрезок относительно BX BY 0-вверх, 1 - вправо, 2 - вниз, 3 - влево
Function GetDirection(BX As Double, BY As Double, EX As Double, EY As Double) As Byte
If (GetOrientation(BX, BY, EX, EY) = 1) Then
If (EX - BX) > 0 Then
GetDirection = 1
Else
GetDirection = 3
End If
Else
If (EY - BY) > 0 Then
GetDirection = 2
Else
GetDirection = 0
End If
End If
End Function
Sub Связать()
' Считаем линии на листе
Dim Lines() As LineInfo
Dim LinesCount As Integer
LinesCount = 0
For i = 1 To ActivePage.Shapes.Count
If ActivePage.Shapes(i).OneD Then
LinesCount = LinesCount + 1
End If
Next i
' Заполняем массив линий
ReDim Lines(LinesCount)
Dim CurPos As Integer, Count As Integer
CurPos = 0
For i = 1 To ActivePage.Shapes.Count
If ActivePage.Shapes(i).OneD Then
CurPos = CurPos + 1
Lines(CurPos).ID = ActivePage.Shapes(i).ID
Lines(CurPos).XY(1, 1) = ActivePage.Shapes(i).CellsU("BeginX")
Lines(CurPos).XY(1, 2) = ActivePage.Shapes(i).CellsU("BeginY")
Lines(CurPos).XY(2, 1) = ActivePage.Shapes(i).CellsU("EndX")
Lines(CurPos).XY(2, 2) = ActivePage.Shapes(i).CellsU("EndY")
Lines(CurPos).Checked(1) = False
Lines(CurPos).Checked(2) = False
End If
Next i
' Считаем точки на листе
Dim TheShapes() As ShapeInfo
Dim ShapesCount As Integer
ShapesCount = 0
For i = 1 To ActivePage.Shapes.Count
If (InStr(ActivePage.Shapes(i).Name, "ТочкаЖирн") = 1) Or (InStr(ActivePage.Shapes(i).Name, "ТочкаПуст") = 1) Or (InStr(ActivePage.Shapes(i).Name, "ТочкаКлей") = 1) Then
ShapesCount = ShapesCount + 1
End If
Next i
' Заполняем массив точек
ReDim TheShapes(ShapesCount)
CurPos = 0
For i = 1 To ActivePage.Shapes.Count
If InStr(ActivePage.Shapes(i).Name, "ТочкаЖирн") = 1 Then
CurPos = CurPos + 1
TheShapes(CurPos).ID = ActivePage.Shapes(i).ID
TheShapes(CurPos).Class = 2
TheShapes(CurPos).PinX = ActivePage.Shapes(i).CellsU("PinX")
TheShapes(CurPos).PinY = ActivePage.Shapes(i).CellsU("PinY")
End If
If InStr(ActivePage.Shapes(i).Name, "ТочкаКлей") = 1 Then
CurPos = CurPos + 1
TheShapes(CurPos).ID = ActivePage.Shapes(i).ID
TheShapes(CurPos).Class = 1
TheShapes(CurPos).PinX = ActivePage.Shapes(i).CellsU("PinX")
TheShapes(CurPos).PinY = ActivePage.Shapes(i).CellsU("PinY")
End If
If InStr(ActivePage.Shapes(i).Name, "ТочкаПуст") = 1 Then
CurPos = CurPos + 1
TheShapes(CurPos).ID = ActivePage.Shapes(i).ID
TheShapes(CurPos).Class = 3
TheShapes(CurPos).PinX = ActivePage.Shapes(i).CellsU("PinX")
TheShapes(CurPos).PinY = ActivePage.Shapes(i).CellsU("PinY")
End If
Next i
' Разбиваем линии, проходящие через концы других линий
For i = 1 To LinesCount
For j = 1 To LinesCount
If i <> j Then
For StartEnd = 1 To 2
If IsNear(Lines(i).XY(StartEnd, 1), Lines(i).XY(StartEnd, 2), Lines(j).XY(1, 1), Lines(j).XY(1, 2), Lines(j).XY(2, 1), Lines(j).XY(2, 2)) Then
LinesCount = LinesCount + 1
ReDim Preserve Lines(LinesCount)
ActivePage.Shapes.ItemFromID(Lines(j).ID).Delete
Dim vsLine As Visio.Shape
Set vsLine = Application.ActiveWindow.Page.DrawLine(Lines(j).XY(1, 1), Lines(j).XY(1, 2), Lines(i).XY(StartEnd, 1), Lines(i).XY(StartEnd, 2))
Count = ActivePage.Shapes.Count
Lines(LinesCount).ID = vsLine.ID
Lines(LinesCount).XY(1, 1) = Lines(j).XY(1, 1)
Lines(LinesCount).XY(1, 2) = Lines(j).XY(1, 2)
Lines(LinesCount).XY(2, 1) = Lines(i).XY(StartEnd, 1)
Lines(LinesCount).XY(2, 2) = Lines(i).XY(StartEnd, 2)
Lines(LinesCount).Checked(1) = False
Lines(LinesCount).Checked(2) = False
Set vsLine = Application.ActiveWindow.Page.DrawLine(Lines(j).XY(2, 1), Lines(j).XY(2, 2), Lines(i).XY(StartEnd, 1), Lines(i).XY(StartEnd, 2))
Lines(j).ID = vsLine.ID
Lines(j).XY(1, 1) = Lines(j).XY(2, 1)
Lines(j).XY(1, 2) = Lines(j).XY(2, 2)
Lines(j).XY(2, 1) = Lines(i).XY(StartEnd, 1)
Lines(j).XY(2, 2) = Lines(i).XY(StartEnd, 2)
End If
Next StartEnd
End If
Next j
Next i
' Разбиваем линии, проходящие через точки
For i = 1 To ShapesCount
For j = 1 To LinesCount
If i <> j Then
If IsNear(TheShapes(i).PinX, TheShapes(i).PinY, Lines(j).XY(1, 1), Lines(j).XY(1, 2), Lines(j).XY(2, 1), Lines(j).XY(2, 2)) Then
LinesCount = LinesCount + 1
ReDim Preserve Lines(LinesCount)
ActivePage.Shapes.ItemFromID(Lines(j).ID).Delete
Set vsLine = Application.ActiveWindow.Page.DrawLine(Lines(j).XY(1, 1), Lines(j).XY(1, 2), TheShapes(i).PinX, TheShapes(i).PinY)
Lines(LinesCount).ID = vsLine.ID
Lines(LinesCount).XY(1, 1) = Lines(j).XY(1, 1)
Lines(LinesCount).XY(1, 2) = Lines(j).XY(1, 2)
Lines(LinesCount).XY(2, 1) = TheShapes(i).PinX
Lines(LinesCount).XY(2, 2) = TheShapes(i).PinY
Lines(LinesCount).Checked(1) = False
Lines(LinesCount).Checked(2) = False
Set vsLine = Application.ActiveWindow.Page.DrawLine(Lines(j).XY(2, 1), Lines(j).XY(2, 2), TheShapes(i).PinX, TheShapes(i).PinY)
Lines(j).ID = vsLine.ID
Lines(j).XY(1, 1) = Lines(j).XY(2, 1)
Lines(j).XY(1, 2) = Lines(j).XY(2, 2)
Lines(j).XY(2, 1) = TheShapes(i).PinX
Lines(j).XY(2, 2) = TheShapes(i).PinY
Lines(LinesCount).Checked(2) = False
End If
End If
Next j
Next i
' Проставляем точки возле групп концов линий, если рядом нет точка
Dim CurEnd As EndInfo
Dim Nearers As NearersStorage
For i = 1 To LinesCount
CurEnd.LineIndex = i
For SrcStartEnd = 1 To 2
If Lines(i).Checked(SrcStartEnd) = False Then
Dim IngoreThisPoint As Byte
Dim PointID As Integer
IgnoreThisPoint = 0
For j = 1 To ShapesCount
If ((Lines(i).XY(SrcStartEnd, 1) - TheShapes(j).PinX) ^ 2 + (Lines(i).XY(SrcStartEnd, 2) - TheShapes(j).PinY) ^ 2) < 0.0015 Then
IgnoreThisPoint = TheShapes(j).Class
PointIndex = j
End If
Next j
CurEnd.StartEnd = SrcStartEnd
Lines(i).Checked(SrcStartEnd) = True
Nearers.ToEndsCount = 0
For j = i To LinesCount
If i <> j Then
For DestStartEnd = 1 To 2
If (Lines(j).Checked(DestStartEnd) = False) And (IgnoreThisPoint < 2) Then
If ((Lines(i).XY(SrcStartEnd, 1) - Lines(j).XY(DestStartEnd, 1)) ^ 2 + (Lines(i).XY(SrcStartEnd, 2) - Lines(j).XY(DestStartEnd, 2)) ^ 2) < 0.0015 Then
Lines(j).Checked(DestStartEnd) = True
Nearers.ToEndsCount = Nearers.ToEndsCount + 1
Nearers.ToEnds(Nearers.ToEndsCount).LineIndex = j
Nearers.ToEnds(Nearers.ToEndsCount).StartEnd = DestStartEnd
End If
End If
Next DestStartEnd
End If
Next j
If (Nearers.ToEndsCount = 1) And (IgnoreThisPoint = 0) Then
Application.Windows.ItemEx("Рисунок.vsd").Activate
Set vsLine = Application.ActiveWindow.Page.Drop(Application.Documents.Item("E:\Инженерия\Трафареты\Шаблон2.vss").Masters.ItemU("ТочкаКлей"), Lines(CurEnd.LineIndex).XY(SrcStartEnd, 1), Lines(CurEnd.LineIndex).XY(SrcStartEnd, 2))
ShapesCount = ShapesCount + 1
ReDim Preserve TheShapes(ShapesCount)
TheShapes(ShapesCount).Class = 1
TheShapes(ShapesCount).ID = vsLine.ID
TheShapes(ShapesCount).PinX = Lines(CurEnd.LineIndex).XY(SrcStartEnd, 1)
TheShapes(ShapesCount).PinY = Lines(CurEnd.LineIndex).XY(SrcStartEnd, 2)
End If
If (Nearers.ToEndsCount > 1) And (IgnoreThisPoint < 2) Then
If IgnoreThisPoint = 1 Then
ActivePage.Shapes.ItemFromID(TheShapes(PointIndex).ID).Delete
End If
Application.Windows.ItemEx("Рисунок.vsd").Activate
Set vsLine = Application.ActiveWindow.Page.Drop(Application.Documents.Item("E:\Инженерия\Трафареты\Шалон2.vss").Masters.ItemU("ТочкаЖирн"), Lines(CurEnd.LineIndex).XY(SrcStartEnd, 1), Lines(CurEnd.LineIndex).XY(SrcStartEnd, 2))
TheShapes(PointIndex).ID = vsLine.ID
TheShapes(PointIndex).Class = 2
TheShapes(PointIndex).PinX = Lines(CurEnd.LineIndex).XY(SrcStartEnd, 1)
TheShapes(PointIndex).PinY = Lines(CurEnd.LineIndex).XY(SrcStartEnd, 2)
End If
End If
Next SrcStartEnd
Next i
' Смотрим, какие точки рядом с какими концами линий и склеиваем
Dim vsoCell1 As Visio.Cell
Dim vsoCell2 As Visio.Cell
For i = 1 To LinesCount
For StartEnd = 1 To 2
For j = 1 To ShapesCount
If ((Lines(i).XY(StartEnd, 1) - TheShapes(j).PinX) ^ 2 + (Lines(i).XY(StartEnd, 2) - TheShapes(j).PinY) ^ 2) < 0.0015 Then
Dim Dir As Integer
Dir = GetDirection(Lines(i).XY(StartEnd, 1), Lines(i).XY(StartEnd, 2), Lines(i).XY(3 - StartEnd, 1), Lines(i).XY(3 - StartEnd, 2))
If TheShapes(j).Class = 1 Then Dir = 0
If StartEnd = 1 Then
Set vsoCell1 = Application.ActiveWindow.Page.Shapes.ItemFromID(Lines(i).ID).CellsU("BeginX")
Set vsoCell2 = Application.ActiveWindow.Page.Shapes.ItemFromID(TheShapes(j).ID).CellsSRC(7, Dir, 0)
Else
Set vsoCell1 = Application.ActiveWindow.Page.Shapes.ItemFromID(Lines(i).ID).CellsU("EndX")
Set vsoCell2 = Application.ActiveWindow.Page.Shapes.ItemFromID(TheShapes(j).ID).CellsSRC(7, Dir, 0)
End If
Dim UndoScopeID1 As Long
Application.Windows.ItemEx("Рисунок.vsd").Activate
UndoScopeID1 = Application.BeginUndoScope("Размер объекта")
vsoCell1.GlueTo vsoCell2
Application.EndUndoScope UndoScopeID1, True
End If
Next j
Next StartEnd
Next i
End Sub
Скрипт сырой пока что, потихоньку в процессе работы определяюсь, что еще нужно в него добавлять, идеи есть конечно, в частности, возможность анализа, какие линии проходят через какие шейпы навылет, и разбивки этих линий на части, приклеивание к ближайшим точкам соединения на шейпе - тогда можно будет контур схемы рисовать линиями, а элементы бросать прямо поверх линий, а скрипт потом сам внедрит элементы в схему.
Вторая проблема - в том, что при рисовании контура схемы этот контур превращается в полилинию, если не сбрасывать постоянно фокус с только что введенной линии... как с этим бороться не знаю, толи писать скрипт разбивки полилинии, толи перехватывать рисование и сбрасывать фокус с текущего активного шейпа, или что то в этом роде..
Еще нужен будет скрипт выравнивания схемы до параллельно-перпендикулярного состояния, алгоритм вроде намечен... Спасибо за внимание... Хочу критики и предложений...
З.Ы. На исходном рисунке две точки нужны чтобы скрипт мог отличить, что это именно пересечение, а не два проводника, не соединяемых между собой... точки брошены просто поверх двух пересекающихся линий.. на конечном рисунке это уже четыре линии, которые приклеены к точке...