Created
January 23, 2022 16:27
-
-
Save gtfox/0dcd4a497a33a93aa18ac22dae3797af to your computer and use it in GitHub Desktop.
Автонумерация/Перенумерация элементов схемы
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| '------------------------------------------------------------------------------------------------------------ | |
| ' Module : AutoNumber - Автонумерация | |
| ' Author : gtfox | |
| ' Date : 2020.05.11 | |
| ' Description : Автонумерация/Перенумерация элементов схемы | |
| ' Link : https://visio.getbb.ru/viewtopic.php?f=44&t=1491, https://github.com/gtfox/SAPR_ASU, https://yadi.sk/d/24V8ngEM_8KXyg | |
| '------------------------------------------------------------------------------------------------------------ | |
| Public MaxNumber As Integer 'Максимальное значение нумерации существующих элементов. Это не общее число элементов, а макс цифра в обозначении. | |
| Public MaxNumberFSA As Integer 'Максимальное значение нумерации существующих элементов. Это не общее число элементов, а макс цифра в обозначении. | |
| 'Sub EventDropAutoNum(vsoShapeEvent As Shape) | |
| ''------------------------------------------------------------------------------------------------------------ | |
| '' Macros : EventDropAutoNum - Автонумерация для одиночной вставки | |
| ' 'Когда происходит вставка применяется привязка к курсору | |
| ' 'Если вставка была из набора элементов - привязка к курсору не происходит | |
| ' '(после вставки на лист в щейпе ставится бит User.Dropped, и он начинает привязываться) | |
| ' 'В EventDrop должна быть формула =CALLTHIS("ThisDocument.EventDropAutoNum") | |
| ''------------------------------------------------------------------------------------------------------------ | |
| ' Макрос в ThisDocument .............. | |
| 'End Sub | |
| Public Sub AutoNum(vsoShape As Visio.Shape) | |
| '------------------------------------------------------------------------------------------------------------ | |
| ' Macros : AutoNum - Автонумерация элементов при вбросе/копировании | |
| 'Нумерация всегда продолжается с максимального значения нумерации существующих элементов | |
| 'Если, в начале схемы был удален элемент, его номер больше не появится | |
| 'Для лотания дыр в нумерации используйте перенумерацию элементов ReNumber() | |
| 'Когда происходит массовая вставка не применяется привязка к курсору | |
| 'В EventMultiDrop должна быть формула = CALLTHIS("AutoNumber.AutoNum", "SAPR_ASU") | |
| '------------------------------------------------------------------------------------------------------------ | |
| Dim SymName As String 'Буквенная часть нумерации | |
| Dim NazvanieShemy As String 'Нумерация элементов идет в пределах одной схемы (одного номера схемы) | |
| Dim UserType As Integer 'Тип элемента схемы: клемма, провод, реле | |
| Dim ThePage As Visio.Shape | |
| Dim vsoShapeOnPage As Visio.Shape | |
| Dim vsoPage As Visio.Page | |
| Dim PageName As String | |
| Set ThePage = ActivePage.PageSheet | |
| If ThePage.CellExists("Prop.SA_NazvanieShemy", 0) Then NazvanieShemy = ThePage.Cells("Prop.SA_NazvanieShemy").ResultStr(0) 'Номер схемы. Если одна схема на весь проект, то на всех листах должен быть один номер. | |
| PageName = cListNameCxema 'Имена листов где возможна нумерация | |
| 'Узнаем тип и буквенное обозначение элемента, который вставили на схему | |
| UserType = ShapeSAType(vsoShape) | |
| If vsoShape.CellExists("Prop.SymName", 0) Then SymName = vsoShape.Cells("Prop.SymName").ResultStr(0) | |
| 'Чистим номер, чтобы он не участвовал в поиске | |
| vsoShape.Cells("Prop.Number").FormulaU = 0 | |
| 'Чистим максимум | |
| MaxNumber = 0 | |
| 'Цикл поиска максимального номера существующих элементов схемы | |
| For Each vsoPage In ActiveDocument.Pages 'Перебираем все листы в активном документе | |
| If Left(vsoPage.Name, Len(PageName)) = PageName Then 'Берем те, что содержат "Схема" в имени | |
| If vsoPage.PageSheet.Cells("Prop.SA_NazvanieShemy").ResultStr(0) = NazvanieShemy Then 'Берем все схемы с именем той, на которую вставляем элемент | |
| For Each vsoShapeOnPage In vsoPage.Shapes 'Перебираем все шейпы в найденных листах | |
| If ShapeSATypeIs(vsoShapeOnPage, UserType) Then 'Если в шейпе есть тип, то проверяем чтобы совпадал с нашим (который вставили) | |
| If vsoShapeOnPage.Cells("Prop.AutoNum").Result(0) = 1 Then 'Отсеиваем шейпы нумеруемые вручную | |
| Select Case UserType | |
| Case typeWire 'Провода | |
| FindMAX vsoShapeOnPage | |
| Case typeCableSH 'Кабели на схеме электрической | |
| FindMAX vsoShapeOnPage | |
| End Select | |
| If (vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) = SymName) Then 'Буквы совпадают 'And (vsoShapeOnPage.NameID <> vsoShape.NameID) и это не тот же шейп который вставили | |
| Select Case UserType | |
| Case typeTerm 'Клеммы | |
| If vsoShapeOnPage.Cells("Prop.NumberKlemmnik").Result(0) = vsoShape.Cells("Prop.NumberKlemmnik").Result(0) Then 'Выбираем клеммы из одного клеммника | |
| FindMAX vsoShapeOnPage | |
| End If | |
| Case typeCoil, typeParent, typeElement, typePLCParent, typeSensor, typeActuator, typeElectroOneWire, typeElectroPlan, typeOPSPlan 'Остальные элементы | |
| FindMAX vsoShapeOnPage | |
| End Select | |
| End If | |
| End If | |
| End If | |
| Next | |
| End If | |
| End If | |
| Next | |
| 'Во вставленный элемент заносим максимальный найденный номер + 1 | |
| vsoShape.Cells("Prop.Number").FormulaU = MaxNumber + 1 | |
| 'Активация событий. Они чета сомодезактивируются xD | |
| 'Set vsoPagesEvent = ActiveDocument.Pages | |
| End Sub | |
| 'Ищем максимальное значение номера элемента | |
| Sub FindMAX(vsoShapeOnPage As Visio.Shape) | |
| If vsoShapeOnPage.Cells("Prop.Number").Result(0) > MaxNumber Then 'Ищем максимальное значение номера элемента | |
| MaxNumber = vsoShapeOnPage.Cells("Prop.Number").Result(0) 'Запоменаем. А те что меньше сюда не попадут | |
| 'Debug.Print vsoShapeOnPage.Name & " " & MaxNumber | |
| End If | |
| End Sub | |
| Sub ShowReNumber() | |
| frmReNumber.Show | |
| End Sub | |
| Public Function ReNumber(colShp As Collection, StartNumber As Integer) As Integer | |
| '------------------------------------------------------------------------------------------------------------ | |
| ' Macros : ReNumber - Перенумерация элементов | |
| 'Сортировка массивов координат и перенумерация | |
| '------------------------------------------------------------------------------------------------------------ | |
| Dim shpElement As Shape | |
| Dim masShape() As Shape | |
| Dim shpTemp As Shape | |
| Dim XPred As Double | |
| Dim XTekush As Double | |
| Dim i As Integer, ii As Integer, j As Integer, N As Integer | |
| 'из коллекции передаем их в массив для сортировки | |
| ReDim masShape(colShp.Count - 1) | |
| i = 0 | |
| For Each shpElement In colShp | |
| Set masShape(i) = shpElement | |
| i = i + 1 | |
| Next | |
| ' "Сортировка вставками" массива шейпов по возрастанию коордонаты Х | |
| '--V--Сортируем по возрастанию коордонаты Х | |
| UbMas = UBound(masShape) | |
| For j = 1 To UbMas | |
| Set shpTemp = masShape(j) | |
| i = j | |
| If SAType = typeWire Then | |
| While WireX(masShape(i - 1)) > WireX(shpTemp) '>:возрастание, <:убывание | |
| Set masShape(i) = masShape(i - 1) | |
| i = i - 1 | |
| If i <= 0 Then GoTo ExitWhileX | |
| Wend | |
| Else | |
| While masShape(i - 1).Cells("PinX").Result("mm") > shpTemp.Cells("PinX").Result("mm") '>:возрастание, <:убывание | |
| Set masShape(i) = masShape(i - 1) | |
| i = i - 1 | |
| If i <= 0 Then GoTo ExitWhileX | |
| Wend | |
| End If | |
| ExitWhileX: Set masShape(i) = shpTemp | |
| Next | |
| '--Х--Сортировка по возрастанию коордонаты Х | |
| 'Находим шейпы с одинаковой координатой Х и сортируем Y-ки | |
| Group = False | |
| Set colShp = New Collection | |
| For ii = 1 To UbMas | |
| If SAType = typeWire Then | |
| XPred = WireX(masShape(ii - 1)) | |
| XTekush = WireX(masShape(ii)) | |
| Else | |
| XPred = masShape(ii - 1).Cells("PinX").Result("mm") | |
| XTekush = masShape(ii).Cells("PinX").Result("mm") | |
| End If | |
| If (Abs(XPred - XTekush) < 0.5) And (ii < UbMas) Then | |
| If Group = False Then | |
| StartIndex = ii - 1 'На первом элементе запоменаем его номер | |
| Group = True 'Начали собирать одинаковые координаты | |
| End If | |
| ElseIf Group Then | |
| Group = False 'Попался первый не одинаковый. Закончили. | |
| EndIndex = ii - 1 | |
| If (ii = UbMas) And (Abs(XPred - XTekush) < 0.5) Then EndIndex = ii 'Если последний элемент, то включаем его в сортировку | |
| '--V--Сортируем по убыванию коордонаты Y | |
| For j = StartIndex + 1 To EndIndex | |
| Set shpTemp = masShape(j) | |
| i = j | |
| If SAType = typeWire Then | |
| While WireY(masShape(i - 1)) < WireY(shpTemp) '>:возрастание, <:убывание | |
| Set masShape(i) = masShape(i - 1) | |
| i = i - 1 | |
| If i <= StartIndex Then GoTo ExitWhileY | |
| Wend | |
| Else | |
| While masShape(i - 1).Cells("PinY").Result("mm") < shpTemp.Cells("PinY").Result("mm") '>:возрастание, <:убывание | |
| Set masShape(i) = masShape(i - 1) | |
| i = i - 1 | |
| If i <= StartIndex Then GoTo ExitWhileY | |
| Wend | |
| End If | |
| ExitWhileY: Set masShape(i) = shpTemp | |
| Next | |
| '--Х--Сортировка по убыванию коордонаты Y | |
| End If | |
| Next | |
| Set colShp = Nothing | |
| 'Перенумеровываем отсортированный массив | |
| For i = 0 To UbMas | |
| masShape(i).Cells("Prop.Number").FormulaU = StartNumber + i + 1 | |
| Next | |
| ReNumber = masShape(UbMas).Cells("Prop.Number").Result(0) | |
| End Function | |
| Function WireX(vsoShape As Visio.Shape) As Double | |
| Dim BeginX As Double | |
| Dim EndX As Double | |
| BeginX = vsoShape.Cells("BeginX").Result("mm") | |
| EndX = vsoShape.Cells("EndX").Result("mm") | |
| WireX = IIf(BeginX < EndX, BeginX, EndX) ' Начало провода по X = Слева | |
| End Function | |
| Function WireY(vsoShape As Visio.Shape) As Double | |
| Dim BeginY As Double | |
| Dim EndY As Double | |
| BeginY = vsoShape.Cells("BeginY").Result("mm") | |
| EndY = vsoShape.Cells("EndY").Result("mm") | |
| WireY = IIf(BeginY > EndY, BeginY, EndY) ' Начало провода по Y = Сверху | |
| End Function | |
| Sub AutoNumFSA(vsoShape As Visio.Shape) | |
| '------------------------------------------------------------------------------------------------------------ | |
| ' Macros : AutoNumFSA - Автонумерация элементов на ФСА при вбросе/копировании | |
| 'Нумеруются датчики с одинаковыми буквенными обозначениями (PT,TE,...) и в педелах одного контура (РТ/1-П,РТ/2-П,РТ/3-П) | |
| 'Если контур не указан, то только с одинаковыми буквенными обозначениями (РТ/1,РТ/2,РТ/3) | |
| 'Нумерация всегда продолжается с максимального значения нумерации существующих элементов | |
| 'Если, в начале схемы был удален элемент, его номер больше не появится | |
| 'Для лотания дыр в нумерации используйте перенумерацию элементов ReNumberFSA() | |
| 'Когда происходит массовая вставка не применяется привязка к курсору | |
| 'В EventMultiDrop должна быть формула = CALLTHIS("AutoNumber.AutoNumFSA", "SAPR_ASU") | |
| '------------------------------------------------------------------------------------------------------------ | |
| If BlockMacros Then Exit Sub | |
| Dim UserType As Integer 'Тип элемента схемы: клемма, провод, реле | |
| Dim SymName As String 'Буквенная часть нумерации | |
| Dim NameKontur 'Имя контура | |
| Dim NazvanieFSA As String 'Нумерация элементов идет в пределах одной схемы (одного номера схемы) | |
| ' Dim MaxNumber As Integer 'Максимальное значение нумерации существующих элементов. Это не общее число элементов, а макс цифра в обозначении. | |
| ' Dim TheDoc As Visio.Shape | |
| ' Set TheDoc = Application.ActiveDocument.DocumentSheet | |
| Dim ThePage As Visio.Shape | |
| Set ThePage = ActivePage.PageSheet | |
| Dim vsoShapeOnPage As Visio.Shape | |
| Dim vsoPage As Visio.Page | |
| Dim PageName As String | |
| PageName = cListNameFSA 'Имена листов где возможна нумерация | |
| If ThePage.CellExists("Prop.SA_NazvanieFSA", 0) Then NazvanieFSA = ThePage.Cells("Prop.SA_NazvanieFSA").ResultStr(0) 'Номер схемы. Если одна схема на весь проект, то на всех листах должен быть один номер. По умолчанию = 1 | |
| 'Узнаем тип и буквенное обозначение элемента, который вставили на схему | |
| UserType = ShapeSAType(vsoShape) | |
| If vsoShape.CellExists("Prop.SymName", 0) Then SymName = vsoShape.Cells("Prop.SymName").ResultStr(0) | |
| If vsoShape.CellExists("Prop.NameKontur", 0) Then NameKontur = vsoShape.Cells("Prop.NameKontur").ResultStr(0) | |
| 'Чистим номер, чтобы он не участвовал в поиске | |
| vsoShape.Cells("Prop.Number").FormulaU = 0 | |
| 'Чистим максимум | |
| MaxNumberFSA = 0 | |
| 'Цикл поиска максимального номера существующих элементов схемы | |
| For Each vsoPage In ActiveDocument.Pages 'Перебираем все листы в активном документе | |
| If InStr(1, vsoPage.Name, PageName) > 0 Then 'Берем те, что содержат "Схема" в имени | |
| If vsoPage.PageSheet.Cells("Prop.SA_NazvanieFSA").ResultStr(0) = NazvanieFSA Then 'Берем все схемы с номером той, на которую вставляем элемент | |
| For Each vsoShapeOnPage In vsoPage.Shapes 'Перебираем все шейпы в найденных листах | |
| If ShapeSATypeIs(vsoShapeOnPage, UserType) Then 'Если в шейпе есть тип, то проверяем чтобы совпадал с нашим (который вставили) | |
| If vsoShapeOnPage.Cells("Prop.AutoNum").Result(0) = 1 Then 'Отсеиваем шейпы нумеруемые вручную | |
| Select Case UserType | |
| Case typeFSAPodval | |
| FindMAXFSA vsoShapeOnPage | |
| End Select | |
| If (vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) = SymName) Then 'Буквы совпадают | |
| Select Case UserType | |
| Case typeFSASensor 'датчики ФСА | |
| If vsoShapeOnPage.Cells("Prop.NameKontur").ResultStr(0) = vsoShape.Cells("Prop.NameKontur").ResultStr(0) Then 'Выбираем датчики из одного контура | |
| FindMAXFSA vsoShapeOnPage | |
| End If | |
| End Select | |
| End If | |
| End If | |
| End If | |
| Next | |
| End If | |
| End If | |
| Next | |
| 'Во вставленный элемент заносим максимальный найденный номер + 1 | |
| vsoShape.Cells("Prop.Number").FormulaU = MaxNumberFSA + 1 | |
| 'Активация событий. Они чета сомодезактивируются xD | |
| 'Set vsoPagesEvent = ActiveDocument.Pages | |
| End Sub | |
| 'Ищем максимальное значение номера элемента | |
| Sub FindMAXFSA(vsoShapeOnPage As Visio.Shape) | |
| If vsoShapeOnPage.Cells("Prop.Number").Result(0) > MaxNumberFSA Then 'Ищем максимальное значение номера элемента | |
| MaxNumberFSA = vsoShapeOnPage.Cells("Prop.Number").Result(0) 'Запоменаем. А те что меньше сюда не попадут | |
| 'Debug.Print vsoShapeOnPage.Name & " " & MaxNumberFSA | |
| End If | |
| End Sub | |
| Sub ReNumberFSA() | |
| End Sub | |
| Sub HideWireNumChildOnPage() | |
| HideWireNumChild ActivePage | |
| End Sub | |
| Sub HideWireNumChildInDoc() | |
| Dim vsoPage As Visio.Page | |
| Dim PageName As String | |
| PageName = cListNameCxema 'Имена листов | |
| For Each vsoPage In ActiveDocument.Pages 'Перебираем все листы в активном документе | |
| If InStr(1, vsoPage.Name, PageName) > 0 Then 'Берем те, что содержат "Схема" в имени | |
| HideWireNumChild vsoPage | |
| End If | |
| Next | |
| End Sub | |
| Public Sub HideWireNumChild(vsoPage As Visio.Page) | |
| '------------------------------------------------------------------------------------------------------------ | |
| ' Macros : HideWireNumChild - Скрывает номера в дочерних проводах (номера полученные по ссылке) | |
| 'На листе остаются только провода с уникальными именами | |
| 'Номера ВСЕХ проводов нужны только при рисовании схемы - для контроля правильности соединения | |
| '------------------------------------------------------------------------------------------------------------ | |
| Dim UserType As Integer 'Тип элемента схемы: клемма, провод, реле | |
| Dim PageName As String | |
| Dim vsoShapeOnPage As Visio.Shape | |
| Dim ThePage As Visio.Shape | |
| Set ThePage = vsoPage.PageSheet | |
| PageName = cListNameCxema 'Имена листов где возможна нумерация | |
| 'Номер схемы. Если одна схема на весь проект, то на всех листах должен быть один номер. По умолчанию = 1 | |
| If ThePage.CellExists("Prop.SA_NazvanieShemy", 0) Then NazvanieShemy = ThePage.Cells("Prop.SA_NazvanieShemy").ResultStr(0) | |
| 'Цикл поиска проводов и скрытия номера | |
| For Each vsoShapeOnPage In vsoPage.Shapes 'Перебираем все шейпы на листе | |
| If ShapeSATypeIs(vsoShapeOnPage, typeWire) Then 'Если в шейпе есть тип, то проверяем чтобы был провод | |
| If vsoShapeOnPage.Cells("Prop.AutoNum").Result(0) = 0 Then 'Отсеиваем шейпы нумеруемые в автомате | |
| If vsoShapeOnPage.Cells("Prop.Number").FormulaU Like "*!*" Then 'Находим дочерние | |
| 'Прячем номер/название | |
| vsoShapeOnPage.Cells("Prop.HideNumber").FormulaU = True | |
| vsoShapeOnPage.Cells("Prop.HideName").FormulaU = True | |
| End If | |
| End If | |
| End If | |
| Next | |
| End Sub | |
| Function ExtractOboz(Oboz) ' Функция определения неизменяемой части обозначения | |
| Dim ObozF As String, i As Integer, Flag As Boolean | |
| Flag = Oboz Like "*[-.,/\]*" | |
| For i = 1 To Len(Oboz) | |
| If Not Flag And Mid(Oboz, i, 1) Like "[a-zA-Zа-яА-Я ]" Then GoSub AddChar | |
| If Flag And Mid(Oboz, i, 1) Like "[a-zA-Zа-яА-Я0-9 ]" Then GoSub AddChar | |
| If Flag And Mid(Oboz, i, 1) Like "[-.,/\]" Then GoSub AddChar | |
| Next | |
| ExtractOboz = ObozF | |
| Exit Function | |
| AddChar: | |
| ObozF = ObozF + Mid(Oboz, i, 1) | |
| Return | |
| End Function | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Dim NazvanieFSA As String | |
| Dim NazvanieShemy As String | |
| Private Sub brnRenumberCx_Click() | |
| ReNumberShemy | |
| Application.EventsEnabled = -1 | |
| ThisDocument.InitEvent | |
| Unload Me | |
| End Sub | |
| Private Sub brnRenumberFSA_Click() | |
| ReNumberFSA | |
| Application.EventsEnabled = -1 | |
| ThisDocument.InitEvent | |
| Unload Me | |
| End Sub | |
| Private Sub UserForm_Initialize() | |
| Fill_cmbxNazvanieShemy | |
| Fill_cmbxNazvanieFSA | |
| cmbxNazvanieShemy.style = fmStyleDropDownList | |
| cmbxNazvanieFSA.style = fmStyleDropDownList | |
| If ActivePage.PageSheet.CellExists("Prop.SA_NazvanieShemy", 0) Then | |
| NazvanieShemy = ActivePage.PageSheet.Cells("Prop.SA_NazvanieShemy").ResultStr(0) | |
| cmbxNazvanieShemy.Text = NazvanieShemy | |
| End If | |
| If ActivePage.PageSheet.CellExists("Prop.SA_NazvanieFSA", 0) Then | |
| NazvanieFSA = ActivePage.PageSheet.Cells("Prop.SA_NazvanieFSA").ResultStr(0) | |
| cmbxNazvanieFSA.Text = NazvanieFSA | |
| End If | |
| With mpRazdel | |
| .Left = Me.Left | |
| .Top = Me.Top | |
| .Width = Me.Width | |
| .Height = Me.Height | |
| .Value = IIf(NazvanieFSA = "", 0, 1) | |
| End With | |
| If NazvanieShemy <> "" Then | |
| obVybCx.Value = True | |
| End If | |
| If NazvanieFSA <> "" Then | |
| obVybFSA.Value = True | |
| End If | |
| If ActiveWindow.Selection.Count > 0 Then | |
| obVydNaListeCx.Value = True | |
| obVydNaListeFSA.Value = True | |
| Else | |
| obVseTipObCx.Value = True 'Все obVybTipObCx.Value = True 'Выбранные | |
| obVseTipObFSA.Value = True 'Все obVybTipObFSA.Value = True 'Выбранные | |
| End If | |
| End Sub | |
| Public Sub ReNumberShemy() | |
| '------------------------------------------------------------------------------------------------------------ | |
| ' Macros : ReNumberShemy - Перенумерация элементов схемы | |
| 'Перенумерация происходит слева направо, сверху вниз | |
| 'независимо от порядка появления элементов на схеме | |
| 'и независимо от их номеров до перенумерации. | |
| 'Если в элементе Prop.AutoNum=0 то он не участвует в перенумерации | |
| 'Перенумерация элементов идет в пределах одной схемы или всех схем | |
| 'Параметры перенумерации задаются в форме frmReNumber | |
| '------------------------------------------------------------------------------------------------------------ | |
| Dim vsoPage As Visio.Page | |
| Dim ThePage As Visio.Shape | |
| Dim vsoShapeOnPage As Visio.Shape | |
| Dim vsoShape As Visio.Shape | |
| Dim colItems As Collection | |
| Dim colTermSelectNames As Collection | |
| Dim colElementSelectNames As Collection | |
| Dim ItemCol As Variant | |
| Dim mstrNames() As String | |
| Dim NumberKlemmnik As Integer | |
| Dim SymNameKlemmnik As String | |
| Dim SAType As Integer | |
| Dim SymName As String 'Буквенная часть нумерации | |
| Dim NazvanieShemy As String 'Нумерация элементов идет в пределах одной схемы (одного номера схемы) | |
| Dim UserType As Integer 'Тип элемента схемы: клемма, провод, реле | |
| Dim PageName As String 'Имена листов где возможна нумерация | |
| Dim colCxem As Collection | |
| Dim Cxema As classCxema | |
| Dim List As classListCxemy | |
| Dim NazvanieShemyOld As String | |
| Dim NextWire As Integer | |
| Dim NextCableSH As Integer | |
| Dim NextTerm As Integer | |
| Dim NextElement As Integer | |
| Dim bWireSelect As Boolean, bCableSHSelect As Boolean, bTermSelect As Boolean, bElementSelect As Boolean | |
| Dim i As Integer | |
| PageName = cListNameCxema 'Имена листов где возможна нумерация | |
| 'Заполняем фильтры на основе выделенных шейпов | |
| If obVydNaListeCx Then 'Выделенные на листе | |
| Set ThePage = ActivePage.PageSheet | |
| If ThePage.CellExists("Prop.SA_NazvanieShemy", 0) Then NazvanieShemy = ThePage.Cells("Prop.SA_NazvanieShemy").ResultStr(0) | |
| Set colTermSelectNames = New Collection | |
| Set colElementSelectNames = New Collection | |
| If ActiveWindow.Selection.Count > 0 Then | |
| 'Заполняем коллекцию уникальными типами элементов | |
| For Each vsoShape In ActiveWindow.Selection | |
| If ShapeSAType(vsoShape) > 1 Then 'Берем только шейпы САПР АСУ | |
| UserType = ShapeSAType(vsoShape) | |
| If vsoShape.CellExists("Prop.AutoNum", 0) Then | |
| If vsoShape.Cells("Prop.AutoNum").Result(0) = 1 Then 'Отсеиваем шейпы нумеруемые вручную | |
| Select Case UserType | |
| Case typeWire 'Провода | |
| bWireSelect = True | |
| Case typeCableSH 'Кабели на схеме электрической | |
| bCableSHSelect = True | |
| Case typeTerm 'Клеммы | |
| bTermSelect = True | |
| On Error Resume Next | |
| colTermSelectNames.Add vsoShape.Cells("Prop.NumberKlemmnik").Result(0) & ";" & vsoShape.Cells("Prop.SymName").ResultStr(0), vsoShape.Cells("Prop.NumberKlemmnik").Result(0) & ";" & vsoShape.Cells("Prop.SymName").ResultStr(0) | |
| Case typeCoil, typeParent, typeElement, typePLCParent, typeSensor, typeActuator ', typeElectroOneWire, typeElectroPlan, typeOPSPlan 'Остальные элементы | |
| bElementSelect = True | |
| On Error Resume Next | |
| colElementSelectNames.Add vsoShape.Cells("User.SAType").Result(0) & ";" & vsoShape.Cells("Prop.SymName").ResultStr(0), vsoShape.Cells("User.SAType").Result(0) & ";" & vsoShape.Cells("Prop.SymName").ResultStr(0) | |
| End Select | |
| End If | |
| End If | |
| End If | |
| Next | |
| End If | |
| End If | |
| 'Заполнение коллекции схем со всеми листами шейпами и фильтрами | |
| Set colCxem = New Collection | |
| Set List = New classListCxemy | |
| NLista = 0 | |
| For Each vsoPage In ActiveDocument.Pages | |
| If vsoPage.Name Like PageName & "*" Then | |
| NazvanieShemy = vsoPage.PageSheet.Cells("Prop.SA_NazvanieShemy").ResultStr(0) | |
| If NazvanieShemy <> NazvanieShemyOld Then | |
| Set Cxema = New classCxema | |
| Set Cxema.colListov = New Collection | |
| Cxema.NameCxema = NazvanieShemy | |
| NazvanieShemyOld = NazvanieShemy | |
| If cbKlemCx Then Set Cxema.colTermNames = New Collection | |
| If cbElCx Or cbDatCx Then Set Cxema.colElementNames = New Collection | |
| End If | |
| On Error Resume Next | |
| colCxem.Add Cxema, Cxema.NameCxema | |
| 'Собираем шейпы и коллекции фильтов | |
| If cbProvCx Or bWireSelect Then Set List.colWires = New Collection | |
| If cbKabCx Or bCableSHSelect Then Set List.colCableSHs = New Collection | |
| If cbKlemCx Or bTermSelect Then Set List.colTerms = New Collection | |
| If cbElCx Or cbDatCx Or bElementSelect Then Set List.colElements = New Collection | |
| For Each vsoShapeOnPage In vsoPage.Shapes 'Перебираем все шейпы на листе | |
| If ShapeSAType(vsoShapeOnPage) > 1 Then 'Берем только шейпы САПР АСУ | |
| UserType = ShapeSAType(vsoShapeOnPage) | |
| If vsoShapeOnPage.CellExists("Prop.AutoNum", 0) Then | |
| If vsoShapeOnPage.Cells("Prop.AutoNum").Result(0) = 1 Then 'Отсеиваем шейпы нумеруемые вручную | |
| Select Case UserType | |
| Case typeWire 'Провода | |
| If cbProvCx Or (obVydNaListeCx And bWireSelect) Then | |
| List.colWires.Add vsoShapeOnPage | |
| End If | |
| Case typeCableSH 'Кабели на схеме электрической | |
| If cbKabCx Or (obVydNaListeCx And bCableSHSelect) Then | |
| List.colCableSHs.Add vsoShapeOnPage | |
| End If | |
| Case typeTerm 'Клеммы | |
| If cbKlemCx Or (obVydNaListeCx And bTermSelect) Then | |
| List.colTerms.Add vsoShapeOnPage | |
| If Not (obVydNaListeCx And bTermSelect) Then | |
| On Error Resume Next | |
| colCxem(Cxema.NameCxema).colTermNames.Add vsoShapeOnPage.Cells("Prop.NumberKlemmnik").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0), vsoShapeOnPage.Cells("Prop.NumberKlemmnik").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) | |
| End If | |
| End If | |
| Case typeCoil, typeParent, typeElement, typePLCParent, typeSensor, typeActuator ', typeElectroOneWire, typeElectroPlan, typeOPSPlan 'Остальные элементы | |
| If cbElCx Or cbDatCx Or (obVydNaListeCx And bElementSelect) Then | |
| List.colElements.Add vsoShapeOnPage | |
| If Not (obVydNaListeCx And bElementSelect) Then | |
| On Error Resume Next | |
| colCxem(Cxema.NameCxema).colElementNames.Add vsoShapeOnPage.Cells("User.SAType").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0), vsoShapeOnPage.Cells("User.SAType").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) | |
| End If | |
| End If | |
| End Select | |
| End If | |
| End If | |
| End If | |
| Next | |
| 'Для перенумерации на основе выделенных присваиваем коллекции фильтров выделенных | |
| If obVydNaListeCx Then | |
| If bTermSelect Then | |
| Set colCxem(Cxema.NameCxema).colTermNames = colTermSelectNames | |
| End If | |
| If bElementSelect Then | |
| Set colCxem(Cxema.NameCxema).colElementNames = colElementSelectNames | |
| End If | |
| End If | |
| colCxem(Cxema.NameCxema).colListov.Add List, CStr(colCxem(Cxema.NameCxema).colListov.Count + 1) | |
| Set List = New classListCxemy | |
| End If | |
| Next | |
| 'Перенумеровываем коллекции | |
| For i = 1 To colCxem.Count | |
| If obVseCx And Not obVydNaListeCx Then | |
| NazvanieShemy = cmbxNazvanieShemy.List(i - 1) | |
| GoSub RenWireKab | |
| GoSub RenTerm | |
| GoSub RenElement | |
| Else | |
| If obVydNaListeCx Then | |
| NazvanieShemy = ThePage.Cells("Prop.SA_NazvanieShemy").ResultStr(0) | |
| Else | |
| NazvanieShemy = cmbxNazvanieShemy.Text | |
| End If | |
| GoSub RenWireKab | |
| GoSub RenTerm | |
| GoSub RenElement | |
| Exit For | |
| End If | |
| Next | |
| Exit Sub | |
| RenWireKab: | |
| NextWire = 0 | |
| NextCableSH = 0 | |
| For Each List In colCxem(NazvanieShemy).colListov | |
| If cbProvCx Or bWireSelect Then | |
| NextWire = ReNumber(List.colWires, NextWire) | |
| End If | |
| If cbKabCx Or bCableSHSelect Then | |
| NextCableSH = ReNumber(List.colCableSHs, NextCableSH) | |
| End If | |
| Next | |
| Return | |
| RenTerm: | |
| If cbKlemCx Or bTermSelect Then | |
| If colCxem(NazvanieShemy).colTermNames.Count > 0 Then | |
| For Each ItemCol In colCxem(NazvanieShemy).colTermNames | |
| mstrNames = Split(ItemCol, ";") | |
| NumberKlemmnik = CInt(mstrNames(0)) | |
| SymNameKlemmnik = mstrNames(1) | |
| NextTerm = 0 | |
| For Each List In colCxem(NazvanieShemy).colListov | |
| 'По фильтрам заполняем коллецию для перенумерации | |
| Set colItems = New Collection | |
| For Each vsoShapeOnPage In List.colTerms | |
| If vsoShapeOnPage.Cells("Prop.NumberKlemmnik").Result(0) = NumberKlemmnik And vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) = SymNameKlemmnik Then | |
| colItems.Add vsoShapeOnPage | |
| End If | |
| Next | |
| NextTerm = ReNumber(colItems, NextTerm) | |
| Next | |
| Next | |
| End If | |
| End If | |
| Return | |
| RenElement: | |
| If cbElCx Or cbDatCx Or bElementSelect Then | |
| If colCxem(NazvanieShemy).colElementNames.Count > 0 Then | |
| For Each ItemCol In colCxem(NazvanieShemy).colElementNames | |
| mstrNames = Split(ItemCol, ";") | |
| SAType = CInt(mstrNames(0)) | |
| SymName = mstrNames(1) | |
| NextElement = 0 | |
| For Each List In colCxem(NazvanieShemy).colListov | |
| 'По фильтрам заполняем коллецию для перенумерации | |
| Set colItems = New Collection | |
| For Each vsoShapeOnPage In List.colElements | |
| If vsoShapeOnPage.Cells("User.SAType").Result(0) = SAType And vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) = SymName Then | |
| colItems.Add vsoShapeOnPage | |
| End If | |
| Next | |
| NextElement = ReNumber(colItems, NextElement) | |
| Next | |
| Next | |
| End If | |
| End If | |
| Return | |
| End Sub | |
| Public Sub ReNumberFSA() | |
| '------------------------------------------------------------------------------------------------------------ | |
| ' Macros : ReNumberFSA - Перенумерация элементов ФСА | |
| 'Нумерация ведется с учетом имени контура | |
| 'Перенумерация происходит слева направо, сверху вниз | |
| 'независимо от порядка появления элементов на схеме | |
| 'и независимо от их номеров до перенумерации. | |
| 'Если в элементе Prop.AutoNum=0 то он не участвует в перенумерации | |
| 'Перенумерация элементов идет в пределах одной ФСА или всех ФСА | |
| 'Параметры перенумерации задаются в форме frmReNumber | |
| '------------------------------------------------------------------------------------------------------------ | |
| Dim vsoPage As Visio.Page | |
| Dim ThePage As Visio.Shape | |
| Dim vsoShapeOnPage As Visio.Shape | |
| Dim vsoShape As Visio.Shape | |
| Dim colItems As Collection | |
| Dim colElementSelectNames As Collection | |
| Dim ItemCol As Variant | |
| Dim mstrNames() As String | |
| Dim SAType As Integer | |
| Dim NameKontur As String | |
| Dim SymName As String 'Буквенная часть нумерации | |
| Dim NazvanieFSA As String 'Нумерация элементов идет в пределах одной схемы (одного номера схемы) | |
| Dim UserType As Integer 'Тип элемента схемы: клемма, провод, реле | |
| Dim PageName As String 'Имена листов где возможна нумерация | |
| Dim colFSA As Collection | |
| Dim FSA As classFSA | |
| Dim List As classListFSA | |
| Dim NazvanieFSAOld As String | |
| Dim NextPodval As Integer | |
| Dim NextElement As Integer | |
| Dim bPodvalSelect As Boolean, bElementSelect As Boolean | |
| Dim i As Integer | |
| PageName = cListNameFSA 'Имена листов где возможна нумерация | |
| 'Заполняем фильтры на основе выделенных шейпов | |
| If obVydNaListeFSA Then 'Выделенные на листе | |
| Set ThePage = ActivePage.PageSheet | |
| If ThePage.CellExists("Prop.SA_NazvanieFSA", 0) Then NazvanieFSA = ThePage.Cells("Prop.SA_NazvanieFSA").ResultStr(0) | |
| Set colElementSelectNames = New Collection | |
| If ActiveWindow.Selection.Count > 0 Then | |
| 'Заполняем коллекцию уникальными типами элементов | |
| For Each vsoShape In ActiveWindow.Selection | |
| If ShapeSAType(vsoShape) > 1 Then 'Берем только шейпы САПР АСУ | |
| UserType = ShapeSAType(vsoShape) | |
| If vsoShape.CellExists("Prop.AutoNum", 0) Then | |
| If vsoShape.Cells("Prop.AutoNum").Result(0) = 1 Then 'Отсеиваем шейпы нумеруемые вручную | |
| Select Case UserType | |
| Case typeFSAPodval 'Подвал на ФСА | |
| bPodvalSelect = True | |
| Case typeFSASensor 'Датчик на ФСА | |
| bElementSelect = True | |
| On Error Resume Next | |
| colElementSelectNames.Add vsoShape.Cells("User.SAType").Result(0) & ";" & vsoShape.Cells("Prop.SymName").ResultStr(0) & ";" & vsoShape.Cells("Prop.NameKontur").ResultStr(0), vsoShape.Cells("User.SAType").Result(0) & ";" & vsoShape.Cells("Prop.SymName").ResultStr(0) & ";" & vsoShape.Cells("Prop.NameKontur").ResultStr(0) | |
| End Select | |
| End If | |
| End If | |
| End If | |
| Next | |
| End If | |
| End If | |
| 'Заполнение коллекции схем со всеми листами шейпами и фильтрами | |
| Set colFSA = New Collection | |
| Set List = New classListFSA | |
| NLista = 0 | |
| For Each vsoPage In ActiveDocument.Pages | |
| If vsoPage.Name Like PageName & "*" Then | |
| NazvanieFSA = vsoPage.PageSheet.Cells("Prop.SA_NazvanieFSA").ResultStr(0) | |
| If NazvanieFSA <> NazvanieFSAOld Then | |
| Set FSA = New classFSA | |
| Set FSA.colListov = New Collection | |
| FSA.NameFSA = NazvanieFSA | |
| NazvanieFSAOld = NazvanieFSA | |
| If cbDatFSA Then Set FSA.colElementNames = New Collection | |
| End If | |
| On Error Resume Next | |
| colFSA.Add FSA, FSA.NameFSA | |
| 'Собираем шейпы и коллекции фильтов | |
| If cbPodFSA Or bPodvalSelect Then Set List.colPodvals = New Collection | |
| If cbDatFSA Or bElementSelect Then Set List.colElements = New Collection | |
| For Each vsoShapeOnPage In vsoPage.Shapes 'Перебираем все шейпы на листе | |
| If ShapeSAType(vsoShapeOnPage) > 1 Then 'Берем только шейпы САПР АСУ | |
| UserType = ShapeSAType(vsoShapeOnPage) | |
| If vsoShapeOnPage.CellExists("Prop.AutoNum", 0) Then | |
| If vsoShapeOnPage.Cells("Prop.AutoNum").Result(0) = 1 Then 'Отсеиваем шейпы нумеруемые вручную | |
| Select Case UserType | |
| Case typeFSAPodval 'Подвал на ФСА | |
| If cbPodFSA Or (obVydNaListeFSA And bPodvalSelect) Then | |
| List.colPodvals.Add vsoShapeOnPage | |
| End If | |
| Case typeFSASensor 'Датчик на ФСА | |
| If cbDatFSA Or (obVydNaListeFSA And bElementSelect) Then | |
| List.colElements.Add vsoShapeOnPage | |
| If Not (obVydNaListeFSA And bElementSelect) Then | |
| On Error Resume Next | |
| colFSA(FSA.NameFSA).colElementNames.Add vsoShapeOnPage.Cells("User.SAType").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) & ";" & vsoShapeOnPage.Cells("Prop.NameKontur").ResultStr(0), vsoShapeOnPage.Cells("User.SAType").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) & ";" & vsoShapeOnPage.Cells("Prop.NameKontur").ResultStr(0) | |
| End If | |
| End If | |
| End Select | |
| End If | |
| End If | |
| End If | |
| Next | |
| 'Для перенумерации на основе выделенных присваиваем коллекции фильтров выделенных | |
| If obVydNaListeFSA Then | |
| If bElementSelect Then | |
| Set colFSA(FSA.NameFSA).colElementNames = colElementSelectNames | |
| End If | |
| End If | |
| colFSA(FSA.NameFSA).colListov.Add List, CStr(colFSA(FSA.NameFSA).colListov.Count + 1) | |
| Set List = New classListFSA | |
| End If | |
| Next | |
| 'Перенумеровываем коллекции | |
| For i = 1 To colFSA.Count | |
| If obVseFSA And Not obVydNaListeFSA Then | |
| NazvanieFSA = cmbxNazvanieFSA.List(i - 1) | |
| GoSub RenPodval | |
| GoSub RenElement | |
| Else | |
| If obVydNaListeFSA Then | |
| NazvanieFSA = ThePage.Cells("Prop.SA_NazvanieFSA").ResultStr(0) | |
| Else | |
| NazvanieFSA = cmbxNazvanieFSA.Text | |
| End If | |
| GoSub RenPodval | |
| GoSub RenElement | |
| Exit For | |
| End If | |
| Next | |
| Exit Sub | |
| RenPodval: | |
| NextPodval = 0 | |
| For Each List In colFSA(NazvanieFSA).colListov | |
| If cbPodFSA Or bPodvalSelect Then | |
| NextPodval = ReNumber(List.colPodvals, NextPodval) | |
| End If | |
| Next | |
| Return | |
| RenElement: | |
| If cbDatFSA Or bElementSelect Then | |
| If colFSA(NazvanieFSA).colElementNames.Count > 0 Then | |
| For Each ItemCol In colFSA(NazvanieFSA).colElementNames | |
| mstrNames = Split(ItemCol, ";") | |
| SAType = CInt(mstrNames(0)) | |
| SymName = mstrNames(1) | |
| NameKontur = mstrNames(2) | |
| NextElement = 0 | |
| For Each List In colFSA(NazvanieFSA).colListov | |
| 'По фильтрам заполняем коллецию для перенумерации | |
| Set colItems = New Collection | |
| For Each vsoShapeOnPage In List.colElements | |
| If vsoShapeOnPage.Cells("User.SAType").Result(0) = SAType And vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) = SymName And vsoShapeOnPage.Cells("Prop.NameKontur").ResultStr(0) = NameKontur Then | |
| colItems.Add vsoShapeOnPage | |
| End If | |
| Next | |
| NextElement = ReNumber(colItems, NextElement) | |
| Next | |
| Next | |
| End If | |
| End If | |
| Return | |
| End Sub | |
| Sub Fill_cmbxNazvanieShemy() | |
| Dim vsoPage As Visio.Page | |
| Dim PageName As String | |
| Dim PropPageSheet As String | |
| Dim mstrPropPageSheet() As String | |
| Dim i As Integer | |
| PageName = cListNameCxema | |
| For Each vsoPage In ActiveDocument.Pages | |
| If vsoPage.Name Like PageName & "*" Then | |
| PropPageSheet = vsoPage.PageSheet.Cells("Prop.SA_NazvanieShemy.Format").ResultStr(0) | |
| Exit For | |
| End If | |
| Next | |
| cmbxNazvanieShemy.Clear | |
| mstrPropPageSheet = Split(PropPageSheet, ";") | |
| For i = 0 To UBound(mstrPropPageSheet) | |
| cmbxNazvanieShemy.AddItem mstrPropPageSheet(i) | |
| Next | |
| cmbxNazvanieShemy.Text = "" | |
| End Sub | |
| Sub Fill_cmbxNazvanieFSA() | |
| Dim vsoPage As Visio.Page | |
| Dim PageName As String | |
| Dim PropPageSheet As String | |
| Dim mstrPropPageSheet() As String | |
| Dim i As Integer | |
| PageName = cListNameFSA | |
| For Each vsoPage In ActiveDocument.Pages | |
| If vsoPage.Name Like PageName & "*" Then | |
| PropPageSheet = vsoPage.PageSheet.Cells("Prop.SA_NazvanieFSA.Format").ResultStr(0) | |
| Exit For | |
| End If | |
| Next | |
| cmbxNazvanieFSA.Clear | |
| mstrPropPageSheet = Split(PropPageSheet, ";") | |
| For i = 0 To UBound(mstrPropPageSheet) | |
| cmbxNazvanieFSA.AddItem mstrPropPageSheet(i) | |
| Next | |
| cmbxNazvanieFSA.Text = "" | |
| End Sub | |
| Private Sub obVseTipObCx_Change() | |
| If obVseTipObCx = True Then | |
| cbElCx.Value = True | |
| cbProvCx.Value = True | |
| cbKlemCx.Value = True | |
| cbKabCx.Value = True | |
| cbDatCx.Value = True | |
| End If | |
| End Sub | |
| Private Sub obVseTipObFSA_Change() | |
| If obVseTipObFSA = True Then | |
| cbDatFSA.Value = True | |
| cbPodFSA.Value = True | |
| End If | |
| End Sub | |
| Private Sub obVydNaListeCx_Change() | |
| cbElCx.Value = False | |
| cbProvCx.Value = False | |
| cbKlemCx.Value = False | |
| cbKabCx.Value = False | |
| cbDatCx.Value = False | |
| End Sub | |
| Private Sub obVydNaListeFSA_Change() | |
| cbDatFSA.Value = False | |
| cbPodFSA.Value = False | |
| End Sub | |
| Private Sub cbDatFSA_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObFSA.Value = True | |
| End Sub | |
| Private Sub cbPodFSA_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObFSA.Value = True | |
| End Sub | |
| Private Sub cbElCx_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObCx.Value = True | |
| End Sub | |
| Private Sub cbProvCx_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObCx.Value = True | |
| End Sub | |
| Private Sub cbKlemCx_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObCx.Value = True | |
| End Sub | |
| Private Sub cbKabCx_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObCx.Value = True | |
| End Sub | |
| Private Sub cbDatCx_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single) | |
| obVybTipObCx.Value = True | |
| End Sub | |
| Private Sub btnCloseCx_Click() | |
| Application.EventsEnabled = -1 | |
| ThisDocument.InitEvent | |
| Unload Me | |
| End Sub | |
| Private Sub btnCloseFSA_Click() | |
| Application.EventsEnabled = -1 | |
| ThisDocument.InitEvent | |
| Unload Me | |
| End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment