Спецификация - сбор данных и оформление

frmSpecifikaciya.frm

Dim NazvanieFSA As String
Dim NazvanieShemy As String

Private Sub btnExportCx_Click()
    FindElementShemyToExcel
    Application.EventsEnabled = -1
    ThisDocument.InitEvent
    Unload Me
End Sub

Private Sub btnExportFSA_Click()
    
    Application.EventsEnabled = -1
    ThisDocument.InitEvent
    Unload Me
End Sub

Private Sub obTekListCx_Click()
    frameOutListCx.Visible = True
End Sub

Private Sub obTekListFSA_Click()
    frameOutListFSA.Visible = True
End Sub

Private Sub obVseCx_Click()
    frameOutListCx.Visible = False
End Sub

Private Sub obVseFSA_Click()
    frameOutListFSA.Visible = False
End Sub

Private Sub obVybCx_Click()
    frameOutListCx.Visible = False
End Sub

Private Sub obVybFSA_Click()
    frameOutListFSA.Visible = False
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
    
    obNaListFSA.Value = True
    obNaListCx.Value = True
End Sub

Public Sub FindElementShemyToExcel()
'------------------------------------------------------------------------------------------------------------
' Macros        : FindElementShemyToExcel - Поиск элементов схемы и заполнение полей спецификации

                '
                '
'------------------------------------------------------------------------------------------------------------
    Dim clsStrokaSpecif As classStrokaSpecifikacii
    Dim colStrokaSpecif As Collection
    Dim colCxem As Collection
    Dim nCount As Double
    Dim strColKey As String
    Dim vsoPage As Visio.Page
    Dim vsoShapeOnPage As Visio.Shape
    Dim NazvanieShemy As String   'Нумерация элементов идет в пределах одной схемы (одного номера схемы)
    Dim UserType As Integer     'Тип элемента схемы: клемма, провод, реле
    Dim PageName As String      'Имена листов где возможна нумерация
    Dim i As Integer
    Dim mNum() As String
    Dim Cxema As classCxema
    Dim xx As Integer
    '-------Вывод EXCEL---------
    Dim apx As Excel.Application
    Dim WB As Excel.Workbook
    Dim sht As Excel.Sheets
    Dim en As String
    Dim un As String
    Dim sPath, sFile As String
    Dim NameSheet As String
    Dim str As Integer
    Dim Mstr() As String
    '-------Вывод на Лист-------
    Dim shpPerechenElementov As Visio.Shape
    Dim shpRow As Visio.Shape
    Dim shpCel As Visio.Shape
    Dim ncell As Integer
    Dim NRow As Integer
    
    PageName = cListNameCxema  'Имена листов
    
    Set colCxem = New Collection
    Set Cxema = New classCxema
    Set Cxema.colListov = New Collection
    Set clsStrokaSpecif = New classStrokaSpecifikacii
    Set colStrokaSpecif = New Collection

    For i = 1 To cmbxNazvanieShemy.ListCount
        NazvanieShemy = cmbxNazvanieShemy.List(i - 1)
        Cxema.NameCxema = NazvanieShemy
        For Each vsoPage In ActiveDocument.Pages
            If vsoPage.Name Like PageName & "*" Then
                If NazvanieShemy = vsoPage.PageSheet.Cells("Prop.SA_NazvanieShemy").ResultStr(0) Then
                    Cxema.colListov.Add vsoPage, vsoPage.Name
                End If
            End If
        Next
        If Cxema.colListov.Count > 0 Then
            colCxem.Add Cxema, NazvanieShemy
        End If
        Set Cxema = New classCxema
        Set Cxema.colListov = New Collection
    Next
    
    i = 0
    If obVseCx Then
        For Each Cxema In colCxem
            NazvanieShemy = Cxema.NameCxema
            For Each vsoPage In Cxema.colListov
                GoSub ShpOnPage
            Next
            If i > 0 Then
                GoSub OutExcelNext
            Else
                GoSub OutExcel
            End If
            i = i + 1
        Next
        WB.Save
    ElseIf obVybCx Then
        NazvanieShemy = cmbxNazvanieShemy.Text
        For Each vsoPage In colCxem(NazvanieShemy).colListov
            GoSub ShpOnPage
        Next
        GoSub OutExcel
        WB.Save
    ElseIf obTekListCx Then
        Set vsoPage = ActivePage
        GoSub ShpOnPage
        If obVExcelCx Then
            GoSub OutExcel
            WB.Save
        Else 'obNaListCx
            GoSub OutList
        End If
    End If

Exit Sub

