VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Public Kompas As Object

Public Function GetLibraryName() As String
  GetLibraryName = "Работа с компонентой (деталь или сборка)"
End Function

Sub GetSetPartName(doc As Object)  ' взять/изменить имя компоненты
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(pTop_Part) ' верхний компонент
  If Not iPart Is Nothing Then
    Kompas.ksMessage "Имя компоненты = " & iPart.Name()
    iPart.Name = "Втулка"
    iPart.Update
  End If
End Sub

Sub FixAndStandartComponent(doc As Object)  ' фиксирование и установка стандартного объекта
  If doc.IsDetail() Then
    Kompas.ksError "Текущий документ должен быть сборкой"
    Exit Sub
  End If
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(0) ' первая деталь в сборке
  If Not iPart Is Nothing Then
    ' Получить состояние фиксации компонента - в системе поддерживающей работу со свойствами - fixedComponent
    Dim fixed As Integer
    fixed = iPart.fixedComponent()
    ' Получить состояние стандартного компонента - в системе поддерживающей работу со свойствами - standardComponent
    Dim stand As Integer
    stand = iPart.standardComponent()
    If fixed Then
      Kompas.ksMessage "Компонент зафиксирован"
    Else
      Kompas.ksMessage "Компонент не зафиксирован"
    End If
    ' Изменить состояние фиксации компонента - в системе поддерживающей работу со свойствами - fixedComponent
    iPart.fixedComponent = (Not fixed)
    If stand Then
      Kompas.ksMessage "Компонент стандартный"
    Else
      Kompas.ksMessage "Компонент нестандартный"
    End If
    ' Изменить состояние стандартного компонента - в системе поддерживающей работу со свойствами - standardComponent
    iPart.standardComponent = (Not stand)
  End If
End Sub
 
Sub GetSetColorProperty(doc As Object)  ' получить и заменить параметры цвета компоненты
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(pTop_Part) ' верхний компонент
  
  If Not iPart Is Nothing Then
    Dim iColorPr As Object ' ksColorProperty
    Set iColorPr = iPart.ColorParam
    If Not iColorPr Is Nothing Then
      Kompas.ksMessage "Номер цвета = " & iColorPr.COLOR & " Общий цвет = " & iColorPr.Ambient & " Диффузия = " & iColorPr.diffuse & " Зеркальность = " & iColorPr.specularity & " Блеск = " & iColorPr.shininess & " Прозрачность = " & iColorPr.transparency & " Излучение = " & iColorPr.emission
      iColorPr.COLOR = 5421504
      iColorPr.transparency = 0.5
      iColorPr.Ambient = 0.1
      iColorPr.diffuse = 0.1
      iPart.Update
      Kompas.ksMessage "Номер цвета = " & iColorPr.COLOR & " Общий цвет = " & iColorPr.Ambient & " Диффузия = " & iColorPr.diffuse & " Зеркальность = " & iColorPr.specularity & " Блеск = " & iColorPr.shininess & " Прозрачность = " & iColorPr.transparency & " Излучение = " & iColorPr.emission
    End If
  End If
  
  ' Взять и поменять параметры цвета компонента
  'If Not iPart Is Nothing Then
  '  Dim ambient As Double, diffuse As Double, specularity As Double, shininess As Double, transparency As Double, emission As Double
  '  Dim color As Long
  '  iPart.GetAdvancedColor color, ambient, diffuse, specularity, shininess, transparency, emission
  '  Kompas.ksMessage "Номер цвета = " & color & " Общий цвет = " & ambient & " Диффузия = " & diffuse & " Зеркальность = " & specularity & " Блеск = " & shininess & " Прозрачность = " & transparency & " Излучение = " & emission
  '  color = 9421504
  '  transparency = 0.5
  '  ambient = 0.1
  '  diffuse = 0.1
  '  iPart.SetAdvancedColor color, ambient, diffuse, specularity, shininess, transparency, emission
  '  iPart.GetAdvancedColor color, ambient, diffuse, specularity, shininess, transparency, emission
  '  iPart.Update
  '  Kompas.ksMessage "Номер цвета = " & color & " Общий цвет = " & ambient & " Диффузия = " & diffuse & " Зеркальность = " & specularity & " Блеск = " & shininess & " Прозрачность = " & transparency & " Излучение = " & emission '
  'End If
End Sub

