| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Автоматический сбор данных для ВРС (VBA)

Автоматический сбор данных для ВРС (VBA)

Ответ
Поиск в этой теме
Непрочитано 20.12.2013, 20:39 6 | #1
Автоматический сбор данных для ВРС (VBA)
swell{d}
 
гадание на конечно-элементной гуще
 
Düsseldorf
Регистрация: 31.05.2006
Сообщений: 7,619

Offtop: Давно об этом мечтал, но всё руки не доходили. А тут дошли, сел и сделал за вечер конфетку. Хочу поделиться, мало ли кому пригодится... Ну или сподвигнет на самостоятельные разработки.
Автоматический сбор данных по армированию элементов и расходу материалов (бетон, утеплитель) для (сводной) ведомости расхода стали материалов.
В качестве исходных данных используем спецификации, выполненные в таблицах СПДС (CSoft). Я работаю на нанокаде СПДС, но при желании можно, наверное, заставить работать и под автокадом.

Код состоит из двух "модулей" - сбор данных по изделиям (КЖИ) и сбор данных с самих конструкций.
Все собранные данные заносятся в заранее подготовленные таблички, которые с помощью магии перемножения матриц считают сводную ведомость с учётом количества элементов.

Итак, по порядку. Рассмотрим принцип работы на примере КЖ на стены какого-то этажа. Стены мы армируем плоскими и пространственными каркасами, а также "Деталями" - П-образными стержнями.
Пример чертежа КЖ - развёртка стены
Пример чертежей КЖИ - каркасы для армирования стен
(кстати, чертежи сгенерированы полностью автоматически, но это отдельная история)

Запускаем нашу табличку, на вкладке КЖИ щёлкаем кнопку "Собрать данные" - вуаля:


Переключаемся на вкладку Детали и материалы, щёлкаем кнопку "Собрать данные" - вуаля:
Сборочные единицы:

Детали и материалы:


Продолжение в следующем сообщении, т.к. ограничение на 5 картинок...


Код:
[Выделить все]
Sub svodnaya_kji()
    'On Error Resume Next
    
    If MsgBox("Все данные на вкладке КЖИ будут удалены. Продолжить?", vbQuestion + vbYesNo) = vbNo Then
        End
    End If
    
    Application.DisplayStatusBar = True
    
    'очищаем лист
    Лист1.Range("A2:A201").Value = "="""""
    Лист1.Range("B2:K201").ClearContents
    Лист1.Range("M2:M201").Clear

    'подключаемся к нано
    Dim app As nanoCAD.Application
    Dim ThisDrawing As nanoCAD.Document
    Dim ms As AcadModelSpace
    Dim ut As nanoCAD.Utility
    Dim server As McCOM2.IServer
    Dim spdsobjects As McCOM2.ObjectsCollection
    Set app = GetObject("", "nanoCAD.Application")
    Set ThisDrawing = app.ActiveDocument
    Set ms = ThisDrawing.ModelSpace
    Set ut = ThisDrawing.Utility
    'подключаемся к спдс
    Set server = CreateObject("McCOM2.Server")
    Set spdsobjects = server.Query()
    
    Dim obj As McCOM2.Object 'ищем основную надпись
    Dim spdstabs_sp As McCOM2.ObjectsCollection
    Set spdstabs_sp = server.CreateObject("ObjectsCollection")
    Dim spdstabs_on As McCOM2.ObjectsCollection
    Set spdstabs_on = server.CreateObject("ObjectsCollection")
    
    ut.Prompt "Сводная КЖИ"
    
    'таймер
    Dim begintime As Double
    begintime = Timer()
    
    'прогоняем все спдс объекты и ищем таблицы с определённым названием
    Dim i As Integer
    i = 0
    For Each obj In spdsobjects
        i = i + 1
        Application.StatusBar = "Этап #1. Проверяем элемент " & i & " из " & spdsobjects.Count & ". Обнаружено спецификаций: " & spdstabs_sp.Count
        If (obj.ClassName = "McCom2.SymTable" And obj.Properties.item(1).Value = "Спецификация элементов") Or (obj.ClassName = "McCom2.SymTable" And obj.Properties.item(1).Value = "Спецификация монолитной конструкции") Then
            spdstabs_sp.Add obj
        End If
        If obj.ClassName = "McCom2.SymTable" And obj.Properties.item(1).Value = "КЖИ_основная_надпись" Then
            spdstabs_on.Add obj
        End If
    Next
    
    Dim taba As McCOM2.SymTable 'объект таблицы, с которой будем работать
    Dim osna As McCOM2.SymTable 'объект таблицы, с которой будем работать
    Dim pt_taba() As Double 'точка вставки таблицы
    Dim pt_obj() As Double 'точка вставки основной надписи
    Dim stroka As Integer 'номер каркаса/детали
    Dim result As Boolean 'контролька
    Dim a As Integer 'номер строки спецификации
    Dim txt As String 'фрагмент строки, из которой будем вытаскивать диаметр
    Dim name As String 'фрагмент строки, из которой будем вытаскивать название каркаса
    Dim diam As Integer 'диаметр
    Dim summ1 As Double 'сумма в таблице
    Dim summ2 As Double 'сумма в спецификации

    i = 0
    For Each taba In spdstabs_sp
        i = i + 1
        Application.StatusBar = "Этап #2. Обработано " & i & " из " & spdstabs_sp.Count
        pt_taba = taba.Position
        
        'ищем основную надпись
        result = False
        For Each osna In spdstabs_on
            pt_obj = osna.Position
            If pt_obj(1) > pt_taba(1) - 100 And pt_obj(1) < pt_taba(1) + 100 And pt_obj(2) > pt_taba(2) - 3000 And pt_obj(2) < pt_taba(2) Then
                result = True
                Exit For
            End If
        Next
        If result Then
            If osna.Cell(7, 9).text = "#" Then
                GoTo exit1
            End If
        Else
            ut.Prompt "Основная надпись не найдена!"
            GoTo exit1
        End If
        
        stroka = CInt(osna.Cell(7, 9).text) 'номер каркаса/детали
        
        name = osna.Cell(9, 7).text
        If Left(name, 7) = "Деталь " Then
            name = Right(name, Len(name) - 7)
        End If
        If Left(name, 15) = "Каркас плоский " Then
            name = Right(name, Len(name) - 15)
        End If
        If Left(name, 24) = "Каркас пространственный " Then
            name = Right(name, Len(name) - 24)
        End If
        If Left(name, 17) = "Закладная деталь " Then
            name = Right(name, Len(name) - 17)
        End If
        Лист1.Cells(stroka, 1).Value = name
        
        'смотрим саму табличку
        For a = 4 To taba.RowCount - 1
            If Left(taba.Cell(a, 3).text, 3) = "%%c" Or Left(taba.Cell(a, 3).text, 3) = "%%C" Then
                txt = taba.Cell(a, 3).text
                txt = Left(txt, 6)
                txt = Right(txt, 2)
                txt = RTrim(txt)
                diam = CInt(txt)
                Лист1.Cells(stroka, stolbec(diam)).Value = Лист1.Cells(stroka, stolbec(diam)).Value + CDbl(taba.Cell(a, 6).DisplayText)
            End If
        Next a
        
        'проверка суммы
        summ1 = Round(Лист1.Cells(stroka, 2).Value + Лист1.Cells(stroka, 3).Value + Лист1.Cells(stroka, 4).Value + Лист1.Cells(stroka, 5).Value + Лист1.Cells(stroka, 6).Value + Лист1.Cells(stroka, 7).Value + Лист1.Cells(stroka, 8).Value + Лист1.Cells(stroka, 9).Value + Лист1.Cells(stroka, 10).Value + Лист1.Cells(stroka, 11).Value, 2)
        If taba.Cell(taba.RowCount, 6).DisplayText <> "" Then
            summ2 = Round(taba.Cell(taba.RowCount, 6).DisplayText, 2)
            If summ1 <> summ2 Then
                Лист1.Cells(stroka, 13).Interior.ColorIndex = 3
            End If
        Else
            Лист1.Cells(stroka, 13).Interior.ColorIndex = 3
        End If
exit1:
    Next
    
    Application.StatusBar = ""
    
    ut.Prompt "Готово! Затрачено: " & CStr(Format(Timer() - begintime, "0.0")) & " сек."
    MsgBox "Готово! Затрачено: " & CStr(Format(Timer() - begintime, "0.0")) & " сек."

End Sub

Function stolbec(diam As Integer) As Integer
    Select Case diam
        Case CInt(Right(Лист1.Cells(1, 2).Value, Len(Лист1.Cells(1, 2).Value) - 1))
            stolbec = 2
        Case CInt(Right(Лист1.Cells(1, 3).Value, Len(Лист1.Cells(1, 3).Value) - 1))
            stolbec = 3
        Case CInt(Right(Лист1.Cells(1, 4).Value, Len(Лист1.Cells(1, 4).Value) - 1))
            stolbec = 4
        Case CInt(Right(Лист1.Cells(1, 5).Value, Len(Лист1.Cells(1, 5).Value) - 1))
            stolbec = 5
        Case CInt(Right(Лист1.Cells(1, 6).Value, Len(Лист1.Cells(1, 6).Value) - 1))
            stolbec = 6
        Case CInt(Right(Лист1.Cells(1, 7).Value, Len(Лист1.Cells(1, 7).Value) - 1))
            stolbec = 7
        Case CInt(Right(Лист1.Cells(1, 8).Value, Len(Лист1.Cells(1, 8).Value) - 1))
            stolbec = 8
        Case CInt(Right(Лист1.Cells(1, 9).Value, Len(Лист1.Cells(1, 9).Value) - 1))
            stolbec = 9
        Case CInt(Right(Лист1.Cells(1, 10).Value, Len(Лист1.Cells(1, 10).Value) - 1))
            stolbec = 10
        Case CInt(Right(Лист1.Cells(1, 11).Value, Len(Лист1.Cells(1, 11).Value) - 1))
            stolbec = 11
        Case Else
            stolbec = 13
    End Select
End Function



Код:
[Выделить все]
Sub svodnaya_kj()
    'On Error Resume Next
    
    If MsgBox("Все данные на вкладках Сборочные единицы и Детали и материалы будут удалены. Продолжить?", vbQuestion + vbYesNo) = vbNo Then
        End
    End If
    
    Application.DisplayStatusBar = True
    
    'очищаем листы
    Лист2.Range("A2:A501").Value = "="""""
    Лист2.Range("B2:GS501").ClearContents
    Лист3.Range("B2:P501").ClearContents
    Лист3.Range("Q2:Q501").Clear
    
    'подключаемся к нано
    Dim app As nanoCAD.Application
    Dim ThisDrawing As nanoCAD.Document
    Dim ms As AcadModelSpace
    Dim ut As nanoCAD.Utility
    Dim server As McCOM2.IServer
    Dim spdsobjects As McCOM2.ObjectsCollection
    Set app = GetObject("", "nanoCAD.Application")
    Set ThisDrawing = app.ActiveDocument
    Set ms = ThisDrawing.ModelSpace
    Set ut = ThisDrawing.Utility
    'подключаемся к спдс
    Set server = CreateObject("McCOM2.Server")
    Set spdsobjects = server.Query()
    
    Dim obj As McCOM2.Object 'ищем основную надпись
'    Dim spdstabs_sp As McCOM2.ObjectsCollection
'    Set spdstabs_sp = server.CreateObject("ObjectsCollection")
    Dim spdstabs_on As McCOM2.ObjectsCollection
    Set spdstabs_on = server.CreateObject("ObjectsCollection")
    
    ut.Prompt "Сводная КЖ"
    
    'таймер
    Dim begintime As Double
    begintime = Timer()
    
    Dim pt0() As Double
    Dim list(999) As Double, Xpos(999) As Double, Ypos(999) As Double, temp As Double
    
    'прогоняем все спдс объекты и ищем таблицы с определённым названием
    Dim i As Integer, m As Integer
    i = 0
    m = 0
    
    For Each obj In spdsobjects
        i = i + 1
        Application.StatusBar = "Этап #1. Проверяем элемент " & i & " из " & spdsobjects.Count & ". Обнаружено спецификаций: " & m
        If obj.ClassName = "McCom2.SymTable" And obj.Properties.item(1).Value = "Спецификация элементов" Then
            m = m + 1
'            spdstabs_sp.Add obj
            pt0 = obj.Position
            list(m) = i
            Xpos(m) = Round(pt0(1) / 1000, 0)
            Ypos(m) = Round(pt0(2) / 1000, 0)
        End If
        If obj.ClassName = "McCom2.SymTable" And obj.Properties.item(1).Value = "КЖ_основная_надпись" Then
            spdstabs_on.Add obj
        End If
    Next
    
    Application.StatusBar = "Этап #2. Сортировка"
    Dim a As Double, b As Double
    For a = 1 To m - 1
        For b = 1 To m - 1
            If Xpos(b) > Xpos(b + 1) Then
                temp = Xpos(b)
                Xpos(b) = Xpos(b + 1)
                Xpos(b + 1) = temp
                
                temp = list(b)
                list(b) = list(b + 1)
                list(b + 1) = temp
                
                temp = Ypos(b)
                Ypos(b) = Ypos(b + 1)
                Ypos(b + 1) = temp
            End If
        Next
    Next
    For a = 1 To m - 1
        For b = 1 To m - 1
            If Ypos(b) < Ypos(b + 1) Then
                temp = Xpos(b)
                Xpos(b) = Xpos(b + 1)
                Xpos(b + 1) = temp
                
                temp = list(b)
                list(b) = list(b + 1)
                list(b + 1) = temp
                
                temp = Ypos(b)
                Ypos(b) = Ypos(b + 1)
                Ypos(b + 1) = temp
            End If
        Next
    Next
    
    Dim taba As McCOM2.SymTable 'объект таблицы, с которой будем работать
    Dim osna As McCOM2.SymTable 'объект таблицы, с которой будем работать
    Dim pt_taba() As Double 'точка вставки таблицы
    Dim pt_obj() As Double 'точка вставки основной надписи
    Dim stroka As Integer 'номер каркаса/детали
    Dim result As Boolean 'контролька
    Dim c As Integer 'номер строки спецификации
    Dim txt As String 'фрагмент строки, из которой будем вытаскивать диаметр
    Dim name As String 'фрагмент строки, из которой будем вытаскивать название каркаса
    Dim diam As Integer 'диаметр
    Dim detal As Integer
    Dim summ1 As Double 'сумма в таблице
    Dim summ2 As Double 'сумма в спецификации

    For i = 1 To m
        Set taba = spdsobjects.item(list(i))
        Application.StatusBar = "Этап #3. Обработано " & i & " из " & m
        pt_taba = taba.Position
        
        'ищем основную надпись
        result = False
        For Each osna In spdstabs_on
            pt_obj = osna.Position
            If pt_obj(1) > pt_taba(1) - 100 And pt_obj(1) < pt_taba(1) + 100 And pt_obj(2) > pt_taba(2) - 10000 And pt_obj(2) < pt_taba(2) Then
                result = True
                Exit For
            End If
        Next
        If result Then
            If osna.Cell(7, 9).text = "#" Then
                GoTo exit1
            End If
        Else
            ut.Prompt "Основная надпись не найдена!"
            GoTo exit1
        End If
        
'        stroka = CInt(osna.Cell(7, 9).text) 'номер строки
        stroka = i + 1
        
        name = osna.Cell(9, 7).text
        If Left(name, 6) = "Стена " Then
            name = Right(name, Len(name) - 6)
        End If
        If Left(name, 8) = "Колонна " Then
            name = Right(name, Len(name) - 8)
        End If
        Лист2.Cells(stroka, 1).Value = name
        
        'смотрим саму табличку
        For c = 4 To taba.RowCount - 1
            If Left(taba.Cell(c, 3).text, 3) = "%%c" Or Left(taba.Cell(c, 3).text, 3) = "%%C" Then
                txt = taba.Cell(c, 3).text
                txt = Left(txt, 6)
                txt = Right(txt, 2)
                txt = RTrim(txt)
                diam = CInt(txt)
                Лист3.Cells(stroka, stolbec(diam)).Value = Лист3.Cells(stroka, stolbec(diam)).Value + CDbl(taba.Cell(c, 6).DisplayText)
            End If
            If Left(taba.Cell(c, 1).text, 2) = "КП" Or Left(taba.Cell(c, 1).text, 2) = "КР" Or Left(taba.Cell(c, 1).text, 2) = "МН" Then
                txt = taba.Cell(c, 1).text
                txt = Right(txt, Len(txt) - 2)
                detal = CInt(txt)
                Лист2.Cells(stroka, detal).Value = CInt(taba.Cell(c, 4).text)
            End If
            If Left(taba.Cell(c, 1).text, 1) = "Д" Then
                txt = taba.Cell(c, 1).text
                txt = Right(txt, Len(txt) - 1)
                detal = CInt(txt)
                Лист2.Cells(stroka, detal).Value = CInt(taba.Cell(c, 4).text)
            End If
            If Left(taba.Cell(c, 3).text, 5) = "Бетон" Then
                txt = taba.Cell(c, 3).text
                txt = Right(txt, Len(txt) - 13)
                txt = RTrim(txt)
                Лист3.Cells(stroka, stolbec_beton(txt)).Value = CDbl(taba.Cell(c, 4).text)
            End If
        Next c
exit1:
    Next
    
    Application.StatusBar = ""
    
    ut.Prompt "Готово! Затрачено: " & CStr(Format(Timer() - begintime, "0.0")) & " сек."
    MsgBox "Готово! Затрачено: " & CStr(Format(Timer() - begintime, "0.0")) & " сек."
    
End Sub

Function stolbec(diam As Integer) As Integer
    Select Case diam
        Case CInt(Right(Лист1.Cells(1, 2).Value, Len(Лист1.Cells(1, 2).Value) - 1))
            stolbec = 2
        Case CInt(Right(Лист1.Cells(1, 3).Value, Len(Лист1.Cells(1, 3).Value) - 1))
            stolbec = 3
        Case CInt(Right(Лист1.Cells(1, 4).Value, Len(Лист1.Cells(1, 4).Value) - 1))
            stolbec = 4
        Case CInt(Right(Лист1.Cells(1, 5).Value, Len(Лист1.Cells(1, 5).Value) - 1))
            stolbec = 5
        Case CInt(Right(Лист1.Cells(1, 6).Value, Len(Лист1.Cells(1, 6).Value) - 1))
            stolbec = 6
        Case CInt(Right(Лист1.Cells(1, 7).Value, Len(Лист1.Cells(1, 7).Value) - 1))
            stolbec = 7
        Case CInt(Right(Лист1.Cells(1, 8).Value, Len(Лист1.Cells(1, 8).Value) - 1))
            stolbec = 8
        Case CInt(Right(Лист1.Cells(1, 9).Value, Len(Лист1.Cells(1, 9).Value) - 1))
            stolbec = 9
        Case CInt(Right(Лист1.Cells(1, 10).Value, Len(Лист1.Cells(1, 10).Value) - 1))
            stolbec = 10
        Case CInt(Right(Лист1.Cells(1, 11).Value, Len(Лист1.Cells(1, 11).Value) - 1))
            stolbec = 11
        Case Else
            stolbec = 17
    End Select
End Function

Function stolbec_beton(txt As String) As Integer
    Select Case txt
        Case CStr(Лист3.Cells(1, 12).Value)
            stolbec_beton = 12
        Case CStr(Лист3.Cells(1, 13).Value)
            stolbec_beton = 13
        Case Else
            stolbec_beton = 17
    End Select
End Function

Миниатюры
Нажмите на изображение для увеличения
Название: 01.PNG
Просмотров: 1437
Размер:	6.1 Кб
ID:	119129  Нажмите на изображение для увеличения
Название: 02.PNG
Просмотров: 1408
Размер:	1.5 Кб
ID:	119130  Нажмите на изображение для увеличения
Название: 03.PNG
Просмотров: 1414
Размер:	3.2 Кб
ID:	119131  

Вложения
Тип файла: pdf кж.pdf (77.9 Кб, 419 просмотров)
Тип файла: pdf кжи.pdf (106.9 Кб, 574 просмотров)

__________________
.: WikiЖБК + YouTube :.

Последний раз редактировалось swell{d}, 20.12.2013 в 20:45.
Просмотров: 4516
 
Автор темы   Непрочитано 20.12.2013, 20:43
2 | #2
swell{d}

гадание на конечно-элементной гуще
 
Регистрация: 31.05.2006
Düsseldorf
Сообщений: 7,619


И итоговая табличка:

Сумма совпала с развёрткой, класс.

Если кого заинтересует, могу дать комментарии по коду, как там чего работает... Критика тоже приветствуется, за исключением обсуждения требований ГОСТов на оформление =)
Миниатюры
Нажмите на изображение для увеличения
Название: 04.PNG
Просмотров: 1432
Размер:	3.8 Кб
ID:	119132  
__________________
.: WikiЖБК + YouTube :.
swell{d} вне форума  
 
Автор темы   Непрочитано 05.04.2014, 15:55
2 | #3
swell{d}

гадание на конечно-элементной гуще
 
Регистрация: 31.05.2006
Düsseldorf
Сообщений: 7,619


Видеоролик с демонстрацией работы: http://youtu.be/VsWjMEOZVy0
__________________
.: WikiЖБК + YouTube :.
swell{d} вне форума  
 
Непрочитано 02.07.2014, 15:25
#4
parino


 
Регистрация: 05.07.2012
Сообщений: 17


Приветствую, классная тема, фтопку электронный кульман и калькулятор туда же, даешь автоматизацию проектирования))))!!! Пока еще не разобрался чо куда но уже нравится, буду внедрять на работе. А под автокад можно это же замутить?
parino вне форума  
 
Автор темы   Непрочитано 02.07.2014, 15:31
1 | #5
swell{d}

гадание на конечно-элементной гуще
 
Регистрация: 31.05.2006
Düsseldorf
Сообщений: 7,619


можно, наверное =)
__________________
.: WikiЖБК + YouTube :.
swell{d} вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Автоматический сбор данных для ВРС (VBA)

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Освоение тел Солнечной системы: Техника, технологии, ресурсы. Солидворкер Разное 2175 вчера 08:14
Какой язык перспективен для инженера-конструктора с условием The_Mercy_Seat Программирование 669 24.03.2017 20:16
Сбор исходных данных. Выдающие органы. Askarov Прочее. Архитектура и строительство 8 17.03.2013 14:54
Сбор данных с таблиц Agonist Прочее. Программное обеспечение 2 07.12.2010 08:39
почему трещит автомат АП Jоhnny Инженерные сети 35 29.03.2010 13:14