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