Sub GetSetArrayVariable(doc As Object)  ' взять и поменять внешние переменные компоненты
  If doc.IsDetail() Then
    Kompas.ksMessage "Текущий документ должен быть сборкой"
    Exit Sub
  End If
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(0) ' первая деталь в сборке
  If Not iPart Is Nothing Then
    ' работа с массивом внешних переменных
    Dim ivarCol As Object ' ksVariableCollection
    Set ivarCol = iPart.VariableCollection()
    If Not ivarCol Is Nothing Then
      Dim ivar As Object ' ksVariable
      Set ivar = Kompas.GetParamStruct(ko_VariableParam)
      Dim count As Integer
      count = ivarCol.GetCount
      For i = 0 To count - 1
        Set ivar = ivarCol.GetByIndex(i)
        Kompas.ksMessage "Номер переменной = " & i & " Имя переменной = " & ivar.Name & " Значение переменной = " & ivar.Value & " Комментарий = " & ivar.note
        ivar.note = "qwerty"
        Dim d As Double
        d = 0
        Kompas.ksReadDouble "Введи переменную", 10, 0, 100, d
        ivar.Value = d
        Set ivar = Nothing
      Next
      Dim count2 As Integer
      count2 = ivarCol.GetCount
      For j = 0 To count2 - 1 ' просмотр изменненных переменных
        Set ivar = ivarCol.GetByIndex(j)
        Kompas.ksMessage "Номер переменной = " & i & " Имя переменной = " & ivar.Name & " Значение переменной = " & ivar.Value & " Комментарий = " & ivar.note
        Set ivar = Nothing
      Next
      iPart.RebuildModel ' перестроение модели
    End If
  End If
End Sub

Sub GetSetPlacmentComponent(doc As Object) ' получить и изменить место расположения детали в сборке
  If doc.IsDetail Then
    Kompas.ksError "Текущий документ должен быть сборкой"
    Exit Sub
  End If
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(0) ' первая деталь в сборке
  If Not iPart Is Nothing Then
    Dim iplac As Object ' ksPlacement
    Set iplac = iPart.GetPlacement()
    If Not iplac Is Nothing Then
      Dim x As Double, y As Double, z As Double
      iplac.GetOrigin x, y, z
      Kompas.ksMessage "x = " & x & " y = " & y & " z = " & z
      iplac.SetOrigin 20, 20, 20
      iPart.SetPlacement iplac
      iPart.UpdatePlacement
      iPart.Update
    End If
  End If
End Sub

Sub GetSetEntity(doc As Object)  ' Получить интерфейс ksEntity объекта создаваемого системой по умолчанию и поменять параметры
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(pTop_Part) ' верхний компонент
  If Not iPart Is Nothing Then
    Dim iplaneXOY As Object ' ksEntity
    Set iplaneXOY = iPart.GetDefaultEntity(o3d_planeXOY) ' 1-интерфейс на плоскость XOY
    If Not iplaneXOY Is Nothing Then
      Kompas.ksMessage iplaneXOY.Name()
      iplaneXOY.Name = "plane"
      iplaneXOY.Update
    End If
  End If
End Sub

Sub CreateSketch(doc As Object)  ' создание эскиза
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(pTop_Part) ' верхний компонент
  If Not iPart Is Nothing Then
    Dim iplaneXOY As Object ' ksEntity
    Set iplaneXOY = iPart.GetDefaultEntity(o3d_planeXOY) ' 1-интерфейс на плоскость XOY
    Dim ientity As Object ' ksEntity
    Set ientity = iPart.NewEntity(o3d_sketch)
    If Not iplaneXOY Is Nothing And Not ientity Is Nothing Then
      Dim isketch As Object ' ksSketchDefinition
      Set isketch = ientity.GetDefinition()
      If Not isketch Is Nothing Then
        isketch.SetPlane iplaneXOY
        ientity.Create
        Dim isketchDoc As Object ' ksDocument2D
        Set isketchDoc = isketch.BeginEdit()
          isketchDoc.ksLineSeg 0, 0, 100, 100, 1
        isketch.EndEdit
      End If
    End If
  End If
End Sub

Sub GetArraySketch(doc As Object)  ' Формирует массив объектов(здесь эскизов) и возвращает его интерфейс ksEntityCollection ( IEntityCollection )
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(pTop_Part) ' верхний компонент
  If Not iPart Is Nothing Then
    Dim ientityCollection As Object ' ksEntityCollection
    Set ientityCollection = iPart.EntityCollection(o3d_sketch)
    Dim icurrentEntity As Object ' ksEntity
    Set icurrentEntity = iPart.EntityCollection(0)
    If Not ientityCollection Is Nothing And Not icurrentEntity Is Nothing Then
      Dim count As Integer
      count = ientityCollection.GetCount
      For i = 0 To count - 1
        Set icurrentEntity = ientityCollection.GetByIndex(i)
        Kompas.ksMessage icurrentEntity.Name
        Set icurrentEntity = Nothing
      Next
    End If
  End If
End Sub

Sub GetSetUserParamComponent(doc As Object)  ' Установить и получить параметры пользователя в компоненте
  If doc.IsDetail Then
    Kompas.ksError "Текущий документ должен быть сборкой"
    Exit Sub
  End If
  Dim iPart As Object ' ksPart
  Set iPart = doc.GetPart(0) ' первая деталь в сборке

  Dim iPar As Object ' ksUserParam
  Set iPar = Kompas.GetParamStruct(ko_UserParam)
  Dim iItem As Object ' ksLtVariant
  Set iItem = Kompas.GetParamStruct(ko_LtVariant)
  Dim iArr As Object ' ksDynamicArray
  Set iArr = Kompas.GetDynamicArray(LTVARIANT_ARR)
  If iPar Is Nothing Or iItem Is Nothing Or iArr Is Nothing Then
    Exit Sub
  End If
 
  iPar.Init
  iPar.SetUserArray iArr
  iItem.Init
    iItem.doubleVal = 12.12
    iArr.ksAddArrayItem -1, iItem
  iItem.Init
    iItem.doubleVal = 21.21
    iArr.ksAddArrayItem -1, iItem
  iItem.Init
    iItem.intVal = 666
    iArr.ksAddArrayItem -1, iItem
  iItem.Init
    iItem.intVal = 999
    iArr.ksAddArrayItem -1, iItem
  
  iPart.SetUserParam iPar ' установка пользовательской структуры
  iPart.Update

  Kompas.ksMessage "Размер пользовательской структуры = " & iPart.GetUserParamSize ' размер пользовательской структуры

  Dim iPar2 As Object ' ksUserParam
  Set iPar2 = Kompas.GetParamStruct(ko_UserParam)
  Dim iItem2 As Object ' ksLtVariant
  Set iItem2 = Kompas.GetParamStruct(ko_LtVariant)
  Dim iArr2 As Object ' ksDynamicArray
  Set iArr2 = Kompas.GetDynamicArray(LTVARIANT_ARR)
  If iPar2 Is Nothing Or iItem2 Is Nothing Or iArr2 Is Nothing Then
    Exit Sub
  End If

  iPar2.Init
  iPar2.SetUserArray iArr2
  iItem2.Init
    iItem2.doubleVal = 3.3
    iArr2.ksAddArrayItem -1, iItem2
  iItem2.Init
    iItem2.doubleVal = 6.6
    iArr2.ksAddArrayItem -1, iItem2
  iItem2.Init
    iItem2.intVal = 123
    iArr2.ksAddArrayItem -1, iItem2
  iItem2.Init
    iItem2.intVal = 321
    iArr2.ksAddArrayItem -1, iItem2

  iPart.GetUserParam iPar2  ' берем пользовательскeую структуру
  
  Dim a As Double, b As Double
  Dim c As Integer, d As Integer
  iArr2.ksGetArrayItem 0, iItem2
  a = iItem2.doubleVal
  iArr2.ksGetArrayItem 1, iItem2
  b = iItem2.doubleVal
  iArr2.ksGetArrayItem 2, iItem2
  c = iItem2.intVal
  iArr2.ksGetArrayItem 3, iItem2
  d = iItem2.intVal
  'Kompas.ksMessage "a = " & a
  Kompas.ksMessage "Переменные пользовательского массива a = " & a & " b = " & b & " c = " & c & " d = " & d ' просмотрим переменные из пользовательского массива
End Sub

Sub CreateDocument3D() ' Создание документа 3D
  Dim doc As Object
  Set doc = Kompas.Document3D
  If Not doc Is Nothing And doc.Create(False, True) Then
    doc.author = "Автор"                   ' Автор документа
    doc.comment = "Пример документа 3D"    ' Комментарии к документу
    doc.FileName = "c:\example.m3d"        ' Имя файла Документа
    doc.UpdateDocumentParam                ' Обновить параметры Документа
    doc.Save                               ' Сохранить документ
    Kompas.ksMessage "Сохраним документ под другим именем"
    doc.SaveAs "c:\example_1.m3d"          ' сохранить документ под другим именем
    
    ' Автор документа
    Kompas.ksMessage "Автор документа: " & doc.author
    ' Комментарий к документу
    Kompas.ksMessage "Комментарий к документу: " & doc.comment
    ' Имя файла
    Kompas.ksMessage "Имя файла: " & doc.FileName
    
    doc.Close   ' закроем документ
  End If
End Sub

Sub DocIterator() ' итератор по документам
  Dim arrDoc As Object
  Set arrDoc = Kompas.GetDynamicArray(CHAR_STR_ARR)  ' динамический массив указателей на строки символов
  ' если массив создан запускаем диалог выбора файлов
  If Not arrDoc Is Nothing And Kompas.ksChoiceFiles("*.m3d", "Документы (*.m3d)|*.m3d|Все файлы (*.*)|*.*|", arrDoc, False) Then
    Dim item As Object
    Set item = Kompas.GetParamStruct(ko_Char255)
    If Not item Is Nothing Then
      ' откроем все файлы указанные пользователем
      For i = 0 To arrDoc.ksGetArrayCount() - 1
        If arrDoc.ksGetArrayItem(i, item) Then
          Dim doc As Object
          Set doc = Kompas.Document3D
          doc.Open item.Str, False ' открываем файл с заданным именем
        End If
      Next i
    End If
  End If

  ' создаем итератор по документам
  Dim iter As Object
  Set iter = Kompas.GetIterator()
  If Not iter Is Nothing And iter.ksCreateIterator(D3_DOCUMENT_OBJ, 0) Then
    Dim ref As Long ' референс документа
    ref = iter.ksMoveIterator("F")
    If ref Then ' смещаем итератор на первый элемент
      Do  ' смещаем итератор на следующую позицию
        Dim doc2 As Object
        Set doc2 = Kompas.ksGet3dDocumentFromRef(ref)
        If Not doc2 Is Nothing Then
          ' автор документа
          Kompas.ksMessage "Автор документа: " & doc2.author
          ' комментарии к документу
          Kompas.ksMessage "Комментарий к документу: " & doc2.comment
          ' имя файла документа
          Kompas.ksMessage "Имя файла: " & doc2.FileName
          ' тип документа
          If doc2.IsDetail Then
            Kompas.ksMessage "Тип документа: Деталь"
          Else
            Kompas.ksMessage "Тип документа: Сборка"
          End If
        End If
        ref = iter.ksMoveIterator("N")
      Loop While ref
    End If

    ' сообщаем количество открытых файлов
    Kompas.ksMessage "Открыто " & arrDoc.ksGetArrayCount() & " файлов"
    
    iter.ksDeleteIterator ' удалить итератор
  End If

End Sub

