Спецификация Solid-Excel-Компас.

Задача.

Нужно создать групповую спецификацию на два исполнения. Мы используем макросы SWPlus, но иногда ругаются на формат спецификации. Раньше мы делали спецификацию вручную в компасе. Пришлось быстро придумать костыльный метод создания спецификации в Компасе через Ексель.

SWPlus-Excel

Сохраняем спецификацию в формате Ексель в удобную папку.

Макрос.

Подключаем библиотеки Excel и Компаса через Tools-References (в редакторе VBA).

Для Excel.

• Проверяем запущен ли Excel через функцию IsAppRunning.
• Открываем сохраненную спецификацию.
• Создаем массив arr из диапазона в Excel (пока вручную указал диапазон).

sApp = "Excel.Application"

If IsAppRunning(sApp) = True Then

'MsgBox "Ok. Excel запущен"

Else

' MsgBox "Fuck. Щас Excel запустим"

Set oApp = CreateObject(sApp)

End If

Set xlApp = GetObject(, "Excel.Application")

Dim xlWB As Excel.Workbook

Set xlWB = xlApp.Workbooks.OpenXML("D:\специя.xls")

Dim arr As Variant

arr = xlApp.Worksheets(1).Range("A1:G24").value

xlApp.Visible = True

Проверка статуса приложения. IsAppRunning

Function IsAppRunning(ByVal sAppName) As Boolean

Dim oApp As Object

On Error Resume Next

Set oApp = GetObject(, sAppName)

If Not oApp Is Nothing Then

Set oApp = Nothing

IsAppRunning = True

End If

End Function

Работа с компасом.

• Проверяем запущен ли Компас через функцию IsAppRunning.
• Определяем поля для документа спецификации doc и самой спецификации spec. Задаем путь к библиотеке стилей компаса str.
• Открываем сохраненный файл пустой спецификации с нужной рамкой (рыбу). Назначаем его активным документом и берем спецификацию. Мы внутри.

sApp = "Kompas.Application.5"

If IsAppRunning(sApp) = True Then

' MsgBox "Ok. Компас запущен"

Else

' MsgBox "Fuck. Щас Компас запустим"

Set oApp = CreateObject(sApp)

End If

Set Kompas = GetObject(, "Kompas.Application.5")

Kompas.Visible = True

Dim doc As Kompas6API5.SpcDocument

Dim spec As Kompas6API5.Specification

Dim str As String

Set doc = Kompas.SpcDocument

str = Kompas.ksSystemPath(0) + "\graphic.lyt"

doc.ksOpenDocument "D:\Новая СП.spw", 0

Set doc = Kompas.SpcActiveDocument

Set spec = doc.GetSpecification()

Заполняем спецификацию.

• Запускаем цикл построчно в нашем массиве. Делаем проверку на пустые строки и строки с названием разделов, кроме строки где есть Сборочный чертеж. Проверяем по наличию формата или номера позиции. Пока так, убогенько. За разрешение создать объекты спецификации отвечает bool.

For i = 1 To UBound(arr, 1)

bool = True

If arr(i, 1) = " " Or arr(i, 3) = " " Then

bool = False

End If

If arr(i, 5) = "Сборочный чертеж" Then

bool = True

End If

• У нас будут попадаться строки в которых в ячейке наименование будет название раздела спецификации. Прохождение такой строки будет задавать значение переменной r (раздел), которая будет использоваться для создания вспомогательного объекта спецификации в Компасе.

Select Case arr(i, 5)

Case "Документация"

r = 5

Case "Сборочные единицы"

r = 15

Case "Детали"

r = 20

Case "Стандартные изделия"

r = 25

Case "Прочие изделия"

r = 30

Case "Материалы"

r = 35

End Select

• Ну и теперь мы можем создать элемент спецификации с заполненными ячейками. Подробное объяснение при необходимости, напишите в комментариях.

Весь код:

Dim bool As Boolean

Dim Kompas As Kompas6API5.Application

Dim xlApp As Excel.Application

Sub main()

sApp = "Excel.Application"

If IsAppRunning(sApp) = True Then

'MsgBox "Ok. Excel запущен"

Else

' MsgBox "Fuck. Щас Excel запустим"

Set oApp = CreateObject(sApp)

End If

Set xlApp = GetObject(, "Excel.Application")

Dim xlWB As Excel.Workbook

Set xlWB = xlApp.Workbooks.OpenXML("D:\специя.xls")

Dim arr As Variant

arr = xlApp.Worksheets(1).Range("A1:G24").value

xlApp.Visible = True

''''''''''''''''''''''Компасизм--------------

sApp = "Kompas.Application.5"

If IsAppRunning(sApp) = True Then

' MsgBox "Ok. Компас запущен"

Else

' MsgBox "Fuck. Щас Компас запустим"

Set oApp = CreateObject(sApp)

End If

Set Kompas = GetObject(, "Kompas.Application.5")

Kompas.Visible = True

Dim doc As Kompas6API5.SpcDocument

Dim spec As Kompas6API5.Specification

Dim str As String

Set doc = Kompas.SpcDocument

str = Kompas.ksSystemPath(0) + "\graphic.lyt"

doc.ksOpenDocument "D:\Новая СП.spw", 0

Set doc = Kompas.SpcActiveDocument

Set spec = doc.GetSpecification()

For i = 1 To UBound(arr, 1)

bool = True

If arr(i, 1) = " " Or arr(i, 3) = " " Then

bool = False

End If

If arr(i, 5) = "Сборочный чертеж" Then

bool = True

End If

Select Case arr(i, 5)

Case "Документация"

r = 5

Case "Сборочные единицы"

r = 15

Case "Детали"

r = 20

Case "Стандартные изделия"

r = 25

Case "Прочие изделия"

r = 30

Case "Материалы"

r = 35

End Select

If bool = True Then

spec.ksSpcObjectCreate str, 1, r, 0, 0, 1 'создать элемент в разделе

spec.ksSetSpcObjectColumnText 4, 1, 0, arr(i, 4) 'Обозначение

spec.ksSetSpcObjectColumnText 5, 1, 0, arr(i, 5) 'Наименование

spec.ksSetSpcObjectColumnText 1, 1, 0, arr(i, 1) 'FORMAT

spec.ksSetSpcObjectColumnText 6, 1, 0, arr(i, 6) 'Количество

spec.ksSetSpcObjectColumnText 6, 2, 0, arr(i, 7) 'Количество1

spec.ksSetSpcObjectColumnText 6, 3, 0, " " 'Количество2

If arr(i, 5) <> "Сборочный чертеж" Then

spec.ksSetSpcObjectColumnText 3, 1, 0, arr(i, 3) 'Позиция

End If

spec.ksSpcObjectEnd 'закончить создание объекта

End If

Next

End Sub

Function IsAppRunning(ByVal sAppName) As Boolean

Dim oApp As Object

On Error Resume Next

Set oApp = GetObject(, sAppName)

If Not oApp Is Nothing Then

Set oApp = Nothing

IsAppRunning = True

End If

End Function

Заключение.

Конечно, улучшать и дорабатывать макрос можно долго, но иногда нужно решение на скорую руку.

Если нужно более подробное описание каких-то шагов в макросах, то

напишите в комментариях - разберём их в следующих постах.

Желаю творческих и профессиональных успехов.

#SolidWorks #VBA #Макросы #Excel #Компас 3D #API