Форум пользователей Visio

Форум по вопросам применения и программирования в Visio
Текущее время: 20 ноя 2019, 08:14

Часовой пояс: UTC + 3 часа [ Летнее время ]


Правила форума


При размещении файлов предпочтительным является формат vsd (а не vsdx/vsdm)
Размещая ваши вложения на форуме не используйте имена файлов содержащих кириллицу, в противном случае файл будет иметь имя .<расширение файла> !
Для форматирования ваших сообщений используйте BBCodes, описание используемых на форуме BBCodes.



Начать новую тему Ответить на тему  [ Сообщений: 6 ] 
Автор Сообщение
 Заголовок сообщения: Скрипт для черчения эл. схем
СообщениеДобавлено: 20 янв 2010, 01:25 
Не в сети

Зарегистрирован: 05 янв 2010, 23:05
Сообщений: 11
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Сделал скрипт для упрощения черчения эл. схем. Позволяет опустить расстановку различного рода соединителей в схеме, анализирует взаимное расположение линий на листе, и ставит жирные точки (обозначающие соединение проводников) в местах, где сходятся концы трех и более линий, кроме того если сходятся концы двух линий, он просто склеивает эти концы, если линия проходит через жирную точку, то разбивает линию на две линии в этой точке. Если линия проходит через конец другой линии, то разбивает линию на две части в этой точке...

Сам скрипт в листинге. Мастер лист, из которого перетаскиваются нужные точки - во вложении...

Код:
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


Скрипт сырой пока что, потихоньку в процессе работы определяюсь, что еще нужно в него добавлять, идеи есть конечно, в частности, возможность анализа, какие линии проходят через какие шейпы навылет, и разбивки этих линий на части, приклеивание к ближайшим точкам соединения на шейпе - тогда можно будет контур схемы рисовать линиями, а элементы бросать прямо поверх линий, а скрипт потом сам внедрит элементы в схему.
Вторая проблема - в том, что при рисовании контура схемы этот контур превращается в полилинию, если не сбрасывать постоянно фокус с только что введенной линии... как с этим бороться не знаю, толи писать скрипт разбивки полилинии, толи перехватывать рисование и сбрасывать фокус с текущего активного шейпа, или что то в этом роде..
Еще нужен будет скрипт выравнивания схемы до параллельно-перпендикулярного состояния, алгоритм вроде намечен... Спасибо за внимание... Хочу критики и предложений...

З.Ы. На исходном рисунке две точки нужны чтобы скрипт мог отличить, что это именно пересечение, а не два проводника, не соединяемых между собой... точки брошены просто поверх двух пересекающихся линий.. на конечном рисунке это уже четыре линии, которые приклеены к точке...


Вложения:
2.rar [58.89 Кб]
Скачиваний: 140
1.JPG
1.JPG [ 127.61 Кб | Просмотров: 395 ]
Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Скрипт для черчения эл. схем
СообщениеДобавлено: 20 янв 2010, 20:25 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 1497
Очков репутации: 100599

Добавить очки репутацииУменьшить очки репутации
Цитата:
Хочу критики и предложений...

Это ж сразу и не проанализируешь. Вон сколько наворочено... :)
Идея интересная.
В любом случае хочу сказать спасибо. Даже если кому-то скрипт целиком не пригодится, все равно смогут использовать фрагменты, как примеры операций, учитывающих взаиморасположение шейпов.
Цитата:
Вторая проблема - в том, что при рисовании контура схемы этот контур превращается в полилинию, если не сбрасывать постоянно фокус с только что введенной линии... как с этим бороться не знаю, толи писать скрипт разбивки полилинии, толи перехватывать рисование и сбрасывать фокус с текущего активного шейпа, или что то в этом роде..

Разбивка полилинии и реализуется проще и логически более естественна. События будут срабатывать и когда не надо, а разбивать можно только нужные линии по специальному указанию.
Да и сам скрипт может быть было бы полезно заставить работать не по всему листу, а по селектированной области. Может на листе будет и то, что преобразовывать не надо.
С точками надо будет подумать... Я такие точки в принципе не использую. Дело в том, что в ранних версиях Visio они страшно тормозили схему (когда точек много). Поэтому в практику вошло использовать не дополнительные точки, а оформление окончаний линий. Остался ли эффект торможения сейчас, я даже не знаю.


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Скрипт для черчения эл. схем
СообщениеДобавлено: 20 янв 2010, 21:33 
Не в сети

Зарегистрирован: 05 янв 2010, 23:05
Сообщений: 11
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Да и сейчас тормозят работу все эти штуки, дома у меня новый комп, а на работе старый... Разница огромная в скорости выполнения... Торможение ощутимое... Даже дома секунд пять скрипт выполняется при около 200 линий и около 200 точек...
Ну раз Вам понравилось, тогда я потом еще вопрос задам :) Когда соберусь :) Впрочем нет, не могу молчать :)
Как можно получить количество точек для приклеивания в шейпе? Я лично сейчас пытаюсь делать так:
Код:
GlowCount = ActivePage.Shapes.ItemFromID(TheShapes(i).ID).RowCount(visSectionConnectionPts)


и дальше перебираю все эти точки, определяя их координаты относительно листа
Код:
       For j = 1 To GlowCount
            X = ActivePage.Shapes.ItemFromID(TheShapes(i).ID).Section(visSectionConnectionPts).Row(j).Cell(visCnnctX)
            Y = ActivePage.Shapes.ItemFromID(TheShapes(i).ID).Section(visSectionConnectionPts).Row(j).Cell(visCnnctY)
            ActivePage.Shapes.ItemFromID(TheShapes(i).ID).XYToPage X, Y, X, Y
            '... и так далее


Вот только иногда выдает какую то ерунду, на предмет того что хоть число строк GlowCount в секции visSectionConnectionPts допустим равно 4, но не для всех них есть ячейка visCnnctX... И на выходе получаю ошибку "неверный идентификатор окна" или как то так...


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Скрипт для черчения эл. схем
СообщениеДобавлено: 21 янв 2010, 01:29 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 1497
Очков репутации: 100599

Добавить очки репутацииУменьшить очки репутации
Цитата:
For j = 1 To GlowCount

Так строки с нуля считаются... Может поэтому?
For j = 0 To GlowCount-1


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Скрипт для черчения эл. схем
СообщениеДобавлено: 21 янв 2010, 09:10 
Не в сети

Зарегистрирован: 05 янв 2010, 23:05
Сообщений: 11
Очков репутации: 0

Добавить очки репутацииУменьшить очки репутации
Да в том и проблема, что по отладчику видно, что число строк секции равно четырем, а нет ячейки для второй строки. Вот и не понятно, толи после удаления точки привязки в шейпе осталась дыра, толи не знаю что еще...


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
 Заголовок сообщения: Re: Скрипт для черчения эл. схем
СообщениеДобавлено: 22 янв 2010, 20:02 
Не в сети
Administrator

Зарегистрирован: 30 авг 2009, 11:02
Сообщений: 1497
Очков репутации: 100599

Добавить очки репутацииУменьшить очки репутации
А в ShapeSheet вторая строка просматривается?


Пожаловаться на это сообщение
Вернуться к началу
 Профиль  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 6 ] 

Часовой пояс: UTC + 3 часа [ Летнее время ]



Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
Вы можете создать форум бесплатно PHPBB3 на Getbb.Ru, Также возможно сделать готовый форум PHPBB2 на Mybb2.ru
Русская поддержка phpBB