Sub UseEntityCollection() ' использование массива элементов
  Dim doc As Object
  Set doc = Kompas.ActiveDocument3D   ' привязываемся к активному документу
  If Not doc Is Nothing Then
    Dim part As Object
    Set part = doc.GetPart(pNew_Part) ' новый компонент
    If Not part Is Nothing Then
      ' массив поверхностей
      Dim collect As Object ' ksEntityCollection
      Set collect = part.EntityCollection(o3d_face)
      Dim count  As Integer
      Dim count1 As Integer
      Dim count2 As Integer
      
      count = collect.GetCount
      count1 = 0 ' количество плоских поверхностей
      count2 = 0 ' количество конических поверхностей
      
      If Not collect Is Nothing And count Then
        For i = 0 To count - 1
          Dim ent As Object ' ksEntity
          Set ent = collect.GetByIndex(i)
          ' интерфейс свойств поверхности
          Dim faceDef As Object      ' ksFaceDefinition
          Set faceDef = ent.GetDefinition
              
          Dim colorPr As Object ' ksColorProperty - интерфейс свойств цвета
          Set colorPr = ent.ColorParam
          
          If Not faceDef Is Nothing Then
            If faceDef.IsCone Or faceDef.IsCylinder Then  ' коническая по-ть
              colorPr.COLOR = vbBlue
              count2 = count2 + 1    ' считаем количество объектов
            End If

            If faceDef.IsPlanar Then ' плоская по-ть
              colorPr.COLOR = vbGreen
              count1 = count1 + 1    ' считаем количество объектов
            End If
          
            ent.Update ' обновить параметры
          End If
        Next i
      End If
      
      ' сообщяем о результатах работы
      If count = 0 Then
        Kompas.ksMessage "Не найдено ни одной поверхности"
      Else
        Kompas.ksMessage "Найдено " & count2 & " коничечких и " & count1 & " плоских объектов"
      End If
      
      count1 = 0
      count2 = 0
      ' массив ребер
      Dim collect2 As Object ' ksEntityCollection
      Set collect2 = part.EntityCollection(o3d_edge)
      count = collect2.GetCount
      If Not collect2 Is Nothing And count Then
        For i = 0 To count - 1
          Dim ent2 As Object      ' ksEntity
          Set ent2 = collect2.GetByIndex(i)
          Dim edgeDef As Object   ' ksEdgeDefinition
          Set edgeDef = ent2.GetDefinition
          If Not edgeDef Is Nothing Then
            If edgeDef.IsStraight Then
              count1 = count1 + 1 ' количество прямых ребер
            Else
              count2 = count2 + 1 ' количество криволинейных ребер
            End If
          End If
        Next i
      
        ' сообщяем о результатах работы
        If count = 0 Then
          Kompas.ksMessage "Не найдено ни одного ребра"
        Else
          Kompas.ksMessage "Найдено " & count1 & " прямых и " & count2 & " криволинейных ребер"
        End If
      End If
    End If
  End If
End Sub


Public Sub ExternalRunCommand(ByVal command As Integer, ByVal mode As Integer, ByVal kompas_ As Object)
  Set Kompas = kompas_
    
  Select Case command
    Case 1:
      CreateDocument3D ' Создание документа
    Case 2:
      DocIterator      ' итератор по документам
    Case 3:
      UseEntityCollection ' использование массива элементов
    Case Else:
      Dim doc As Object
      Set doc = Kompas.ActiveDocument3D
      If Not doc Is Nothing Then
        Select Case command
          Case 4: GetSetPartName doc           ' взять/изменить имя компоненты
          Case 5: FixAndStandartComponent doc  ' фиксирование и установка стандартного объекта
          Case 6: GetSetColorProperty doc      ' получить и заменить параметры цвета компоненты
          Case 7: GetSetArrayVariable doc      ' взять и поменять внешние переменные компоненты
          Case 8: GetSetPlacmentComponent doc  ' получить и изменить место расположения детали в сборке
          Case 9: GetSetEntity doc             ' Получить интерфейс ksEntity объекта создаваемого системой по умолчанию и поменять параметры
          Case 10: CreateSketch doc             ' создать эскиз
          Case 11: GetArraySketch doc           ' Формирует массив объектов(здесь эскизов) и возвращает его интерфейс ksEntityCollection ( IEntityCollection )
          Case 12: GetSetUserParamComponent doc ' Установить и получить параметры пользователя в компоненте
        End Select
      End If
  End Select
End Sub

Public Function ExternalMenuItem(ByVal number As Integer, itemType As Integer, command As Integer) As String
    itemType = 3 '"ENDMENU"'
    ExternalMenuItem = ""
    command = -1

    Select Case number
        Case 1
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Создание 3D документа"
            command = 1
        Case 2
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Итератор по документам"
            command = 2
        Case 3
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Массивы элементов"
            command = 3
        Case 4
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Взять и поменять имя компоненты"
            command = 4
        Case 5
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Фиксирование и установка стандартного объекта"
            command = 5
        Case 6
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Получить и заменить параметры цвета компоненты"
            command = 6
        Case 7
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Взять и поменять внешние переменные компоненты"
            command = 7
        Case 8
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Получить и изменить расположение детали в сборке"
            command = 8
        Case 9
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Получить и изменить парметры базовой плоскости"
            command = 9
        Case 10
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Создать эскиз"
            command = 10
        Case 11
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Вернуть массив эскизов"
            command = 11
        Case 12
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Установить и получить параметры пользователя в компоненте"
            command = 12
        Case 13
            itemType = 3 '"ENDMENU"'
            ExternalMenuItem = ""
            command = -1
    End Select
End Function