---

Hallo werte IV-Gemeinde
Wie kann ich per VBA feststellen ob ein Bauteil rund oder eckig ist (Rohr oder Flachstahl)?
Ich möchte über eine If-Then-Else Abfrage ein entsprechenden Code starten.
Gruß Didi

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Alle Faces des SurfaceBody prüfen, ob eine den SurfaceType kCylinderSurface hat ist eine Möglichkeit.

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Wo finde ich das?
Ich habe bisher alle Rundkörper über Bauteilmodellierung und Parameter erstellt, nicht über Freiform.

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Didikalle,

mit unten stehendem Code findest du Zylinderflächen in Bauteilen.

Wie sie erstellt wurden ist dabei egal, für Inventor sind Solids aus Einzelflächen zusammen gesetzt. Was wiederum das Problem ergibt, dass z.B. eine Verrundung meist auch eine Zylinderfläche darstellt, eine Bohrung selbstverständlich auch.

Umgekehrt kann (bzw. wird in den meisten Fällen) natürlich auch ein Rundkörper plane Flächen aufweisen z.B. Zylinderendflächen, dazu ggf. noch Schlüsselflächen usw.

Einen Flachstahl o.ä. OHNE Bearbeitung zu identifizieren ist relativ trivial, ein Rohr/Zylinder OHNE Bearbeitung auch. Alles darüber hinaus finde ich dann aber deutlich ambitionierter 

Code:

---

Sub FindCylinderFaces()

Dim oApp As Application
Set oApp = ThisApplication

Dim oPrtDoc As PartDocument
Set oPrtDoc = oApp.ActiveDocument

Dim oSrfceBds As SurfaceBodies
Set oSrfceBds = oPrtDoc.ComponentDefinition.SurfaceBodies

Dim oSrfceBody As SurfaceBody

Dim oFaces As Faces

Dim oFace As Face

For Each oSrfceBody In oSrfceBds

    Set oFaces = oSrfceBody.Faces
       
        For Each oFace In oFaces
           
            Debug.Print "Oberflächentyp: " & oFace.SurfaceType
           
            If oFace.SurfaceType = kCylinderSurface Then
                Debug.Print "Zylinderfläche gefunden"
            End If
            Debug.Print ""
        Next
Next
   
End Sub

---

Grüße

EIBe 3D

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo EIBe 3D
Das funktioniert wenn ich ein rundes Teil habe. Ich rufe statt Debug.Print ein Code auf (Call Rund). Ist das Teil ein Flach soll ein anderer Code aufgerufen werden (Call Flach). Ich habe schon mit Else probiert, bekomme es aber nicht hin. Wie muss die Lösung lauten??

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ich kann dir leider nicht ganz folgen.

Bitte präzisier was du machst, vorhast, bzw. Poste deinen Code

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Zur Zeit habe ich 2 Button. Einer stößt den Code an um bei einem eckigen Bauteil die Werte Länge x Breite x Stärke zur weiteren Verarbeitung auszugeben. Der andere gibt bei einem runden Teil die Werte Durchmesser x Länge aus. Nun möchte ich, um die Fehler beim verkehrten Klicken zu minimieren, beides mit einer If Then Else-Entscheidung auf ein Button legen.

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ok, verständlich.

Aber ohne deinen Code zu kennen ist es nur ein stochern im Nebel was dabei schief läuft.

Wenn du ihn hier posten würdest kann ich vielleicht helfen.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hier der Code für runde Bauteile:

Code:

---

Public Sub Rund()
    Call Parameter
    Call Rund_1
    Call Comment
End Sub

Public Sub Parameter()
Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument

Dim oParams As Inventor.Parameters
Set oParams = oDoc.ComponentDefinition.Parameters
Dim oparam As Parameter

For Each oparam In oParams.ModelParameters

  oparam.ExposedAsProperty = False
   
Next

End Sub

Public Sub Rund_1()

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
 
    Dim oDoc As PartDocument
    Set oDoc = oApp.ActiveDocument
 
    Dim oPane As BrowserPane
    Set oPane = oDoc.BrowserPanes("Modell")
 
    Call oPane.TopNode.DoSelect
 
    Dim oCompDef As ComponentDefinition
    Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition
   
    If oDoc.SelectSet.Count = 0 Then
        MsgBox "Bitte vorher Baugruppe auswählen."

        ' Delete any graphics, if they exist.
        On Error Resume Next
        Dim oExistingGraphicsData As GraphicsDataSets
        Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
        If Err.Number = 0 Then
            On Error GoTo 0
            Dim oExistingGraphics As ClientGraphics
            Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
            oExistingGraphics.Delete
            oExistingGraphicsData.Delete
            ThisApplication.ActiveView.Update
        End If

        Exit Sub
    End If

    ReDim aoRanges(1 To oDoc.SelectSet.Count) As Box
    Dim iRangeCount As Long
    Dim i As Long
    On Error Resume Next
    For i = 1 To oDoc.SelectSet.Count
      Dim oBox As Box
        Set oBox = oDoc.SelectSet.Item(i).RangeBox
        If Err Then
            Err.Clear
            ' Special case for B-Rep entities.
            If oDoc.SelectSet.Item(i).Type = kFaceObject Or _
              oDoc.SelectSet.Item(i).Type = kFaceProxyObject Or _
              oDoc.SelectSet.Item(i).Type = kEdgeObject Or _
              oDoc.SelectSet.Item(i).Type = kEdgeProxyObject Then
                ' Get the range from evaluator of the BRep object.
                Set oBox = oDoc.SelectSet.Item(i).Evaluator.RangeBox
                iRangeCount = iRangeCount + 1
                Set aoRanges(iRangeCount) = oBox
            End If
        Else
            iRangeCount = iRangeCount + 1
            Set aoRanges(iRangeCount) = oBox
        End If
    Next
    On Error GoTo 0

    If iRangeCount = 0 Then
        MsgBox "You must pick object(s) that support a 3D RangeBox property."
        Exit Sub
    End If

    ' Check to see if range box graphics information already exists.
    On Error Resume Next
    Dim oClientGraphics As ClientGraphics
    Dim oLineGraphics As LineGraphics
    Dim oBoxNode As GraphicsNode
    Dim oGraphicsData As GraphicsDataSets
    Set oGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
    If Err Then
        Err.Clear
        On Error GoTo 0

        ' Set a reference to the transient geometry object for user later.
        Dim oTransGeom As TransientGeometry
        Set oTransGeom = ThisApplication.TransientGeometry

        ' Create a graphics data set object. This object contains all of the
        ' information used to define the graphics.
        Dim oDataSets As GraphicsDataSets
        Set oDataSets = oDoc.GraphicsDataSetsCollection.Add("RangeBoxGraphics")

        ' Create a coordinate set.
        Dim oCoordSet As GraphicsCoordinateSet
        Set oCoordSet = oDataSets.CreateCoordinateSet(1)

        ' Create the client graphics for this compdef.
        Set oClientGraphics = oCompDef.ClientGraphicsCollection.Add("RangeBoxGraphics")

        ' Create a graphics node.
        Set oBoxNode = oClientGraphics.AddNode(1)
        oBoxNode.Selectable = False

        ' Create line graphics.
        Set oLineGraphics = oBoxNode.AddLineGraphics

        oLineGraphics.CoordinateSet = oCoordSet
    Else
        Set oCoordSet = oGraphicsData.ItemById(1)
        Set oBoxNode = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics").ItemById(1)
    End If

    Dim dBoxLines() As Double
    ReDim dBoxLines(1 To 12 * 6 * iRangeCount) As Double
    For i = 0 To iRangeCount - 1
        Dim MinPoint(1 To 3) As Double
        Dim MaxPoint(1 To 3) As Double
        Call aoRanges(i + 1).GetBoxData(MinPoint, MaxPoint)

        ' Line 1
        dBoxLines(i * 72 + 1) = MinPoint(1)
        dBoxLines(i * 72 + 2) = MinPoint(2)
        dBoxLines(i * 72 + 3) = MinPoint(3)
        dBoxLines(i * 72 + 4) = MaxPoint(1)
        dBoxLines(i * 72 + 5) = MinPoint(2)
        dBoxLines(i * 72 + 6) = MinPoint(3)

        ' Line 2
        dBoxLines(i * 72 + 7) = MinPoint(1)
        dBoxLines(i * 72 + 8) = MinPoint(2)
        dBoxLines(i * 72 + 9) = MinPoint(3)
        dBoxLines(i * 72 + 10) = MinPoint(1)
        dBoxLines(i * 72 + 11) = MaxPoint(2)
        dBoxLines(i * 72 + 12) = MinPoint(3)

        ' Line 3
        dBoxLines(i * 72 + 13) = MinPoint(1)
        dBoxLines(i * 72 + 14) = MinPoint(2)
        dBoxLines(i * 72 + 15) = MinPoint(3)
        dBoxLines(i * 72 + 16) = MinPoint(1)
        dBoxLines(i * 72 + 17) = MinPoint(2)
        dBoxLines(i * 72 + 18) = MaxPoint(3)

        ' Line 4
        dBoxLines(i * 72 + 19) = MaxPoint(1)
        dBoxLines(i * 72 + 20) = MaxPoint(2)
        dBoxLines(i * 72 + 21) = MaxPoint(3)
        dBoxLines(i * 72 + 22) = MinPoint(1)
        dBoxLines(i * 72 + 23) = MaxPoint(2)
        dBoxLines(i * 72 + 24) = MaxPoint(3)

        ' Line 5
        dBoxLines(i * 72 + 25) = MaxPoint(1)
        dBoxLines(i * 72 + 26) = MaxPoint(2)
        dBoxLines(i * 72 + 27) = MaxPoint(3)
        dBoxLines(i * 72 + 28) = MaxPoint(1)
        dBoxLines(i * 72 + 29) = MinPoint(2)
        dBoxLines(i * 72 + 30) = MaxPoint(3)

        ' Line 6
        dBoxLines(i * 72 + 31) = MaxPoint(1)
        dBoxLines(i * 72 + 32) = MaxPoint(2)
        dBoxLines(i * 72 + 33) = MaxPoint(3)
        dBoxLines(i * 72 + 34) = MaxPoint(1)
        dBoxLines(i * 72 + 35) = MaxPoint(2)
        dBoxLines(i * 72 + 36) = MinPoint(3)

        ' Line 7
        dBoxLines(i * 72 + 37) = MinPoint(1)
        dBoxLines(i * 72 + 38) = MaxPoint(2)
        dBoxLines(i * 72 + 39) = MinPoint(3)
        dBoxLines(i * 72 + 40) = MaxPoint(1)
        dBoxLines(i * 72 + 41) = MaxPoint(2)
        dBoxLines(i * 72 + 42) = MinPoint(3)

        ' Line 8
        dBoxLines(i * 72 + 43) = MinPoint(1)
        dBoxLines(i * 72 + 44) = MaxPoint(2)
        dBoxLines(i * 72 + 45) = MinPoint(3)
        dBoxLines(i * 72 + 46) = MinPoint(1)
        dBoxLines(i * 72 + 47) = MaxPoint(2)
        dBoxLines(i * 72 + 48) = MaxPoint(3)

        ' Line 9
        dBoxLines(i * 72 + 49) = MaxPoint(1)
        dBoxLines(i * 72 + 50) = MinPoint(2)
        dBoxLines(i * 72 + 51) = MaxPoint(3)
        dBoxLines(i * 72 + 52) = MaxPoint(1)
        dBoxLines(i * 72 + 53) = MinPoint(2)
        dBoxLines(i * 72 + 54) = MinPoint(3)

        ' Line 10
        dBoxLines(i * 72 + 55) = MaxPoint(1)
        dBoxLines(i * 72 + 56) = MinPoint(2)
        dBoxLines(i * 72 + 57) = MaxPoint(3)
        dBoxLines(i * 72 + 58) = MinPoint(1)
        dBoxLines(i * 72 + 59) = MinPoint(2)
        dBoxLines(i * 72 + 60) = MaxPoint(3)

        ' Line 11
        dBoxLines(i * 72 + 61) = MinPoint(1)
        dBoxLines(i * 72 + 62) = MinPoint(2)
        dBoxLines(i * 72 + 63) = MaxPoint(3)
        dBoxLines(i * 72 + 64) = MinPoint(1)
        dBoxLines(i * 72 + 65) = MaxPoint(2)
        dBoxLines(i * 72 + 66) = MaxPoint(3)

        ' Line 12
        dBoxLines(i * 72 + 67) = MaxPoint(1)
        dBoxLines(i * 72 + 68) = MinPoint(2)
        dBoxLines(i * 72 + 69) = MinPoint(3)
        dBoxLines(i * 72 + 70) = MaxPoint(1)
        dBoxLines(i * 72 + 71) = MaxPoint(2)
        dBoxLines(i * 72 + 72) = MinPoint(3)
    Next

    ' Assign the points into the coordinate set.
    Call oCoordSet.PutCoordinates(dBoxLines)

    ' Update the display.
    ThisApplication.ActiveView.Update
     
' Create a string that defines an area using the current length unit.
    Dim oUOM As UnitsOfMeasure
    Set oUOM = ThisApplication.ActiveDocument.UnitsOfMeasure
 
  ' Get the enum value that defines the current default length units.
    Dim eLengthUnit As UnitsTypeEnum
    eLengthUnit = oUOM.LengthUnits

    ' Get the equivalent string of the enum value.
    Dim sLengthUnit As String
    sLengthUnit = " " & oUOM.GetStringFromType(eLengthUnit)
   
    Dim rLänge As String
    'Dim rBreite As Double
    Dim rStärke As String
   
   
    If (MaxPoint(1) - MinPoint(1)) = (MaxPoint(2) - MinPoint(2)) Then
    rLänge = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    'rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rStärke = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
   
    ElseIf (MaxPoint(2) - MinPoint(2)) = (MaxPoint(3) - MinPoint(3)) Then
    rLänge = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    'rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rStärke = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
   
    Else
    rLänge = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    'rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rStärke = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    End If
   
    'rLänge = Round((MaxPoint(3) - MinPoint(3)) * 10, 3)
    'rStärke = Round((MaxPoint(2) - MinPoint(2)) * 10, 3)
   
    'rLänge = (MaxPoint(1) - MinPoint(1)) * 10
  ' rBreite = (MaxPoint(2) - MinPoint(2)) * 10
    'rStärke = (MaxPoint(3) - MinPoint(3)) * 10
               
    MsgBox "Durchmesser: " & rLänge & sLengthUnit & Chr(13) & Chr(10) & "Länge: " & rStärke & sLengthUnit
   
    'rLänge = Format$(rLänge, "###0.0")
    'rBreite = Format$(rBreite, "###0.0")
    'rStärke = Format$(rStärke, "###0")
   
    Dim bLängeDa As Boolean
    Dim oProper As Property
    bLängeDa = False
    For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert D5CDD505-2E9C-101B-9397-08002B2CF9AE
        If oProper.Name = "Durchmesser" Then
            bLängeDa = True
            Exit For
        End If
    Next
    'Durchmesser eintragen oder ändern
    If bLängeDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Durchmesser").Value = rLänge
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rLänge, "Durchmesser"
    End If
   
   
    'Länge vorhanden?
    Dim bStärkeDa As Boolean
    bStärkeDa = False
    For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProper.Name = "Länge" Then
            bStärkeDa = True
            Exit For
        End If
    Next
    'Länge eintragen oder ändern
    If bStärkeDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Länge").Value = rStärke
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rStärke, "Länge"
    End If
   
   
    'Da die ClientGraphic nur temporär sein soll, wird sie nach Bestätigen
    'der Meldung wieder gelöscht.
    If oDoc.SelectSet.Count = 0 Then
   
    ' Delete any graphics, if they exist.
    On Error Resume Next
    Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
    If Err.Number = 0 Then
        On Error GoTo 0
        Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
        oExistingGraphics.Delete
        oExistingGraphicsData.Delete
        ThisApplication.ActiveView.Update
    End If

    Exit Sub
    End If
   
End Sub
Public Sub Comment()

  Dim oDoc As PartDocument
  Set oDoc = ThisApplication.ActiveDocument
   
  Dim oPropSets As PropertySets
  Set oPropSets = oDoc.PropertySets
 
  Dim oPropSet As PropertySet
 
  For Each oPropSet In oPropSets
       
    For i = 1 To oPropSet.Count
     
      If oPropSet(i).Name = "Comments" Then
        On Error Resume Next
        Debug.Print oPropSet(i).Name & "    " & oPropSet(i).Value
        oPropSet(i).Value = "=Ø<Durchmesser>x<Länge>"
      End If
     
      If oPropSet(i).Name = "Creation Time" Then
        On Error Resume Next
        Debug.Print oPropSet(i).Name & "    " & oPropSet(i).Value
        oPropSet(i).Value = Now
      End If
     
    Next i
 
  Next oPropSet
   
End Sub

---

Hier der Code für eckige Bauteile:

Code:

---

Public Sub Flach()
    Call Parameter
    Call Flach_1
    Call Comments
End Sub

Public Sub Parameter()
Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument

Dim oParams As Inventor.Parameters
Set oParams = oDoc.ComponentDefinition.Parameters
Dim oparam As Parameter

For Each oparam In oParams.ModelParameters

  oparam.ExposedAsProperty = False
   
Next

End Sub

Public Sub Flach_1()

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
 
    Dim oDoc As PartDocument
    Set oDoc = oApp.ActiveDocument
 
    Dim oPane As BrowserPane
    Set oPane = oDoc.BrowserPanes("Modell")
 
    Call oPane.TopNode.DoSelect
 
    Dim oBrowserNode As BrowserNode
 
    For Each oBrowserNode In ThisApplication.ActiveDocument.BrowserPanes.Item("Modell").TopNode.BrowserNodes
   
    If Right(oBrowserNode.FullPath, 10) = "Abwicklung" Then
        oBrowserNode.DoSelect
  End If