'-----------------------------------------------------------------------------------
ShpOnPage:
    For Each vsoShapeOnPage In vsoPage.Shapes    'Перебираем все шейпы на листе
        If ShapeSAType(vsoShapeOnPage) > 1 Then   'Берем только шейпы САПР АСУ
            UserType = ShapeSAType(vsoShapeOnPage)
            Set clsStrokaSpecif = New classStrokaSpecifikacii
            clsStrokaSpecif.SymName = vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0)
            clsStrokaSpecif.SAType = vsoShapeOnPage.Cells("User.SAType").Result(0)
            clsStrokaSpecif.NazvanieDB = vsoShapeOnPage.Cells("Prop.NazvanieDB").ResultStr(0)
            clsStrokaSpecif.ArtikulDB = vsoShapeOnPage.Cells("Prop.ArtikulDB").ResultStr(0)
            clsStrokaSpecif.ProizvoditelDB = vsoShapeOnPage.Cells("Prop.ProizvoditelDB").ResultStr(0)
            clsStrokaSpecif.CenaDB = vsoShapeOnPage.Cells("Prop.CenaDB").ResultStr(0)
            clsStrokaSpecif.EdDB = vsoShapeOnPage.Cells("Prop.EdDB").ResultStr(0)
            clsStrokaSpecif.KolVo = 1
            clsStrokaSpecif.PozOboznach = vsoShapeOnPage.Cells("Prop.Number").ResultStr(0)
            clsStrokaSpecif.KodPoziciiDB = vsoShapeOnPage.Cells("User.KodPoziciiDB").Formula
            strColKey = vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0) & ";" & vsoShapeOnPage.Cells("User.SAType").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.ArtikulDB").ResultStr(0)
            
            Select Case UserType
                Case typeCableSH 'Кабели на схеме электрической
                    clsStrokaSpecif.SymName = IIf(vsoShapeOnPage.Cells("Prop.BukvOboz").Result(0), vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0), "")
                    clsStrokaSpecif.KolVo = vsoShapeOnPage.Cells("Prop.Dlina").Result(0)
                    strColKey = IIf(vsoShapeOnPage.Cells("Prop.BukvOboz").Result(0), vsoShapeOnPage.Cells("Prop.SymName").ResultStr(0), "") & ";" & vsoShapeOnPage.Cells("User.SAType").Result(0) & ";" & vsoShapeOnPage.Cells("Prop.ArtikulDB").ResultStr(0)
                    On Error Resume Next
                    colStrokaSpecif.Add clsStrokaSpecif, strColKey
                    If colStrokaSpecif.Count = nCount Then 'Если кол-во не увеличелось, значит уже есть такой элемент - увеличиваем .KolVo в том, который есть
                        colStrokaSpecif(strColKey).KolVo = colStrokaSpecif(strColKey).KolVo + vsoShapeOnPage.Cells("Prop.Dlina").Result(0)
                        colStrokaSpecif(strColKey).PozOboznach = colStrokaSpecif(strColKey).PozOboznach & ";" & vsoShapeOnPage.Cells("Prop.Number").ResultStr(0)
                    Else
                        nCount = colStrokaSpecif.Count
                    End If
                Case typeTerm 'Клеммы
                    clsStrokaSpecif.PozOboznach = vsoShapeOnPage.Cells("Prop.NumberKlemmnik").ResultStr(0)
                    On Error Resume Next
                    colStrokaSpecif.Add clsStrokaSpecif, strColKey
                    If colStrokaSpecif.Count = nCount Then 'Если кол-во не увеличелось, значит уже есть такой элемент - увеличиваем .KolVo в том, который есть
                        colStrokaSpecif(strColKey).KolVo = colStrokaSpecif(strColKey).KolVo + 1
                        mNum = Split(colStrokaSpecif(strColKey).PozOboznach, ";")
                        colStrokaSpecif(strColKey).PozOboznach = colStrokaSpecif(strColKey).PozOboznach & IIf(vsoShapeOnPage.Cells("Prop.NumberKlemmnik").ResultStr(0) = mNum(UBound(mNum)), "", ";" & vsoShapeOnPage.Cells("Prop.NumberKlemmnik").ResultStr(0))
                    Else
                        nCount = colStrokaSpecif.Count
                    End If

                Case typeCoil, typeParent, typeElement, typePLCParent, typePLCModParent, typeSensor, typeActuator ', typeElectroOneWire, typeElectroPlan, typeOPSPlan 'Остальные элементы
                    On Error Resume Next
                    colStrokaSpecif.Add clsStrokaSpecif, strColKey
                    If colStrokaSpecif.Count = nCount Then 'Если кол-во не увеличелось, значит уже есть такой элемент - увеличиваем .KolVo в том, который есть
                        colStrokaSpecif(strColKey).KolVo = colStrokaSpecif(strColKey).KolVo + 1
                        colStrokaSpecif(strColKey).PozOboznach = colStrokaSpecif(strColKey).PozOboznach & ";" & vsoShapeOnPage.Cells("Prop.Number").ResultStr(0)
                    Else
                        nCount = colStrokaSpecif.Count
                    End If
            End Select
        End If
    Next
Return

SortReplace:
    'Сортировка номеров и замена последовательных позиционных обозначений
    For Each clsStrokaSpecif In colStrokaSpecif
        clsStrokaSpecif.PozOboznach = SortNumInString(clsStrokaSpecif.PozOboznach)
        clsStrokaSpecif.PozOboznach = ReplaceSequenceInString(clsStrokaSpecif.PozOboznach)
    Next
Return

OutExcel:
    
    Set apx = CreateObject("Excel.Application")
    sPath = Visio.ActiveDocument.path
    sFileName = "SP_2_Visio.xls"
    sFile = sPath & sFileName
    
    
    If Dir(sFile, 16) = "" Then 'есть хотя бы один файл
        MsgBox "Файл " & sFileName & " не найден в папке: " & sPath, vbCritical, "Ошибка"
        Exit Sub
    End If
    
    Set WB = apx.Workbooks.Open(sFile)

    'Set wb = apx.Workbooks.Add
    'un = Format(Now(), "yyyy_mm_dd")
    'pth = Visio.ActiveDocument.Path
    'en = pth & "СП_" & un & ".xls"
    apx.Visible = True

OutExcelNext:

    GoSub SortReplace
    
    str = colStrokaSpecif.Count
    If obTekListCx Then
        NameSheet = NazvanieShemy & "_" & vsoPage.Name
    Else
        NameSheet = NazvanieShemy
    End If
    'удаляем старый лист
    apx.DisplayAlerts = False
    On Error Resume Next
    apx.Sheets(NameSheet).Delete
    apx.DisplayAlerts = True
    'добавляем новый
    apx.Sheets("СП").Copy After:=apx.Sheets(apx.Worksheets.Count)
    
    apx.Sheets("СП (2)").Name = NameSheet
    
    lLastRow = apx.Sheets(NameSheet).Cells(apx.Rows.Count, 1).End(xlUp).Row
    apx.Application.CutCopyMode = False
    apx.Worksheets(NameSheet).Activate
    apx.ActiveSheet.Rows("6:" & lLastRow).Delete Shift:=xlUp
    apx.ActiveSheet.Range("A3:I5").ClearContents

    
    WB.Activate
    apx.ActiveSheet.Range("J1") = Format(Now(), "yyyy.mm.dd hh:mm:ss")
    apx.ActiveSheet.Range("D3:D65536").NumberFormat = "@"
    For xx = 1 To str
        If colStrokaSpecif(xx).ArtikulDB Like "Набор_*" Then
            Mstr = Split(colStrokaSpecif(xx).KodPoziciiDB, "/")
            NElemNabora = AddSostavNaboraIzBD(colStrokaSpecif, colStrokaSpecif(xx).KolVo, Mstr(0), xx)
            str = str + NElemNabora - 1
            colStrokaSpecif.Remove xx
        End If
    Next
    
    If str < 5 Then nstr = 5 Else nstr = str
    apx.ActiveSheet.Rows("5:" & nstr + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    For xx = 1 To str
        WB.Sheets(NameSheet).Cells(xx + 2, 1) = "=A" & xx + 1 & "+1" '1 Позиция
        WB.Sheets(NameSheet).Cells(xx + 2, 2) = colStrokaSpecif(xx).NazvanieDB '2 Наименование и техническая характеристика
        WB.Sheets(NameSheet).Cells(xx + 2, 3) = colStrokaSpecif(xx).ArtikulDB '3 Тип, марка, обозначение документа, опросного листа
        WB.Sheets(NameSheet).Cells(xx + 2, 4) = PozNameInString(colStrokaSpecif(xx).PozOboznach, colStrokaSpecif(xx).SymName) '4 Код оборудования, изделия, материала
        WB.Sheets(NameSheet).Cells(xx + 2, 5) = colStrokaSpecif(xx).ProizvoditelDB '5 Завод-изготовитель
        WB.Sheets(NameSheet).Cells(xx + 2, 6) = colStrokaSpecif(xx).EdDB '6 Единица измерения
        WB.Sheets(NameSheet).Cells(xx + 2, 7) = colStrokaSpecif(xx).KolVo '7 Количество
        'WB.Sheets(NameSheet).Cells(xx + 2, 8) = colStrokaSpecif(xx) '8 Масса единицы, кг
        'WB.Sheets(NameSheet).Cells(xx + 2, 9) = colStrokaSpecif(xx) '9 Примечание
        WB.Sheets(NameSheet).Cells(xx + 2, 11) = CSng(colStrokaSpecif(xx).CenaDB)  'Цена
        WB.Sheets(NameSheet).Cells(xx + 2, 12) = "=K" & xx + 2 & "*G" & xx + 2
        'wb.Sheets(NameSheet).Range("A" & (xx + 2)).Select 'для наглядности
    Next

    WB.Sheets(NameSheet).Range("A3") = 1
    WB.Sheets(NameSheet).Range("K2") = "Цена"
    WB.Sheets(NameSheet).Range("L2") = "Сумма"
    WB.Sheets(NameSheet).Range("K2:L2").HorizontalAlignment = xlRight
    WB.Sheets(NameSheet).Range("K2:L2").VerticalAlignment = xlCenter
    apx.ActiveSheet.Range("A3:I" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).WrapText = False
    apx.ActiveSheet.Range("A3:I" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).RowHeight = 20 'Если ячейки, в которых были многострочные тексты, были растянуты по высоте, то мы их приводим в нормальный вид
    apx.ActiveSheet.Range("B3:B" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).HorizontalAlignment = xlLeft
    apx.ActiveSheet.Range("K3:L" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).NumberFormat = "#,##0"
    apx.ActiveSheet.Range("L" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlUp).Row + 1).FormulaLocal = "=СУММ(L3:L" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlUp).Row & ")"
    For i = 7 To 12: Range("K2:L" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlUp).Row).Borders(i).Weight = 2: Next
    apx.ActiveSheet.Range("K2:L" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).Columns.AutoFit
    apx.ActiveSheet.Range("J1").Select
    
    Set clsStrokaSpecif = New classStrokaSpecifikacii
    Set colStrokaSpecif = New Collection
    
'    WB.Save
'    WB.Close SaveChanges:=True
'    apx.Quit
'    MsgBox "Спецификация экспортирована в файл SP_2_Visio.xls на лист " & NameSheet, vbInformation
Return

OutList:
    GoSub SortReplace
    ActivePage.Drop Application.Documents.Item("SAPR_ASU_OFORM.vss").Masters.Item("ПЭ"), 0, ActivePage.PageSheet.Cells("PageHeight").Result(mm) - 10 / 25.4
    Set shpPerechenElementov = Application.ActiveWindow.Selection(1)
    str = colStrokaSpecif.Count
    For NRow = 1 To str
        If colStrokaSpecif(NRow).ArtikulDB Like "Набор_*" Then
            Mstr = Split(colStrokaSpecif(NRow).KodPoziciiDB, "/")
            NElemNabora = AddSostavNaboraIzBD(colStrokaSpecif, colStrokaSpecif(NRow).KolVo, Mstr(0), NRow)
            If NRow < 5 Then nstr = 5 Else nstr = NRow
            str = str + NElemNabora - 1
            colStrokaSpecif.Remove NRow
        End If
    Next
    str = colStrokaSpecif.Count
    If str > 30 Then str = 30: MsgBox "Элементов на листе больше, чем строк в таблице(30): " & colStrokaSpecif.Count & vbNewLine & vbNewLine & "Используйте вывод в Excel для разбивки на несколько таблиц", vbExclamation, "Перечень элементов"
    For NRow = 1 To str
        Set shpRow = shpPerechenElementov.Shapes("row" & NRow)
        shpRow.Shapes(NRow & ".1").Text = PozNameInString(colStrokaSpecif(NRow).PozOboznach, colStrokaSpecif(NRow).SymName)
        shpRow.Shapes(NRow & ".2").Text = colStrokaSpecif(NRow).NazvanieDB
        shpRow.Shapes(NRow & ".3").Text = colStrokaSpecif(NRow).KolVo
        shpRow.Shapes(NRow & ".4").Text = colStrokaSpecif(NRow).ArtikulDB
        If shpRow.Shapes(NRow & ".3").Text = " " Then
            shpRow.Shapes(NRow & ".2").CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "1" 'По центру
            shpRow.Shapes(NRow & ".2").CellsSRC(visSectionCharacter, 0, visCharacterStyle).FormulaU = visItalic + visUnderLine 'Курсив+Подчеркивание
        End If
        shpRow.Shapes(NRow & ".2").CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "0"
        shpRow.Shapes(NRow & ".4").CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "0"
    Next
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 btnCloseCx_Click()
    Application.EventsEnabled = -1
    ThisDocument.InitEvent
    Unload Me
End Sub

Private Sub btnCloseFSA_Click()
    Application.EventsEnabled = -1
    ThisDocument.InitEvent
    Unload Me
End Sub

Specifikaciya.bas

'------------------------------------------------------------------------------------------------------------
' Module        : Specifikaciya - Спецификация
' Author        : gtfox
' Date          : 2019.09.22
' Description   : spDEL - Удаляет листы спецификации
                ' spADD_Excel_Razbienie - Добавляет листы спецификации из Excel из листа SP_2_Visio (после разбиения на ячейки)
                ' spADD_Visio_Perenos - Добавляет листы спецификации из Excel из листа SP (перенос длинных строк делает визио)
                ' spEXP_2_XLS – Экспортирует спецификацию из Visio в Excel
                ' SP_2_Visio.xls -Спецификация
                ' Лист SP содержит исходную спецификацию, с многострочным текстом в одной ячейке.
                ' Лист SP_2_Visio создается автоматически и содержит лист SP с порезанными однострочными ячейками (в дальнейшем не используется + перезаписывается при каждом вызове макроса)
                ' Лист EXP_2_XLS содержит экспортированную из Visio спецификацию (если вы вносили изменения в спецификацию в самом Visio) Создается автоматически макросом + перезаписывается при каждом вызове макроса
                ' Основная проблема спецификации – длинные строки, которые надо разбивать/переносить.
                ' У Surrogate перенос делает Visio, а расчет высоты получившейся строки делает ShapeSheet. В 2007 версии VBA выполняется быстрее пересчета формул в ShapeSheet и макрос не получает высоту вовремя. Исправлено
                ' Я решил разбивать строки в Excel, и тогда в Visio не надо считать высоту через ShapeSheet.
                ' Деление многострочной ячейки на строки происходит на основе особенности реализации шейпа надпись в Excel. Задаем ширину прямоугольника и помещаем длинный текст. Он переносится, чтобы поместится в ширину. А особенностью является то, что мы можем обращаться отдельно к каждой получившейся строке в этом прямоугольнике через коллекции.
                ' Макрос написан на основе singleTextCellToRows https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=77447&TITLE_SEO=77447-perenos-teksta-na-sleduyushchuyu-stroku-pri-zapolnenii-stolbtsa-po-shi&MID=841387#message841387
' Link          : https://visio.getbb.ru/viewtopic.php?p=14130, https://github.com/gtfox/SAPR_ASU, https://yadi.sk/d/24V8ngEM_8KXyg
'------------------------------------------------------------------------------------------------------------
                'на основе этого:
                '------------------------------------------------------------------------------------------------------------
                ' Module    : speka2003 Спецификация
                ' Author    : Surrogate
                ' Date      : 07.11.2012
                ' Purpose   : Спецификация: перенос данных из Excel из Visio и обратно
                '           : Мастер для переноса данных из экселя в визио, для формирования спецификации
                ' Links     : https://visio.getbb.ru/viewtopic.php?f=15&t=234, https://visio.getbb.ru/download/file.php?id=106
                '------------------------------------------------------------------------------------------------------------

Option Base 1
'Option Explicit
Dim tabl(1 To 1000, 1 To 9) As Variant
Dim arr() As Variant
Dim str As Integer
Dim pNumber As Integer
Dim RowCountXls As Integer
Dim ColoumnCountXls As Integer
Dim xx As Integer
Dim yx As Integer
Dim pth As String
Public Excel_imya_lista As String
Public sp As Excel.Workbook
Public frmClose As Boolean

Sub ShowSpecifikaciya()
    frmSpecifikaciya.Show
End Sub

Public Sub spDEL()
    If MsgBox("Удалить листы спецификации?", vbQuestion + vbOKCancel, "Удалить спецификацию") = vbOK Then
        del_sp
        'MsgBox "Старая версия спецификации удалена", vbInformation
    End If
End Sub

'Public Sub spDEL_ADD()
'    del_sp
'    spADD
'End Sub

Public Sub SP_Excel_2_Visio()
    xls_query
    If frmClose Then Exit Sub
    fill_table_SP
    Application.ActiveWindow.Page = Application.ActiveDocument.Pages.Item(cListNameSpec)
    MsgBox "Спецификация добавлена", vbInformation
End Sub

Public Sub PE_Excel_2_Visio(PerechenElementov As Visio.Shape)
    xls_query
    If frmClose Then Exit Sub
    fill_table_PE PerechenElementov
End Sub

Private Sub xls_query()
    Dim oExcel As Excel.Application
'    Dim sp As Excel.Workbook
'    Dim sht As Excel.Worksheet
    Dim tr As Object
    Dim tc As Object
    Dim qx As Integer
    Dim qy As Integer
    Dim ffs As FileDialogFilters
    Dim sFileName As String
    Dim fd As FileDialog
    Dim sPath, sFile As String
    Dim Chois As Integer
    
    
    Set oExcel = CreateObject("Excel.Application")
    pth = Visio.ActiveDocument.path
'    oExcel.Visible = True ' для наглядности
    
    Set fd = oExcel.FileDialog(msoFileDialogOpen)
    With fd
        .AllowMultiSelect = False
        .InitialFileName = pth
        Set ffs = .Filters
        With ffs
            .Clear
            .Add "Excel", "*.xls"
        End With
        Chois = oExcel.FileDialog(msoFileDialogOpen).Show
    End With
    If Chois = 0 Then oExcel.Application.Quit: frmClose = True: Exit Sub
    sFileName = oExcel.FileDialog(msoFileDialogOpen).SelectedItems(1)
    
    

    sPath = pth
'    sFileName = "SP_2_Visio.xls"
    sFile = sFileName
    
'    If Dir(sFile, 16) = "" Then 'есть хотя бы один файл
'        MsgBox "Файл " & sFileName & " не найден в папке: " & sPath, vbCritical, "Ошибка"
'        Exit Sub
'    End If
    
    Set sp = oExcel.Workbooks.Open(sFile)
    Load frmVyborListaExcel
    frmVyborListaExcel.Show
    If frmClose Then oExcel.Application.Quit: Exit Sub

    sp.Activate
    Dim UserRange As Excel.Range
    Dim Total As Excel.Range ' диапазон Full_list
    
    On Error Resume Next
    If oExcel.Worksheets(Excel_imya_lista) Is Nothing Then
        'действия, если листа нет
'        oExcel.run "'SP_2_Visio.xls'!Spec_2_Visio.Spec_2_Visio" 'создаем
    Else
        'действия, если лист есть
    End If
    
    'oExcel.GoTo Reference:=sp.Worksheets(1).Range("A2")
    'oExcel.ActiveCell.Select
    lLastRow = oExcel.Sheets(Excel_imya_lista).Cells(oExcel.Sheets(Excel_imya_lista).Rows.Count, 1).End(xlUp).Row
    Set UserRange = oExcel.Worksheets(Excel_imya_lista).Range("A3:I" & lLastRow) 'oExcel.InputBox _
    '(Prompt:="Выберите диапазон A3:Ix", _
    'Title:="Выбор диапазона", _
    'Type:=8)
    Set Total = UserRange
        For Each tr In Total.Rows
            RowCountXls = RowCountXls + 1
            ColoumnCountXls = 0
            For Each tc In Total.Rows.Columns
                ColoumnCountXls = ColoumnCountXls + 1
            Next tc
        Next tr
    ReDim arr(RowCountXls, ColoumnCountXls) As Variant
    For qx = 1 To RowCountXls
        For qy = 1 To ColoumnCountXls
            arr(qx, qy) = Total.Cells(qx, qy) ' заполнение массива arr
        Next qy
    Next qx
    sp.Close SaveChanges:=False
    oExcel.Application.Quit
    

End Sub

Private Sub fill_table_SP()  ' заполнение спецификации

    Dim TheDocListovSpecifikac As Cell
    Dim ncell As Integer
    Dim NStrokiXls As Integer
    Dim NRow As Integer ' счетчик количества строк спецификации на странице
    Dim mastSpecifikacia As Master
    Dim pName As String
    Dim shpCell As Shape
    Dim shpSpecifikacia As Shape
    Dim shpRow As Shape
    Dim HMax As Integer
    Dim HTable As Integer

    Set TheDocListovSpecifikac = ActiveDocument.DocumentSheet.Cells("user.SA_FR_NListSpecifikac")
    TheDocListovSpecifikac.FormulaU = 1
    pNumber = 1
    NRow = 1
    pName = cListNameSpec & "."
    AddPageSpecifikac cListNameSpec
    Set mastSpecifikacia = Application.Documents.Item("SAPR_ASU_OFORM.vss").Masters.Item("СП")
    ActivePage.Drop mastSpecifikacia, 0, 0
    Set shpSpecifikacia = ActivePage.Shapes.Item("СП")
    For NStrokiXls = 1 To RowCountXls
        Set shpRow = shpSpecifikacia.Shapes.Item("row" & NRow)
        For ncell = 1 To 9 'ColoumnCountXls
            Set shpCell = shpRow.Shapes.Item(NRow & "." & ncell)
            shpCell.Text = arr(NStrokiXls, ncell)
            If ncell = 2 Or ncell = 9 Then shpCell.CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "0"
            If ncell = 2 And arr(NStrokiXls, 1) = "" Then
                shpCell.CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "1" 'По центру
                shpCell.CellsSRC(visSectionCharacter, 0, visCharacterStyle).FormulaU = visItalic + visUnderLine 'Курсив+Подчеркивание
            End If
        Next ncell

        DoEvents

        If pNumber = 1 Then HMax = 198 Else HMax = 232
        HTable = shpSpecifikacia.Cells("User.V").Result("mm")
        
        If HTable > HMax Then 'Высота таблицы больше 232мм/198мм
            'Удаляем лишние строки
            While HTable > HMax
                For xNCell = 1 To 9 'ColoumnCountXls
                    Set shpCell = shpRow.Shapes.Item(NRow & "." & xNCell)
                    shpCell.Text = " "
'                    shpCell.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "0 mm"
                Next xNCell
                NStrokiXls = NStrokiXls - 1
                NRow = NRow - 1
                Set shpRow = shpSpecifikacia.Shapes.Item("row" & NRow)
                HTable = shpSpecifikacia.Cells("User.V").Result("mm")
            Wend
            'Добавляем лист
            GoSub SubAddPage

        ElseIf HTable = HMax And NStrokiXls <> RowCountXls Then 'Высота таблицы равна 232мм/198мм и это не полследняя строка
            'Добавляем лист
            GoSub SubAddPage
        End If
        
        NRow = NRow + 1
        If NRow > 30 Then NRow = 0

    Next NStrokiXls
    pNumber = 1
    RowCountXls = 0
    Exit Sub
    
SubAddPage:
    'Добавляем лист
    NRow = 0
    pNumber = pNumber + 1
    TheDocListovSpecifikac.Formula = pNumber
    AddPageSpecifikac pName & pNumber
    ActivePage.Drop mastSpecifikacia, 0, 0
    Set shpSpecifikacia = ActivePage.Shapes.Item("СП")
    Return

 End Sub
 
 
 Private Sub fill_table_PE(PerechenElementov As Visio.Shape)  ' заполнение таблицы перечня элементов
    Dim ncell As Integer
    Dim NStrokiXls As Integer
    Dim NRow As Integer ' счетчик количества строк спецификации на странице
    Dim shpCell As Shape
    Dim shpRow As Shape

    NRow = 1
    If RowCountXls > 30 Then MsgBox "Строк на листе Excel больше, чем строк в таблице(30): " & RowCountXls & vbNewLine & vbNewLine & "Разбейте перечень на несколько таблиц", vbExclamation, "Перечень элементов": RowCountXls = 30
    For NStrokiXls = 1 To RowCountXls
        Set shpRow = PerechenElementov.Shapes.Item("row" & NRow)
        For ncell = 1 To 4 'ColoumnCountXls
            Set shpCell = shpRow.Shapes.Item(NRow & "." & ncell)
            shpCell.Text = arr(NStrokiXls, ncell)
            If ncell = 2 Or ncell = 4 Then shpCell.CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "0"
            If ncell = 2 And arr(NStrokiXls, 1) = "" Then
                shpCell.CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "1" 'По центру
                shpCell.CellsSRC(visSectionCharacter, 0, visCharacterStyle).FormulaU = visItalic + visUnderLine 'Курсив+Подчеркивание
            End If
        Next ncell
        NRow = NRow + 1
        If NRow > 30 Then NRow = 0
    Next NStrokiXls
    RowCountXls = 0
End Sub
 
Sub AddPageSpecifikac(pName As String)
    Dim aPage As Visio.Page
    Dim Mstr As Visio.Master
    Dim Ramka As Visio.Shape
    If GetSAPageExist(pName) Is Nothing Then
        Set aPage = ActiveDocument.Pages.Add
        aPage.Name = pName
        With aPage.PageSheet
            .Cells("PageWidth").Formula = "420 MM"
            .Cells("PageHeight").Formula = "297 MM"
            .Cells("Paperkind").Formula = 8
            .Cells("PrintPageOrientation").Formula = 2
            .AddSection visSectionAction
'            .AddRow visSectionAction, visRowLast, visTagDefault
'            .CellsSRC(visSectionAction, visRowLast, visActionMenu).FormulaForceU = """Перечень оборудования со Схемы в Excel"""
'            .CellsSRC(visSectionAction, visRowLast, visActionAction).FormulaForceU = "RunMacro(""PagePLANAddElementsFrm"")"
'            .CellsSRC(visSectionAction, visRowLast, visActionButtonFace).FormulaForceU = "263" '5897
'            .CellsSRC(visSectionAction, visRowLast, visActionSortKey).FormulaU = """10"""
            .AddRow visSectionAction, visRowLast, visTagDefault
            .CellsSRC(visSectionAction, visRowLast, visActionMenu).FormulaForceU = """Создать спецификацию в Visio из Excel"""
            .CellsSRC(visSectionAction, visRowLast, visActionAction).FormulaForceU = "RunMacro(""SP_Excel_2_Visio"")"
            .CellsSRC(visSectionAction, visRowLast, visActionButtonFace).FormulaForceU = "7076" '6224
            .CellsSRC(visSectionAction, visRowLast, visActionSortKey).FormulaU = """20"""
            .AddRow visSectionAction, visRowLast, visTagDefault
            .CellsSRC(visSectionAction, visRowLast, visActionMenu).FormulaForceU = """Удалить все листы спецификации"""
            .CellsSRC(visSectionAction, visRowLast, visActionAction).FormulaForceU = "RunMacro(""spDEL"")"
            .CellsSRC(visSectionAction, visRowLast, visActionButtonFace).FormulaForceU = "1088" '2645
            .CellsSRC(visSectionAction, visRowLast, visActionSortKey).FormulaU = """30"""
        End With
        Set Mstr = Application.Documents.Item("SAPR_ASU_OFORM.vss").Masters.Item("Рамка")
        Set Ramka = ActivePage.Drop(Mstr, 0, 0)
        LockTitleBlock
        ActiveDocument.Masters.Item("Рамка").Delete
    Else
        ActiveWindow.Page = ActiveDocument.Pages(pName)
        ActiveWindow.SelectAll
        ActiveWindow.Selection.Delete
        Set Ramka = ActivePage.Shapes.Item("Рамка")
    End If
    Ramka.Shapes("FORMA3").Shapes("Shifr").Cells("fields.value").FormulaU = "=TheDoc!User.SA_FR_Shifr & "".CO"""
    Ramka.Cells("User.NomerLista").FormulaU = "=PAGENUMBER()+Sheet.1!Prop.CNUM + TheDoc!User.SA_FR_NListSpecifikac - PAGECOUNT()"
    Ramka.Cells("User.ChisloListov").FormulaU = "=TheDoc!User.SA_FR_NListSpecifikac"
'    Ramka.Cells("prop.type").Formula = """Спецификация оборудования, изделий и материалов"""
    If Len(pName) > 1 Then Ramka.Cells("Prop.CHAPTER").FormulaU = "INDEX(1,Prop.CHAPTER.Format)"
    Ramka.Cells("Prop.cnum") = 0
    Ramka.Cells("Prop.tnum") = 0

End Sub

Private Sub del_sp()
    Dim dp As Page
    Dim colPage As Collection
    Set colPage = New Collection
    'Спецификацию в колекцию
    For Each dp In ActiveDocument.Pages
        If InStr(1, dp.Name, cListNameSpec & ".") > 0 Then
            colPage.Add dp
        End If
    Next
    'удаляем все страницы которые нашли выше
    For Each dp In colPage
        dp.Delete (1)
    Next
    On Error Resume Next
    ActiveDocument.Pages.Item(cListNameSpec).Delete (1)
    ActiveDocument.DocumentSheet.Cells("user.SA_FR_NListSpecifikac").Formula = 0
End Sub

Public Sub SP_EXP_2_XLS()
    Dim opn As Long
    Dim npName As String
    Dim pName As String
    Dim np As Page
    Dim pg As Page
    Dim N As Integer
    pName = cListNameSpec
    str = 1
    opn = ActiveDocument.Pages.Item(pName).Index
    Application.ActiveWindow.Page = ActiveDocument.Pages.Item(cListNameSpec)
    get_data ActivePage.Shapes.Item("СП"), 9
    For N = 2 To ActiveDocument.DocumentSheet.Cells("user.SA_FR_NListSpecifikac")
        pName = cListNameSpec & "." & N
        Application.ActiveWindow.Page = ActiveDocument.Pages.Item(pName)
        get_data ActivePage.Shapes.Item("СП"), 9
    Next
    
    Dim apx As Excel.Application
    Set apx = CreateObject("Excel.Application")
    Dim WB As Excel.Workbook
    Dim sht As Excel.Sheets
    Dim en As String
    Dim un As String
    
    Dim sPath, sFile As String
    sPath = Visio.ActiveDocument.path
    sFileName = "SP_2_Visio.xls"
    sFile = sPath & sFileName
    
    
    If Dir(sFile, 16) = "" Then 'есть хотя бы один файл
        MsgBox "Файл " & sFileName & " не найден в папке: " & sPath, vbCritical, "Ошибка"
        Exit Sub
    End If
    
    Set WB = apx.Workbooks.Open(sFile)
    

    
    'Set wb = apx.Workbooks.Add
    'un = Format(Now(), "yyyy_mm_dd")
    'pth = Visio.ActiveDocument.Path
    'en = pth & "СП_" & un & ".xls"
    apx.Visible = True
    'удаляем старый лист
    apx.DisplayAlerts = False
    On Error Resume Next
    apx.Sheets("СП_EXP_2_XLS").Delete
    apx.DisplayAlerts = True
    'добавляем новый
    apx.Sheets("СП").Copy After:=apx.Sheets(apx.Worksheets.Count)
    apx.Sheets("СП (2)").Name = "СП_EXP_2_XLS"
    
    
    lLastRow = apx.Sheets("СП_EXP_2_XLS").Cells(apx.Rows.Count, 1).End(xlUp).Row
    apx.Application.CutCopyMode = False
    apx.Worksheets("СП_EXP_2_XLS").Activate
    apx.ActiveSheet.Rows("6:" & lLastRow).Delete Shift:=xlUp
    apx.ActiveSheet.Range("A3:I5").ClearContents
    apx.ActiveSheet.Rows("5:" & str).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    WB.Activate
        
        For xx = 1 To str + 2
            For yx = 1 To 9
                WB.Sheets("СП_EXP_2_XLS").Cells(xx + 2, yx) = tabl(xx, yx)
                'wb.Sheets("СП_EXP_2_XLS").Range("A" & (xx + 2)).Select 'для наглядности
            Next yx
        Next xx
        
    apx.ActiveSheet.Range("A3:I" & apx.Sheets("СП_EXP_2_XLS").Cells(apx.Rows.Count, 1).End(xlUp).Row).WrapText = False
    apx.ActiveSheet.Range("A3:I" & apx.Sheets("СП_EXP_2_XLS").Cells(apx.Rows.Count, 1).End(xlUp).Row).RowHeight = 20 'Если ячейки, в которых были многострочные тексты, были растянуты по высоте, то мы их приводим в нормальный вид перед копированием
    apx.ActiveSheet.Range("K1") = Format(Now(), "yyyy.mm.dd hh:mm:ss")
    apx.ActiveSheet.Range("K1").Select
    WB.Save
'    WB.Close SaveChanges:=True
'    apx.Quit
    MsgBox "Спецификация экспортирована в файл SP_2_Visio.xls на лист СП_EXP_2_XLS", vbInformation
End Sub

Public Sub PE_EXP_2_XLS(PerechenElementov As Visio.Shape) 'Перечень элементов - экспорт в EXCEL
    Dim opn As Long
    Dim npName As String
    Dim pName As String
    Dim NameListExcel As String
    Dim np As Page
    Dim pg As Page
    Dim N As Integer
    pName = PerechenElementov.ContainingPage.Name
    NameListExcel = "ПЭ_" & pName & "_EXP_2_XLS"
    str = 1
    Erase tabl
    get_data PerechenElementov, 4
    
    Dim apx As Excel.Application
    Set apx = CreateObject("Excel.Application")
    Dim WB As Excel.Workbook
    Dim sht As Excel.Sheets
    Dim en As String
    Dim un As String
    
    Dim sPath, sFile As String
    sPath = Visio.ActiveDocument.path
    sFileName = "SP_2_Visio.xls"
    sFile = sPath & sFileName
    
    
    If Dir(sFile, 16) = "" Then 'есть хотя бы один файл
        MsgBox "Файл " & sFileName & " не найден в папке: " & sPath, vbCritical, "Ошибка"
        Exit Sub
    End If
    
    Set WB = apx.Workbooks.Open(sFile)
    

    
    'Set wb = apx.Workbooks.Add
    'un = Format(Now(), "yyyy_mm_dd")
    'pth = Visio.ActiveDocument.Path
    'en = pth & "СП_" & un & ".xls"
    apx.Visible = True
    'удаляем старый лист
    apx.DisplayAlerts = False
    On Error Resume Next
    apx.Sheets(NameListExcel).Delete
    apx.DisplayAlerts = True
    'добавляем новый
    apx.Sheets("СП").Copy After:=apx.Sheets(apx.Worksheets.Count)
    apx.Sheets("СП (2)").Name = NameListExcel
    
    
    lLastRow = apx.Sheets(NameListExcel).Cells(apx.Rows.Count, 1).End(xlUp).Row
    apx.Application.CutCopyMode = False
    apx.Worksheets(NameListExcel).Activate
    apx.ActiveSheet.Rows("6:" & lLastRow).Delete Shift:=xlUp
    apx.ActiveSheet.Range("A3:I5").ClearContents
    apx.ActiveSheet.Rows("5:" & str).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    apx.ActiveSheet.Range("A1") = "Поз."
    apx.ActiveSheet.Range("B1") = "Наименование"
    apx.ActiveSheet.Range("C1") = "Кол."
    apx.ActiveSheet.Range("D1") = "Примечание"
    apx.ActiveSheet.Columns("E:I").Delete
   
    WB.Activate
        
        For xx = 1 To str + 2
            For yx = 1 To 4
                WB.Sheets(NameListExcel).Cells(xx + 2, yx) = tabl(xx, yx)
                'wb.Sheets(NameListExcel).Range("A" & (xx + 2)).Select 'для наглядности
            Next yx
        Next xx
        
    apx.ActiveSheet.Range("A1:I" & apx.Sheets(NameListExcel).Cells(apx.Rows.Count, 1).End(xlUp).Row).WrapText = False
    apx.ActiveSheet.Range("A3:I" & apx.Sheets(NameListExcel).Cells(apx.Rows.Count, 1).End(xlUp).Row).RowHeight = 20 'Если ячейки, в которых были многострочные тексты, были растянуты по высоте, то мы их приводим в нормальный вид перед копированием
    
    apx.ActiveSheet.Range("B3:B" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).HorizontalAlignment = xlLeft
    apx.ActiveSheet.Range("D3:D" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).HorizontalAlignment = xlLeft
    apx.ActiveSheet.Range("F1") = Format(Now(), "yyyy.mm.dd hh:mm:ss")
    apx.ActiveSheet.Range("A1:D" & apx.ActiveSheet.Cells(apx.Rows.Count, 1).End(xlDown).Row).Columns.AutoFit
    apx.ActiveSheet.Range("F1").Select
    
    
    
    WB.Save
'    WB.Close SaveChanges:=True
'    apx.Quit
'    MsgBox "Спецификация экспортирована в файл SP_2_Visio.xls на лист ПЭ_EXP_2_XLS", vbInformation
End Sub

Public Sub get_data(Tablica As Visio.Shape, kolcell As Integer) '(pgName As Page)
    Dim i As Integer
    Dim c As Integer
    Dim rw As Shape     ' шейп - строка
    Dim cn As String ' имя целевого шейпа
    
    For i = 1 To 30
        Set rw = Tablica.Shapes.Item("row" & i)
        If rw.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight) = 0 Then GoTo out:
        For c = 1 To kolcell
            cn = i & "." & c
             tabl(str, c) = rw.Shapes.Item(cn).Text
        Next
        str = str + 1
    Next
out:
End Sub

Public Function SortNumInString(strToSort As String) As String
'------------------------------------------------------------------------------------------------------------
' Function      : SortNumInString - "Сортировка вставками" чисел в строке, разделенных ";"
                'Строка чисел, разделенных ";", преобразуется в массив, сортируется,
                'и возвращается в виде склеенной строки
'------------------------------------------------------------------------------------------------------------
    Dim mNum() As String
    Dim NumTemp As Variant
    Dim i As Integer
    Dim j As Integer
    Dim UbNum As Long
    
    mNum = Split(strToSort, ";")
    UbNum = UBound(mNum)
    If UbNum > 0 Then
        strToSort = ""
        '--V--Сортировка
        For j = 1 To UbNum
            NumTemp = IIf(mNum(j) = "", "0", mNum(j))
            i = j
            While CInt(mNum(i - 1)) > CInt(NumTemp) '>:возрастание, <:убывание
                mNum(i) = mNum(i - 1)
                i = i - 1
                If i <= 0 Then GoTo ExitWhile
            Wend
ExitWhile:     mNum(i) = NumTemp
        Next
        '--Х--Сортировка
        For i = 0 To UbNum
            strToSort = strToSort & mNum(i) & ";"
        Next
        strToSort = Left(strToSort, Len(strToSort) - 1)
    End If
    SortNumInString = strToSort
End Function


Public Function ReplaceSequenceInString(strToReplace As String) As String
'------------------------------------------------------------------------------------------------------------
' Function      : ReplaceSequenceInString - Заменяет последовательно идущие чисела в строке на тире
                ' "1;2;3;4;5;9" заменяется на "1-;5;9"
                'и возвращается в виде склеенной строки
'------------------------------------------------------------------------------------------------------------
    Dim mNum() As String
    Dim NumTemp As Variant
    Dim i As Integer
    Dim j As Integer
    Dim NumStart As Integer
    Dim NumEnd As Integer
    Dim TempStart As Integer
    Dim nCount As Integer
    Dim UbNum As Long
    
    mNum = Split(strToReplace, ";")
    strToReplace = ""
    UbNum = UBound(mNum)
    For i = 0 To UbNum
        NumStart = CInt(IIf(mNum(i) = "", "0", mNum(i)))
        TempStart = NumStart
        For j = i To UbNum 'Сканируем диапазон
            If j = UbNum Then '--------достигли конца строки---------
                If TempStart - NumStart > 0 Then 'конец = диапазон
                    If TempStart - NumStart = 1 Then
                        strToReplace = strToReplace & NumStart & ";" & TempStart & ";" 'конец = диапазон - 2 цифры
                    Else
                        strToReplace = strToReplace & NumStart & "-;" & TempStart & ";" 'конец = диапазон - больше 2-х цифр
                    End If
                Else
                    strToReplace = strToReplace & TempStart & ";"  'конец = единичное число
                End If
                i = j
                Exit For
            End If
            NumEnd = CInt(mNum(j + 1))
            If NumEnd - TempStart = 1 Then 'идет последовательность
                TempStart = NumEnd
                nCount = nCount + 1
            Else '---------------Конец последовательности-------------------
                If nCount = 0 Then
                    strToReplace = strToReplace & TempStart & ";" 'нет последовательности
                ElseIf nCount = 1 Then
                    strToReplace = strToReplace & NumStart & ";" & TempStart & ";" 'диапазон - 2 цифры
                Else
                    strToReplace = strToReplace & NumStart & "-;" & TempStart & ";" 'диапазон - больше 2-х цифр
                End If
                nCount = 0
                i = j
                Exit For
            End If
        Next
    Next

    strToReplace = Left(strToReplace, Len(strToReplace) - 1)

    ReplaceSequenceInString = strToReplace
End Function

Public Function PozNameInString(strPozNumber As String, strPozName As String) As String
'------------------------------------------------------------------------------------------------------------
' Function      : PozNameInString - Добавляет ИМЕНА позиционных обозначений к НОМЕРАМ позиционных обозначений
                'Строка чисел, разделенных ";", преобразуется в массив, добавляются имена,
                'и возвращается в виде склеенной строки разделенной ","
'------------------------------------------------------------------------------------------------------------
    Dim mNum() As String
    Dim i As Integer
    Dim UbNum As Long
    
    mNum = Split(strPozNumber, ";")
    UbNum = UBound(mNum)
    If UbNum > -1 Then
        strPozNumber = ""
        For i = 0 To UbNum
            strPozNumber = strPozNumber & strPozName & mNum(i) & IIf(InStr(mNum(i), "-"), "", ",")
        Next
        strPozNumber = Left(strPozNumber, Len(strPozNumber) - 1)
    End If
    PozNameInString = strPozNumber
End Function


Public Function AddSostavNaboraIzBD(colStrokaSpecif As Collection, KolVo As Integer, IzbPozCod As String, iIndex As Integer) As Double
'------------------------------------------------------------------------------------------------------------
' Function      : AddSostavNaboraIzBD - Добавляет состав набора из БД к списку позиций спецификации
                'Возвращает число добавленных строк
                '
'------------------------------------------------------------------------------------------------------------
    Dim i As Double
    Dim iold As Double
    Dim rst As DAO.Recordset
    Dim RecordCount As Double
    Dim SQLQuery As String
    Dim clsStrokaSpecif As classStrokaSpecifikacii
    Dim strColKey As String
   

    nCount = colStrokaSpecif.Count
    SQLQuery = "SELECT Наборы.КодПозиции, Наборы.ИзбрПозицииКод, Наборы.Артикул, Наборы.Название, Наборы.Цена, Наборы.Количество, Наборы.ПроизводительКод, Производители.Производитель, Наборы.ЕдиницыКод, Единицы.Единица " & _
                "FROM Единицы INNER JOIN (Производители INNER JOIN Наборы ON Производители.КодПроизводителя = Наборы.ПроизводительКод) ON Единицы.КодЕдиницы = Наборы.ЕдиницыКод " & _
                "WHERE Наборы.ИзбрПозицииКод=" & IzbPozCod & ";"
    Set rst = GetRecordSet(DBNameIzbrannoe, SQLQuery)
    If rst.RecordCount > 0 Then
        rst.MoveLast
        RecordCount = rst.RecordCount
        i = 0
        iold = 1000
        With rst
            If .EOF Then Exit Function
            .MoveFirst
            Do Until .EOF
                Set clsStrokaSpecif = New classStrokaSpecifikacii
                clsStrokaSpecif.SymName = colStrokaSpecif(iIndex).SymName
                clsStrokaSpecif.SAType = ""
                clsStrokaSpecif.NazvanieDB = .Fields("Название").Value
                clsStrokaSpecif.ArtikulDB = .Fields("Артикул").Value
                clsStrokaSpecif.ProizvoditelDB = .Fields("Производитель").Value
                clsStrokaSpecif.CenaDB = .Fields("Цена").Value
                clsStrokaSpecif.EdDB = .Fields("Единица").Value
                clsStrokaSpecif.KolVo = .Fields("Количество").Value * KolVo
                clsStrokaSpecif.PozOboznach = colStrokaSpecif(iIndex).PozOboznach
                clsStrokaSpecif.KodPoziciiDB = ""
                strColKey = ";;" & .Fields("Артикул").Value
                        
                On Error Resume Next
                colStrokaSpecif.Add clsStrokaSpecif, strColKey
                If colStrokaSpecif.Count = nCount Then 'Если кол-во не увеличелось, значит уже есть такой элемент
                    MsgBox "В наборе присутствуют позиции с одинаковым артикулом: " & .Fields("Артикул").Value, vbExclamation, "Добавление набора в состав спецификации"
                Else
                    nCount = colStrokaSpecif.Count
                End If

                .MoveNext
            Loop
        End With
        AddSostavNaboraIzBD = RecordCount
    End If
    Set rst = Nothing
End Function