Создание листового тела в Компас 17.1 с помощью VBA.

Автор Semargl1990, 04.01.20, 00:45:20

« назад - далее »

0 Пользователи и 1 гость просматривают эту тему.

Semargl1990

Написал код в VBA(см.ниже), что создает эскиз квадрата. При созданий листового тела выдает ошибку, помогите решить эту задачку.

Private Sub CommandButton1_Click()
    Set kompas = New Kompas6API5.Application
    kompas.Visible = True
    Set ksdoc = kompas.Document3D
    ksdoc.Create False, True

    'создание эскиза
    Set iPart = ksdoc.GetPart(-1)   
    If Not iPart Is Nothing Then
      Set iplaneXOY = iPart.GetDefaultEntity(1) 
      Set ientity = iPart.NewEntity(5)
      If Not iplaneXOY Is Nothing And Not ientity Is Nothing Then
       
       Set isketch = ientity.GetDefinition()
        If Not isketch Is Nothing Then
         
          isketch.SetPlane iplaneXOY
         
          ientity.Create
         
          Set isketchDoc = isketch.BeginEdit()
         
          isketchDoc.ksLineSeg 0, 0, 100, 0, 1
         
          isketchDoc.ksLineSeg 0, 0, 0, 100, 1
         
          isketchDoc.ksLineSeg 0, 100, 100, 100, 1
         
          isketchDoc.ksLineSeg 100, 100, 100, 0, 1
         
          isketch.EndEdit
        End If
      End If
    End If

'создание листового тела
kompas.ksMessage ("Операции листового выдавливания")
    Set kompas7 = kompas.ksGetApplication7
    Set ksdoc7 = kompas7.SheetMetalContainer
    Set part = ksdoc7.SheetMetalBodies
    Set partbody = part.Add
          partbody.Sketch isketch
          partbody.Thickness 1
          partbody.BendCoefficient 0.4
          partbody.Update
End Sub

#1
Направление выдавливания нужно указать.
Эскиз привести к API7.

Semargl1990

Цитата: Sabahs от 04.01.20, 10:38:30Направление выдавливания нужно указать.
Эскиз привести к API7.
Есть ли конкретный пример работы с листовыми телами на VBA или VB.net? В SDK Компаса v17.1 примеров не нашел.

Semargl1990

Dim kompasDoc As KompasAPI7.KompasDocument

Dim doc2D As KompasAPI7.DrawingDocument

Set kompasDoc = KomApp.ActiveDocument

Set doc2D = kompasDoc // Здесь выполнится QueryInterface.

Как интерпретировать этот кусок кода с VB.net на VBA? Выдает ошибку в строке Set doc2D = kompasDoc type mismatch.

Semargl1990

 Для будущих последователей: вот кусок кода для VBA создающая листовое тело,
на открытие неизвестного острова в карибском море ушел 2 дня, пользуйтесь на здоровье.
Данный код читать совместно с кодом в самом начале, где создается эскиз. Спасибо Sabahs,
который показал в каком направление необходимо работать.

'листовое выдавливание эскиза
    kompas.ksMessage ("Операции листового выдавливания")
    Set kompas7 = kompas.ksGetApplication7
           
    Dim kompasDoc7 As KompasAPI7.KompasDocument3D
   
    Dim doc3D As KompasAPI7.ISheetMetalContainer
   
    Set kompasDoc7 = kompas7.ActiveDocument

    Set doc3D = kompasDoc7.TopPart

    Set sheetbodies = doc3D.SheetMetalBodies
       
    Set sheetbody = sheetbodies.Add
   
    sheetbody.BendCoefficient = 0.4
   
    sheetbody.Depth True, TextBox1.Text
    sheetbody.Depth False, 0
    sheetbody.Direction 0
    sheetbody.ExtrusionType True, 0
    sheetbody.ExtrusionType False, 0
    sheetbody.Radius TextBox3.Text
   
    Set icollection = iPart.EntityCollection(7)
    icollection.SelectByPoint 0, 50, 0
    Set tochka1 = icollection.Last
    Set edgepar = tochka1.GetDefinition
    Set isheetsketch = edgepar.GetOwnerEntity
   
   
    Set isketch7 = kompas.TransferInterface(isheetsketch, 2, 0)
    sheetbody.Sketch isketch7
    sheetbody.Straighten False
    sheetbody.ThicknessDirection True
    sheetbody.Thickness TextBox2.Text
    sheetbody.UnfoldType 0
   
    Dim obj As entity
   
    Set obj = kompas.TransferInterface(sheetbody, 1, 105)
    obj.Name = "Листовое тело:1"
    Set colorpar = obj.ColorParam
    colorpar.ambient 0.5
    colorpar.Color 9474192
    colorpar.diffuse 0.6
    colorpar.emission 0.5
    colorpar.shininess 0.8
    colorpar.specularity 0.8
    colorpar.Transparency 1
    obj.Create

Semargl1990

Помогите создать развертку с помощью VBA, т.е. войти в режим отображения развертки
и установить неподвижный грань. Ниже написал код, но оно неработает. 


'создание развертки
    Set icollectionface = iPart.EntityCollection(6)
    icollectionface.SelectByPoint 0, 60, 100
    Set tochkaface1 = icollectionface.Last
    Set facepar = tochkaface1.GetDefinition
    Set isheetface = facepar.GetOwnerEntity
   
   If Not iPart Is Nothing Then
      Set iunfoldentity = iPart.NewEntity(538)
      If Not isheetface Is Nothing And Not iunfoldentity Is Nothing Then
       
       Set isheetunfold = iunfoldentity.GetDefinition()
        If Not isheetunfold Is Nothing Then
         
          isheetunfold.SetPlane isheetface
         
          iunfoldentity.Create
         
         Set isheetunfolddoc = isheetunfold.BeginEdit()
         Dim objunfold As entity
         Set objunfold = SetPlane.isheetface
                 
         isheetunfolddoc.EndEdit
         
   End If
   End If
   End If