Next

    Dim oCompDef As ComponentDefinition
    Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition
   
    If oDoc.SelectSet.Count = 0 Then
        MsgBox "Bitte vorher Baugruppe auswählen."

        ' Delete any graphics, if they exist.
        On Error Resume Next
        Dim oExistingGraphicsData As GraphicsDataSets
        Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
        If Err.Number = 0 Then
            On Error GoTo 0
            Dim oExistingGraphics As ClientGraphics
            Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
            oExistingGraphics.Delete
            oExistingGraphicsData.Delete
            ThisApplication.ActiveView.Update
        End If

        Exit Sub
    End If

    ReDim aoRanges(1 To oDoc.SelectSet.Count) As Box
    Dim iRangeCount As Long
    Dim i As Long
    On Error Resume Next
    For i = 1 To oDoc.SelectSet.Count
      Dim oBox As Box
        Set oBox = oDoc.SelectSet.Item(i).RangeBox
        If Err Then
            Err.Clear
            ' Special case for B-Rep entities.
            If oDoc.SelectSet.Item(i).Type = kFaceObject Or _
              oDoc.SelectSet.Item(i).Type = kFaceProxyObject Or _
              oDoc.SelectSet.Item(i).Type = kEdgeObject Or _
              oDoc.SelectSet.Item(i).Type = kEdgeProxyObject Then
                ' Get the range from evaluator of the BRep object.
                Set oBox = oDoc.SelectSet.Item(i).Evaluator.RangeBox
                iRangeCount = iRangeCount + 1
                Set aoRanges(iRangeCount) = oBox
            End If
        Else
            iRangeCount = iRangeCount + 1
            Set aoRanges(iRangeCount) = oBox
        End If
    Next
    On Error GoTo 0

    If iRangeCount = 0 Then
        MsgBox "You must pick object(s) that support a 3D RangeBox property."
        Exit Sub
    End If

    ' Check to see if range box graphics information already exists.
    On Error Resume Next
    Dim oClientGraphics As ClientGraphics
    Dim oLineGraphics As LineGraphics
    Dim oBoxNode As GraphicsNode
    Dim oGraphicsData As GraphicsDataSets
    Set oGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
    If Err Then
        Err.Clear
        On Error GoTo 0

        ' Set a reference to the transient geometry object for user later.
        Dim oTransGeom As TransientGeometry
        Set oTransGeom = ThisApplication.TransientGeometry

        ' Create a graphics data set object. This object contains all of the
        ' information used to define the graphics.
        Dim oDataSets As GraphicsDataSets
        Set oDataSets = oDoc.GraphicsDataSetsCollection.Add("RangeBoxGraphics")

        ' Create a coordinate set.
        Dim oCoordSet As GraphicsCoordinateSet
        Set oCoordSet = oDataSets.CreateCoordinateSet(1)

        ' Create the client graphics for this compdef.
        Set oClientGraphics = oCompDef.ClientGraphicsCollection.Add("RangeBoxGraphics")

        ' Create a graphics node.
        Set oBoxNode = oClientGraphics.AddNode(1)
        oBoxNode.Selectable = False

        ' Create line graphics.
        Set oLineGraphics = oBoxNode.AddLineGraphics

        oLineGraphics.CoordinateSet = oCoordSet
    Else
        Set oCoordSet = oGraphicsData.ItemById(1)
        Set oBoxNode = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics").ItemById(1)
    End If

    Dim dBoxLines() As Double
    ReDim dBoxLines(1 To 12 * 6 * iRangeCount) As Double
    For i = 0 To iRangeCount - 1
        Dim MinPoint(1 To 3) As Double
        Dim MaxPoint(1 To 3) As Double
        Call aoRanges(i + 1).GetBoxData(MinPoint, MaxPoint)

        ' Line 1
        dBoxLines(i * 72 + 1) = MinPoint(1)
        dBoxLines(i * 72 + 2) = MinPoint(2)
        dBoxLines(i * 72 + 3) = MinPoint(3)
        dBoxLines(i * 72 + 4) = MaxPoint(1)
        dBoxLines(i * 72 + 5) = MinPoint(2)
        dBoxLines(i * 72 + 6) = MinPoint(3)

        ' Line 2
        dBoxLines(i * 72 + 7) = MinPoint(1)
        dBoxLines(i * 72 + 8) = MinPoint(2)
        dBoxLines(i * 72 + 9) = MinPoint(3)
        dBoxLines(i * 72 + 10) = MinPoint(1)
        dBoxLines(i * 72 + 11) = MaxPoint(2)
        dBoxLines(i * 72 + 12) = MinPoint(3)

        ' Line 3
        dBoxLines(i * 72 + 13) = MinPoint(1)
        dBoxLines(i * 72 + 14) = MinPoint(2)
        dBoxLines(i * 72 + 15) = MinPoint(3)
        dBoxLines(i * 72 + 16) = MinPoint(1)
        dBoxLines(i * 72 + 17) = MinPoint(2)
        dBoxLines(i * 72 + 18) = MaxPoint(3)

        ' Line 4
        dBoxLines(i * 72 + 19) = MaxPoint(1)
        dBoxLines(i * 72 + 20) = MaxPoint(2)
        dBoxLines(i * 72 + 21) = MaxPoint(3)
        dBoxLines(i * 72 + 22) = MinPoint(1)
        dBoxLines(i * 72 + 23) = MaxPoint(2)
        dBoxLines(i * 72 + 24) = MaxPoint(3)

        ' Line 5
        dBoxLines(i * 72 + 25) = MaxPoint(1)
        dBoxLines(i * 72 + 26) = MaxPoint(2)
        dBoxLines(i * 72 + 27) = MaxPoint(3)
        dBoxLines(i * 72 + 28) = MaxPoint(1)
        dBoxLines(i * 72 + 29) = MinPoint(2)
        dBoxLines(i * 72 + 30) = MaxPoint(3)

        ' Line 6
        dBoxLines(i * 72 + 31) = MaxPoint(1)
        dBoxLines(i * 72 + 32) = MaxPoint(2)
        dBoxLines(i * 72 + 33) = MaxPoint(3)
        dBoxLines(i * 72 + 34) = MaxPoint(1)
        dBoxLines(i * 72 + 35) = MaxPoint(2)
        dBoxLines(i * 72 + 36) = MinPoint(3)

        ' Line 7
        dBoxLines(i * 72 + 37) = MinPoint(1)
        dBoxLines(i * 72 + 38) = MaxPoint(2)
        dBoxLines(i * 72 + 39) = MinPoint(3)
        dBoxLines(i * 72 + 40) = MaxPoint(1)
        dBoxLines(i * 72 + 41) = MaxPoint(2)
        dBoxLines(i * 72 + 42) = MinPoint(3)

        ' Line 8
        dBoxLines(i * 72 + 43) = MinPoint(1)
        dBoxLines(i * 72 + 44) = MaxPoint(2)
        dBoxLines(i * 72 + 45) = MinPoint(3)
        dBoxLines(i * 72 + 46) = MinPoint(1)
        dBoxLines(i * 72 + 47) = MaxPoint(2)
        dBoxLines(i * 72 + 48) = MaxPoint(3)

        ' Line 9
        dBoxLines(i * 72 + 49) = MaxPoint(1)
        dBoxLines(i * 72 + 50) = MinPoint(2)
        dBoxLines(i * 72 + 51) = MaxPoint(3)
        dBoxLines(i * 72 + 52) = MaxPoint(1)
        dBoxLines(i * 72 + 53) = MinPoint(2)
        dBoxLines(i * 72 + 54) = MinPoint(3)

        ' Line 10
        dBoxLines(i * 72 + 55) = MaxPoint(1)
        dBoxLines(i * 72 + 56) = MinPoint(2)
        dBoxLines(i * 72 + 57) = MaxPoint(3)
        dBoxLines(i * 72 + 58) = MinPoint(1)
        dBoxLines(i * 72 + 59) = MinPoint(2)
        dBoxLines(i * 72 + 60) = MaxPoint(3)

        ' Line 11
        dBoxLines(i * 72 + 61) = MinPoint(1)
        dBoxLines(i * 72 + 62) = MinPoint(2)
        dBoxLines(i * 72 + 63) = MaxPoint(3)
        dBoxLines(i * 72 + 64) = MinPoint(1)
        dBoxLines(i * 72 + 65) = MaxPoint(2)
        dBoxLines(i * 72 + 66) = MaxPoint(3)

        ' Line 12
        dBoxLines(i * 72 + 67) = MaxPoint(1)
        dBoxLines(i * 72 + 68) = MinPoint(2)
        dBoxLines(i * 72 + 69) = MinPoint(3)
        dBoxLines(i * 72 + 70) = MaxPoint(1)
        dBoxLines(i * 72 + 71) = MaxPoint(2)
        dBoxLines(i * 72 + 72) = MinPoint(3)
    Next

    ' Assign the points into the coordinate set.
    Call oCoordSet.PutCoordinates(dBoxLines)

    ' Update the display.
    ThisApplication.ActiveView.Update
     
