VBA (Excel) Чтение и Запись в Чертеж КОМПАСа

[Михаил88]

Код рабочий. Вам нужно подключить



https://forum.ascon.ru/index.php?topic=40745.20 - в этой теме есть gif как работает.

[Михаил88]

https://norseev.ru/books/kompas-api-5-2025/

Валерич, можете еще эту книгу почитать.

[Валерич]

https://norseev.ru/books/kompas-api-5-2025/

Валерич, можете еще эту книгу почитать.

Да, спасибо, изучаю...

[Валерич]

Добрый день!
Пожалуйста, подскажите
как получить и изменить обозначения и наименования сборки
всех подсборок и деталей входящих в дерево построения,
путем открытия каждого соответствующего файла, изменения его свойств, сохранения с новыми значениями и закрытия файла.
Вот пробный код:

Код Выделить Развернуть

Option Explicit

Private Function bCheckKOMPAS7() As Boolean 'Проверка КОМПАСа
Dim objKomApp7 As KompasAPI7.IApplication
Dim vFromMsg As Variant

Set objKomApp7 = Nothing

On Error GoTo lblErrorHandler_01

'если запущен КОМПАС, получить интерфейс
Set objKomApp7 = GetObject(, "KOMPAS.Application.7")

    If Not objKomApp7 Is Nothing Then
        bCheckKOMPAS7 = True
    End If 'If Not objKomApp7 Is Nothing Then

Set objKomApp7 = Nothing

Exit Function

lblErrorHandler_01:
If Err.Number <> 0 Then
    vFromMsg = MsgBox("КОМПАС не Запущен" & "!", vbOKOnly + vbExclamation, "Требуется Запустить КОМПАС...") 'vbCritical
    bCheckKOMPAS7 = False
    On Error GoTo -1 'Очистить ошибку
End If 'If Err.Number <> 0 Then

Set objKomApp7 = Nothing

On Error GoTo -1 'Очистить ошибку

End Function 'Private Function bCheckKOMPAS7() As Boolean 'Проверка КОМПАСа



Private Function sGetKomDocTypeDir(sTypeDirPath As String) As String 'Определить Тип Документа или Путь к нему
Dim objKomApp7 As KompasAPI7.IApplication
Dim objKomDoc7 As KompasAPI7.IKompasDocument
Dim sKomDocType As String
'Dim sKomDocDir As String
'Dim sKomDocPath As String

Set objKomApp7 = GetObject(, "Kompas.Application.7")
Set objKomDoc7 = objKomApp7.ActiveDocument

'ksDocumentUnknown 0 Неизвестный тип
'ksDocumentDrawing 1 Чертеж
'ksDocumentFragment 2 Фрагмент
'ksDocumentSpecification 3 Спецификация
'ksDocumentPart 4 Деталь
'ksDocumentAssembly 5 Сборка
'ksDocumentTextual 6 Текстовый документ
'ksDocumentTechnologyAssembly 7 Технологическая сборка
 
'sKomDocType = objKomDoc7.DocumentType
'sKomDocDir = objKomDoc7.Path
'sKomDocPath = objKomDoc7.PathName

Select Case sTypeDirPath
   
    Case "Тип"
        sKomDocType = objKomDoc7.DocumentType
       
        Select Case sKomDocType
       
            Case "0"
                sGetKomDocTypeDir = "Неизвестный тип"
            Case "1"
                sGetKomDocTypeDir = "Чертеж"
            Case "2"
                sGetKomDocTypeDir = "Фрагмент"
            Case "3"
                sGetKomDocTypeDir = "Спецификация"
            Case "4"
                sGetKomDocTypeDir = "Деталь"
            Case "5"
                sGetKomDocTypeDir = "Сборка"
            Case "6"
                sGetKomDocTypeDir = "Текстовый документ"
            Case "7"
                sGetKomDocTypeDir = "Технологическая сборка"
           
        End Select 'Select Case sKomDocType
       
    Case "Каталог"
        sGetKomDocTypeDir = objKomDoc7.Path
   
    Case "Путь"
        sGetKomDocTypeDir = objKomDoc7.PathName
   
End Select 'Select Case sTypeDirPath




Set objKomApp7 = Nothing
Set objKomDoc7 = Nothing

End Function 'Private Function sGetKomDocTypeDir(sTypeDirPath As String) As String 'Определить Тип Документа или Путь к нему



Private Function bCheckDocAssembling() As Boolean 'Проверка Документа на Сборку
Dim vFromMsg As Variant

If bCheckKOMPAS7() Then 'Если КОМПАС запущен

    If sGetKomDocTypeDir("Тип") = "Сборка" Then 'Если Сборка
        bCheckDocAssembling = True
   
    ElseIf sGetKomDocTypeDir("Тип") = "Неизвестный тип" Then
        vFromMsg = MsgBox("НЕИЗВЕСТНЫЙ ТИП Документа" & "...", vbOKOnly + vbQuestion, "НЕ ОПРЕДЕЛЕН ТИП...") 'vbCritical
        bCheckDocAssembling = False
    Else
        vFromMsg = MsgBox("Требуется ОТКРЫТАЯ СБОРКА" & "...", vbOKOnly + vbInformation, "НЕ СБОРКА...") 'vbCritical
        bCheckDocAssembling = False

    End If 'If bCheckKOMPAS7() And sGetKomDocTypeDir("Тип") = "Сборка" Then 'Проверка КОМПАСа и если Сборка

End If 'If bCheckKOMPAS7() Then 'Если КОМПАС запущен

End Function 'Private Function bCheckDocAssembling() As Boolean 'Проверка Документа на Сборку


Public Sub ChangeAssemblingData()
Dim objKomApp7 As KompasAPI7.IApplication
Dim objKomDoc7_3D As KompasAPI7.IKompasDocument3D
Dim objKomPart7 As KompasAPI7.part7
Dim sMarking As String
Dim sName As String
Dim vFromMsg As Variant

If bCheckDocAssembling Then 'Если Активный Документ - Сборка

On Error GoTo lblErrorHandler_01 ' Если произошло переключение Активного Документа

Set objKomApp7 = GetObject(, "Kompas.Application.7")
Set objKomDoc7_3D = objKomApp7.ActiveDocument


'-------------------------------------------------------------------
'ЗДЕСЬ НУЖНО ПОЛУЧИТЬ И ИЗМЕНИТЬ ОБОЗНАЧЕНИЯ И НАИМЕНОВАНИЯ СБОРКИ
'ВСЕХ ПОДСБОРОК И ДЕТАЛЕЙ ВХОДЯЩИХ В ДЕРЕВО ПОСТРОЕНИЯ,
'ПУТЕМ ОТКРЫТИЯ КАЖДОГО СООТВЕТСТВУЮЩЕГО ФАЙЛА, ИЗМЕНЕНИЯ ЕГО СВОЙСТВ,
'СОХРАНЕНИЯ С НОВЫМИ ЗНАЧЕНИЯМИ И ЗАКРЫТИЯ ФАЙЛА
'
'-------------------------------------------------------------------
'Здесь, наверное, д.б ЦИКЛ ПЕРЕБОРА ЭЛЕМЕНТОВ КОЛЛЕКЦИИ.
'Вызов Функции...
'
'-------------------------------------------------------------------

'Для Пробы

Set objKomPart7 = objKomDoc7_3D.TopPart

sMarking = objKomPart7.marking
sName = objKomPart7.name

vFromMsg = MsgBox("Обозначение: " & sMarking & Chr(13) & "Наименование: " & sName, vbOKOnly + vbInformation, "Основная Сборка")

'Запись новых данных
objKomPart7.marking = sMarking & " Дополнение"
objKomPart7.name = sName & " Дополнение"
objKomPart7.Update

sMarking = ""
sName = ""

sMarking = objKomPart7.marking
sName = objKomPart7.name

vFromMsg = MsgBox("Обозначение: " & sMarking & Chr(13) & "Наименование: " & sName, vbOKOnly + vbInformation, "Основная Сборка")

'
'-------------------------------------------------------------------

lblErrorHandler_01: ' Если произошло переключение Активного Документа
If Err.Number <> 0 Then
    vFromMsg = MsgBox("Ошибка обращения к Документу" & "...", vbOKOnly + vbExclamation, "КОМПАС...")
    On Error GoTo -1 'Очистить ошибку
End If 'If Err.Number <> 0 Then


Set objKomApp7 = Nothing
Set objKomDoc7_3D = Nothing
Set objKomPart7 = Nothing

End If 'If bCheckDocAssembling Then 'Если Сборка

End Sub 'Public Sub ChangeAssemblingData()
Спасибо!

[p3452]

Видно КНИГА (оказалась не волшебной!) - не помогла

[Валерич]

Видно КНИГА (оказалась не волшебной!) - не помогла

Что-нибудь ДЕЛЬНОЕ НАПИШИТЕ...
Гуру!

[p3452]

Что-нибудь ДЕЛЬНОЕ НАПИШИТЕ...

См. пост №2 !!!

p/s: Не имеет смысла учиться писать, не выучив буквы...

[Валерич]

«Не в Коня корм»?
Гуру!

[Валерич]

Добрый день!
Пожалуйста, подскажите, как прочитать, записать раздел спецификации в 3D-документе?

[Михаил88]

#67

https://forum.ascon.ru/index.php?topic=32513.msg297635#msg297635

[Student2025]

Во первых, пока не убрал из объявлений типы, ВБА ругался, что пользовательские типы не определены, откуда их взять?
Во вторых, у объекта "text_font" нет свойства "height"

В целом странная ошибка и так и не понял почему она возникает.
Спрашивал ИИ и нашли решение и не одно

Код Выделить Развернуть

Option Explicit

' --- API Declarations (32-bit VBA 6) ---
Private Declare Function IIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As Long, _
    ByRef lpiid As GUID) As Long

Private Declare Function DispCallFunc Lib "oleaut32.dll" ( _
    ByVal pvInstance As Long, _
    ByVal offsetinVft As Long, _
    ByVal CallConv As Long, _
    ByVal retTYP As Integer, _
    ByVal paCNT As Long, _
    ByRef prgvt As Integer, _
    ByRef prgpvarg As Long, _
    ByRef pvargResult As Variant) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByRef Destination As Any, _
    ByRef Source As Any, _
    ByVal Length As Long)

' --- Constants ---
Private Const CC_STDCALL As Long = 4
Private Const VT_I4 As Long = 3
Private Const VT_BYREF As Long = &H4000
Private Const VT_DISPATCH As Long = 9
Private Const S_OK As Long = 0

' --- GUID Type ---
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

' --- QueryInterface Function (ИСПРАВЛЕНО) ---
Public Function QuerySpecificInterface(ByVal pUnk As IUnknown, ByVal strIID As String) As Object
    Dim iid As GUID
    Dim pResult As Long
    Dim hr As Long
    Dim vResult As Variant
    Dim i As Long
   
    ' 1. Convert IID string to GUID
    hr = IIDFromString(StrPtr(strIID), iid)
    Debug.Print "IIDFromString: " & Hex(hr)
    If hr <> S_OK Then Exit Function
   
    ' 2. Prepare arguments
    Dim Vnt(0 To 1) As Variant
    Dim vt(0 To 1) As Integer
    Dim pArgs(0 To 1) As Long
   
    Vnt(0) = VarPtr(iid)
    vt(0) = VT_I4 Or VT_BYREF
    pArgs(0) = VarPtr(Vnt(0))
   
    pResult = 0
    Vnt(1) = VarPtr(pResult)
    vt(1) = VT_I4 Or VT_BYREF
    pArgs(1) = VarPtr(Vnt(1))
   
    ' 3. Call QueryInterface
    hr = DispCallFunc(ObjPtr(pUnk), 0, CC_STDCALL, vbLong, 2, _
        vt(0), pArgs(0), vResult)
   
    Debug.Print "DispCallFunc: " & Hex(hr)
    Debug.Print "HRESULT: " & Hex(vResult)
    Debug.Print "pResult: " & pResult
   
    ' 4. Check result
    If hr = S_OK And vResult = S_OK And pResult <> 0 Then
        ' БЕЗОПАСНОЕ создание объекта из указателя
        Set QuerySpecificInterface = SafeObjectFromPointer(pResult)
    Else
        Err.Raise vbObjectError Or vResult, , "QueryInterface failed: " & Hex(vResult)
    End If
End Function

' --- БЕЗОПАСНАЯ функция создания объекта (ИСПРАВЛЕНО) ---
Private Function SafeObjectFromPointer(ByVal pObj As Long) As Object
    Dim tmp As Variant
    Dim obj As Object
   
    ' Создаём Variant типа VT_DISPATCH (9)
    ' Структура Variant: 2 байта тип + 6 байт паддинг + 4 байта данные (32-бит)
    Dim varData(0 To 11) As Byte
   
    ' Тип VT_DISPATCH (9)
    varData(0) = 9: varData(1) = 0
    ' VT_BYREF флаг НЕ нужен
   
    ' Копируем указатель в данные Variant (байты 8-11 для 32-бит)
    CopyMemory varData(8), pObj, 4
   
    ' Копируем Variant в переменную
    CopyMemory tmp, varData(0), 12
   
    ' Извлекаем объект
    Set obj = tmp
   
    ' Возвращаем объект (VBA сам вызовет AddRef)
    Set SafeObjectFromPointer = obj
End Function

Private Sub Command1_Click()

    Dim application
    Dim kompas_document, layout_sheets, layout_sheet, stamp0
    Dim text0, text_lines, text_line, text_items, text_item, text_font, text_lines2
    Dim ITextFont_uuid
    Dim height, str
   
    Dim ITextFont_IID
   
    ITextFont_IID = "{A6AD008D-58D1-48B5-BD29-E6795289FE4B}"
   
    height = 3.5
   
    Set application = GetObject(, "Kompas.Application.7")
    Set kompas_document = application.ActiveDocument
    Set layout_sheets = kompas_document.LayoutSheets
    Set layout_sheet = layout_sheets.Item(0)
           
    Set stamp0 = layout_sheet.Stamp
    Set text0 = stamp0.Text(1)
   
    text_lines = text0.TextLines
   
    MsgBox (IsArray(text_lines))
    MsgBox (UBound(text_lines))
       
    Set text_line = text_lines(0)
   
    text_items = text_line.TextItems
    Set text_item = text_items(0)
   
    Set text_font = QuerySpecificInterface(text_item, ITextFont_IID)
   
    MsgBox (text_font.height)

End Sub


почему то возвращает родительский объект. Есть объекты обертки и не работает динамическое сведение к объекту ITextFont (text_font).

[Student2025]

Например в python:

Код Выделить Развернуть

import pythoncom
from win32com.client import Dispatch

import KompasApi5V24 as KAPI5
import KompasApi7V24 as KAPI7


api5 = Dispatch('Kompas.Application.5', None, KAPI5.KompasObject.CLSID)
api7 = Dispatch('Kompas.Application.7')

iDoc = api7.ActiveDocument

layout_sheets = iDoc.LayoutSheets
layout_sheet = layout_sheets.Item(0)

stamp0 = layout_sheet.Stamp
text0 = stamp0.Text(1)

text_lines = text0.TextLines

text_line = text_lines[0]

text_items = text_line.TextItems
text_item = text_items[0] # тип объекта ITextItem

text_font_iid = KAPI7.NamesToIIDMap['ITextFont']

print(text_font_iid) #получим {A6AD008D-58D1-48B5-BD29-E6795289FE4B}

#text_font {A6AD008D-58D1-48B5-BD29-E6795289FE4B} ITextFont
#text_item {1DE74AFB-5026-4B85-861F-F0CFDBD443E6} ITextItem

text_font_dispatch = text_item._oleobj_.QueryInterface(text_font_iid, pythoncom.IID_IDispatch)
text_font = Dispatch(text_font_dispatch, None, KAPI7.ITextFont.CLSID)

# все верно работает и получаем верное значение Height
print(text_font.Height)

все работает однако

text_font._oleobj_.GetTypeInfo().GetTypeAttr().iid возвращает iid родительского "действительного" объекта и причем между ними могут быть несколько объектов "оберток".

Как то странно это видеть если база знаний так себе 

[Student2025]

В WSH:VBS другая картина с поучениями объектов:

Код Выделить Развернуть

Option Explicit

Sub FillName()
Dim application
Dim kompas_document, layout_sheets, layout_sheet, stamp0
Dim text0, text_line, text_items, text_item, text_font, text_lines2
Dim ITextFont_uuid
Dim height, str
Dim text_lines

height = 3.5

Set application = GetObject(, "Kompas.Application.7")
Set kompas_document = application.ActiveDocument
Set layout_sheets = kompas_document.Layoutsheets
Set layout_sheet = layout_sheets.Item(0)

Set stamp0 = layout_sheet.Stamp
Set text0 = stamp0.Text(1)

'text_lines = text0.TextLines
'что то не так с text_lines(0)
'Set text_line = text_lines(0)

'WScript.Echo IsArray(text_lines)
'WScript.Echo UBound(text_lines)

Set text_line = text0.TextLine(0)

'text_items = text_line.TextItems
'что то не так с text_items(0)
'Set text_item = text_items(0)

Set text_item = text_line.TextItem(0)

Dim dw
Set dw = CreateObject("DynamicWrapperX")

dw.Register "Kompas.Application.7", "{69AC2981-37C0-4379-84FD-5DD2F3C0A520}", "ITextFont"

Set text_font = dw.Interface(text_item, "ITextFont")

WScript.Echo text_font.Height


WScript.Echo "ok"
End Sub

Call FillName