Summe Flächeninhalte bestimmter Flächen eines Bauteiles auslesen und in ein iProperty schreiben (VBA) (Toolbox)

Hier ein kleines VBA-Programm, das bei einer IPT Flächeninhalte bestimmter Flächen ausliest und summiert in ein iProperty schreibt. Flächen, die berücksichtigt werden sollen, manuell einfärben.

Wird das Programm ausgeführt, wird durch alle Flächen des ersten Volumenkörper gegangen und – sollte die Flächenfarbe überschrieben worden sein – der Flächeninhalt addiert und am Ende eine Meldung ausgegeben und der Flächeninhalt in ein iProperty geschrieben.

Zum Aktualisieren des Wertes im iProperty den Makro nochmals ausführen

Public Sub Flaecheninhalt_iProp()
    
    If ThisApplication.ActiveDocument.DocumentType <> kPartDocumentObject Then
        MsgBox ("Bitte Bauteil öffnen!")
        Exit Sub
    End If
    
    Dim oDoc As PartDocument
    Set oDoc = ThisApplication.ActiveDocument
    
    Dim Koerper As SurfaceBody
    Dim Flaeche As Face
    Dim Anzahl_Flaechen As Integer
    Dim Flaecheninhalt As Double
    
    Flaecheninhalt = 0
    Anzahl_Flaechen = 0
    
    Set Koerper = oDoc.ComponentDefinition.SurfaceBodies.Item(1)
    
    For Each Flaeche In Koerper.Faces
        If Flaeche.AppearanceSourceType = kOverrideAppearance Then
            Flaecheninhalt = Flaecheninhalt + Flaeche.Evaluator.Area
            Anzahl_Flaechen = Anzahl_Flaechen + 1
        End If
    Next
    '*100 da wird sonst cm^2 bekommen und keine mm^2!
    MsgBox "Flaecheninhalt: " & Round(Flaecheninhalt * 100, 2) & vbCr & "Anzahl gefundene Flächen: " & Anzahl_Flaechen
    Call UpdateCustomiProperty(oDoc, "Flächeninhalt", Round(Flaecheninhalt * 100, 2) & " mm^2")
End Sub

Public Sub UpdateCustomiProperty(ByRef doc As Document, _
ByRef PropertyName As String, _
ByRef PropertyValue As Variant)
    ' Get the custom property set.
    Dim customPropSet As PropertySet
    Set customPropSet = doc.PropertySets.Item( _
   "Inventor User Defined Properties")

    ' Get the existing property, if it exists.
    Dim prop As Property
    On Error Resume Next
    Set prop = customPropSet.Item(PropertyName)

    ' Check to see if the above call failed.  If it failed
    ' then the property doesn't exist.
    If Err.Number <> 0 Then
    ' Failed to get the existing property so create a new one.
    Set prop = customPropSet.Add(PropertyValue, PropertyName)
    Else
    ' Change the value of the existing property.
    prop.Value = PropertyValue
    End If
End Sub

Links

• VBA-Programm in die Benutzeroberfläche einbinden
• Programmieranleitungen

Die Funktion ist auch Teil der Inventor Toolbox

Allgemeine Infos zur Inventor Toolbox gibt’s hier | Alle Beiträge zu den Toolbox-Funktionen