' Create a string that defines an area using the current length unit.
    Dim oUOM As UnitsOfMeasure
    Set oUOM = ThisApplication.ActiveDocument.UnitsOfMeasure
 
  ' Get the enum value that defines the current default length units.
    Dim eLengthUnit As UnitsTypeEnum
    eLengthUnit = oUOM.LengthUnits

    ' Get the equivalent string of the enum value.
    Dim sLengthUnit As String
    sLengthUnit = " " & oUOM.GetStringFromType(eLengthUnit)
         
    'Dim sLänge As String
    'Dim sBreite As String
    'Dim sStärke As String
   
    Dim rLänge As String
    Dim rBreite As String
    Dim rStärke As String
   
'festlegen, dass Länge immer Lännge, Breite immer Breite und Stärke immer Stärke ist
   
    If (MaxPoint(2) - MinPoint(2)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(2) - MinPoint(2)) > (MaxPoint(3) - MinPoint(3)) And (MaxPoint(1) - MinPoint(1) > (MaxPoint(3) - MinPoint(3))) Then
    rLänge = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rStärke = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
   
    ElseIf (MaxPoint(3) - MinPoint(3)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(3) - MinPoint(3)) > (MaxPoint(2) - MinPoint(2)) And (MaxPoint(1) - MinPoint(1) > (MaxPoint(2) - MinPoint(2))) Then
    rLänge = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
    rBreite = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rStärke = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
   
    ElseIf (MaxPoint(1) - MinPoint(1)) > (MaxPoint(3) - MinPoint(3)) And (MaxPoint(1) - MinPoint(1)) > (MaxPoint(2) - MinPoint(2)) And (MaxPoint(3) - MinPoint(3) > (MaxPoint(2) - MinPoint(2))) Then
    rLänge = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rBreite = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
    rStärke = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
   
    ElseIf (MaxPoint(2) - MinPoint(2)) > (MaxPoint(3) - MinPoint(3)) And (MaxPoint(2) - MinPoint(2)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(3) - MinPoint(3) > (MaxPoint(1) - MinPoint(1))) Then
    rLänge = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    rBreite = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
    rStärke = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
   
    ElseIf (MaxPoint(3) - MinPoint(3)) > (MaxPoint(2) - MinPoint(2)) And (MaxPoint(3) - MinPoint(3)) > (MaxPoint(1) - MinPoint(1)) And (MaxPoint(2) - MinPoint(2) > (MaxPoint(1) - MinPoint(1))) Then
    rLänge = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
    rBreite = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    rStärke = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
     
    Else
    rLänge = Round((MaxPoint(1) - MinPoint(1)) * 10, 1)
    rBreite = Round((MaxPoint(2) - MinPoint(2)) * 10, 1)
    rStärke = Round((MaxPoint(3) - MinPoint(3)) * 10, 1)
    End If
         
    MsgBox "Länge: " & rLänge & sLengthUnit & Chr(13) & Chr(10) & "Breite: " & rBreite & sLengthUnit & Chr(13) & Chr(10) & "Stärke: " & rStärke & sLengthUnit
   
    Dim bLängeDa As Boolean
    Dim oProper As Property
    bLängeDa = False
    For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProper.Name = "Länge" Then
            bLängeDa = True
            Exit For
        End If
    Next
    'Länge eintragen oder ändern
    If bLängeDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Länge").Value = rLänge
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rLänge, "Länge"
    End If
   
        'Breite vorhanden?
    Dim bBreiteDa As Boolean
    bBreiteDa = False
    For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProper.Name = "Breite" Then
            bBreiteDa = True
            Exit For
        End If
    Next
    'Breite eintragen oder ändern
    If bBreiteDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Breite").Value = rBreite
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rBreite, "Breite"
    End If
   
    'Stärke vorhanden?
    Dim bStärkeDa As Boolean
    bStärkeDa = False
    For Each oProper In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProper.Name = "Stärke" Then
            bStärkeDa = True
            Exit For
        End If
    Next
    'Höhe eintragen oder ändern
    If bStärkeDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Stärke").Value = rStärke
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add rStärke, "Stärke"
    End If
   
    'Da die ClientGraphic nur temporär sein soll, wird sie nach Bestätigen
    'der Meldung wieder gelöscht.
    If oDoc.SelectSet.Count = 0 Then
   
    ' Delete any graphics, if they exist.
    On Error Resume Next
    Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
    If Err.Number = 0 Then
        On Error GoTo 0
        Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
        oExistingGraphics.Delete
        oExistingGraphicsData.Delete
        ThisApplication.ActiveView.Update
    End If

    Exit Sub
    End If
   
End Sub
Public Sub Comments()

  Dim oDoc As PartDocument
  Set oDoc = ThisApplication.ActiveDocument
   
  Dim oPropSets As PropertySets
  Set oPropSets = oDoc.PropertySets
 
  Dim oPropSet As PropertySet
 
  For Each oPropSet In oPropSets
       
    For i = 1 To oPropSet.Count
     
      If oPropSet(i).Name = "Comments" Then
        On Error Resume Next
        Debug.Print oPropSet(i).Name & "    " & oPropSet(i).Value
        oPropSet(i).Value = "=<Stärke>x<Breite>x<Länge>"
      End If
     
      If oPropSet(i).Name = "Creation Time" Then
        On Error Resume Next
        Debug.Print oPropSet(i).Name & "    " & oPropSet(i).Value
        oPropSet(i).Value = Now
      End If
     
    Next i
 
  Next oPropSet
   
End Sub

---

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Und wo ist der Block zur Unterscheidung ob rund oder eckig? Ich konnte ihn nicht finden und darum gings doch eigentlich?

Nebenbei als Hinweis, allgemein verwendet man keine Umlaute für Parameter, da dies zu Problemen führen kann.

Also statt Stärke -> Staerke

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ja der fehlt mir, weswegen ich hier auch nachfrage, wie ich das lösen kann.

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Bedingung (Flachstahl):

6 Flächen, alle eben

Bedingung Zylinder

3 Flächen, 2 eben, 1 zylindrisch.

Anzahl der Flächen

SurfaceBodies.Count

Der Code wie du die Flächen ausliest steht ja oben

Grüße

EIBe 3D

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Bekomme ich nicht hin, stehe mir wahrscheinlich selbst im Weg.
Hier mein versuch der nicht klappt:

Code:

---

Public Sub Werte()
Dim oApp As Application
Set oApp = ThisApplication

Dim oPrtDoc As PartDocument
Set oPrtDoc = oApp.ActiveDocument

Dim oSrfceBds As SurfaceBodies
Set oSrfceBds = oPrtDoc.ComponentDefinition.SurfaceBodies

Dim oSrfceBody As SurfaceBody

Dim oFaces As Faces

Dim oFace As Face

If oSrfceBds.Count = 6 Then
    Call Parameter
    Call Flach_2
    Call CommentFlach
If oSrfceBds.Count = 3 Then
    Call Parameter
    Call Rund_2
    Call CommentRund
End If
End If
End Sub

---

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

So sollte es gehen

Code:

---

Public Sub KoerperForm_Bestimmen()

Dim oApp As Application
Set oApp = ThisApplication

Dim oPrtDoc As PartDocument
Set oPrtDoc = oApp.ActiveDocument

Dim oSrfceBds As SurfaceBodies
Set oSrfceBds = oPrtDoc.ComponentDefinition.SurfaceBodies

Dim oSrfceBody As SurfaceBody
Set oSrfceBody = oSrfceBds.Item(1)

Dim oFaces As Faces
Set oFaces = oSrfceBody.Faces

Dim oFace As Face

If oFaces.Count = 6 Then
    Debug.Print "Eckig" 'dein Code hier
ElseIf oFaces.Count = 3 Then
    For Each oFace In oFaces
        If oFace.SurfaceType = kCylinderSurface Then
            Debug.Print "Zylinder" 'dein Code hier
        End If
    Next
End If

End Sub

---

Grüße

EIBe 3D

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Das klappt und wie du oben schon erwähnt hast bei einfachen Geometrien. Ein Rohr bekommt man auch übergeben wenn man den Count von 3 auf 4 (oder 3 Or 4) setzt. Wenn ich allerdings eine runde Scheibe mit 3 Durchgangsbohrungen habe, geht das nicht. Ich habe dann 6 Flächen und bekomme ein Flach übergeben. Gibt es noch eine Möglichkeit, eine Bedingung ohne Count zu formulieren? Ist es vielleicht möglich über ein festgelegten Modellparameter "dum" (steht für durchmesser) für runde Körper die Bedingung zu formulieren? Ich würde mir dann eine entsprechende Modell.ipt (Rund.ipt) gestalten.

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Guten Morgen,
ich habe eine Lösung für mich gefunden. Wie schon im vorigen Post angedeutet habe ich für zylindrische Bauteile in den Modellparametern den Wert "d0" für Durchmesser im Kommentar mit "Durchmesser" beschrieben und weise in dem Code darauf hin.

Code:

---

Public Sub Werteholen()
Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument
Dim oParams As Inventor.Parameters
Set oParams = oDoc.ComponentDefinition.Parameters
Dim oparam As Parameter
For Each oparam In oParams.ModelParameters
  oparam.ExposedAsProperty = False
Next
Dim Durchmesser As Parameter
Set Durchmesser = ThisApplication.ActiveDocument.ComponentDefinition.Parameters("d0")
If Durchmesser.Comment = "Durchmesser" Then
    MsgBox ("Durchmesser")
Else
    MsgBox ("Flach")
End If

End Sub

---

nochmal herzlichen Dank für eure Unterstützung, besonders an EIBe 3D

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Didikalle,

gut wenn du für dich einen Weg gefunden hast.

Unten noch mal ein wenig erweiterter Code, welcher sicher Eckig oder Zylinder erkennt auch ohne "Durchmesser" - Kommentar. Allerdings wird es damit schon schwierig ein Rohr zu erkennen. Auch ist eckig relativ, es muss sich nicht zwingend um einen Quader handeln.

Code:

---

Public Sub KoerperForm_Bestimmen()

Dim oApp As Application
Set oApp = ThisApplication

Dim oPrtDoc As PartDocument
Set oPrtDoc = oApp.ActiveDocument

Dim oSrfceBds As SurfaceBodies
Set oSrfceBds = oPrtDoc.ComponentDefinition.SurfaceBodies

Dim oSrfceBody As SurfaceBody
Set oSrfceBody = oSrfceBds.Item(1)

Dim oFaces As Faces
Set oFaces = oSrfceBody.Faces

Dim oFace As Face

If oFaces.Count = 6 Then
   
    Dim iFlatFacesCnt As Integer
    For Each oFace In oFaces
        If oFace.SurfaceType = kPlaneSurface Then
            iFlatFacesCnt = iFlatFacesCnt + 1
        End If
    Next
    If iFlatFacesCnt = oFaces.Count Then
        Debug.Print "Eckig" 'Dein Code Hier
    End If
       

ElseIf oFaces.Count = 3 Or oFaces.Count = 4 Then
   
    Dim iZylFacesCnt As Integer

    For Each oFace In oFaces
        If oFace.SurfaceType = kCylinderSurface Then
            iZylFacesCnt = iZylFacesCnt + 1
        End If
    Next
   
    If iZylFacesCnt = 1 Then
        Debug.Print "Zylinder" 'Dein Code Hier
    ElseIf iZylFacesCnt = 2 Then
        Debug.Print "Rohr oder irgendetwas Ähnliches" 'Dein Code Hier !! Gibt auch bei Zylinder mit Querbohrung Rohr aus, oder wenn Mittenbohrung exzentrisch sitzt
    End If

End If

End Sub

---

Grüße

EIBe 3D

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo EIBe 3D,
Danke für den Code. Der Faces.Count schränkt einen doch sehr ein. Besonders bei zylindrischen Körpern. Auch wenn die Grundfläche bei eckigen Körpern ein Dreieck ist habe ich nur 5 Flächen.
Ich habe mir folgenden Code zusammengestellt:

Code:

---

Public Sub DurchmesserSetzen()
    On Error Resume Next
Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument
Dim antw As Integer
    antw = MsgBox("ist das ein zylindrischer Körper?", vbYesNo)
    If antw = vbNo Then
    Exit Sub
    End If
Dim oParams As Inventor.Parameters
Set oParams = oDoc.ComponentDefinition.Parameters
Dim oparam As Parameter
    For Each oparam In oParams.ModelParameters
    oparam.ExposedAsProperty = False
Next
Dim iNumParams As Long
    Debug.Print "ALL PARAMETERS"
    For iNumParams = 1 To oParams.Count
        Debug.Print " Name: " & oParams.Item(iNumParams).Name
        Select Case oParams.Item(iNumParams).Type
            Case kModelParameterObject
                Debug.Print "  Type: " & "Model Parameter"
            Case kTableParameterObject
                Debug.Print "  Type: " & "Table Parameter"
            Case kUserParameterObject
                Debug.Print "  Type: " & "User Parameter"
        End Select
        Debug.Print "  Value: " & oParams.Item(iNumParams).Value
    Next iNumParams
    Dim oModelParams As ModelParameters
    Set oModelParams = oParams.ModelParameters
    Dim iNumModelParams As Long
    Debug.Print "MODEL PARAMETER VALUES"
    For iNumModelParams = 1 To oModelParams.Count
        Debug.Print " Name:" & oModelParams.Item(iNumModelParams).Name
        Debug.Print "  Value: " & oModelParams.Item(iNumModelParams).Value
        Debug.Print "  Units: " & oModelParams.Item(iNumModelParams).Units
    Next iNumModelParams
    oModelParams.Item("Durchmesser").Name = "d0"
Dim oDurchm As Parameter
Set oDurchm = ThisApplication.ActiveDocument.ComponentDefinition.Parameters("d0")
  If Not oDurchm.Name = ("d0") Then
            MsgBox ("Bezeichnung Durchmesser nicht vorhanden, manuell ändern!")
    GoTo AbbruchMarker
    Else
        GoTo DurchmesserSetzen
    End If
DurchmesserSetzen:
Dim Durchmesser As Parameter
Set Durchmesser = ThisApplication.ActiveDocument.ComponentDefinition.Parameters("d0")
    If Durchmesser.Comment = "" Then
    Durchmesser.Comment = "Durchmesser"
        MsgBox ("Durchmesser gesetzt")
Else
    MsgBox ("ist schon vorhanden")
End If
AbbruchMarker:
End Sub

---

Grund dieser Möglichkeiten ist, dass ich für einen Kunden Stücklisten mit max. Zuschnittmaße aus den Bauteilen generieren muss. Diese Bauteile haben öfter auch Ausbrüche oder Bohrungen.
Gruß

------------------
Didi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Zitat:

---

Original erstellt von Didikalle:
...
Der Faces.Count schränkt einen doch sehr ein. Besonders bei zylindrischen Körpern. Auch wenn die Grundfläche bei eckigen Körpern ein Dreieck ist habe ich nur 5 Flächen.

...

---

Wie erwähnt ist es nicht trivial eine große Bandbreite an geometrischen Körpern anhand von Programmroutinen zu erkennen. Hat man natürlich Marker, wie z.B. Durchmesser, Innendurchmesser wie du in deinem Fall macht es Sinn diese zu verwenden. Auch wenn ich die Parameter direkt benennen würde statt das Kommentarfeld zu nutzen.

Grüße

EIBe 3D

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP