es geht auch so:
-----------------------------------------------------
Public Sub getBoundingBox()
Dim oDoc As partDocument
Set oDoc = ThisApplication.ActiveDocument
Dim oCD As SheetMetalComponentDefinition
Set oCD = oDoc.ComponentDefinition
Dim oFP As FlatPattern
Set oFP = oCD.FlatPattern
Dim dimX, dimY, dimZ As Double
Dim sdimXYZ As String
On Error Resume Next
dimX = Round((oFP.Body.RangeBox.MaxPoint.X - oFP.Body.RangeBox.MinPoint.X) * 10, 3)
If Err Then
MsgBox "Abwicklung fehlt!", 16, "Error"
End
End If
dimY = Round((oFP.Body.RangeBox.MaxPoint.Y - oFP.Body.RangeBox.MinPoint.Y) * 10, 3)
dimZ = Round((oFP.Body.RangeBox.MaxPoint.Z - oFP.Body.RangeBox.MinPoint.Z) * 10, 3)
'MsgBox ("X= " & CStr(dimX) & " mm" _
& Chr(10) & "Y= " & CStr(dimY) & " mm" _
& Chr(10) & "Z= " & CStr(dimZ) & " mm")
sdimXYZ = CStr(dimX) & " x " & CStr(dimY) & " x " & CStr(dimZ)
MsgBox ("Abwicklung :" & vbCrLf & vbCrLf & sdimXYZ & " mm x mm x mm")
Call IPropEintraege.Property_setzen(oDoc, "Groesse_Abwicklung", CStr(sdimXYZ))
Set oFP = Nothing
Set oCD = Nothing
Set oDoc = Nothing
End Sub
------------------------------------------------------------
Sub Property_setzen(oDoc As Document, sPropName As String, vPropValue As Variant)
' Belegt eine Property mit einem Wert.
' Ist die Property nicht vorhanden, so wird sie angelegt.
' Obtain the PropertySets collection object
Dim oPropSets As PropertySets
Set oPropSets = oDoc.PropertySets
Dim bPropertyDa As Boolean
Dim oProp As Property
bPropertyDa = False
' Iterate through all the PropertySets one by one using for loop
' and changing its value if found
Dim oPropSet As PropertySet
For Each oPropSet In oPropSets
For Each oProp In oPropSet
'Debug.Print oProp.Name
If oProp.Name = sPropName Then
oProp.Value = vPropValue
bPropertyDa = True
Exit For
End If
Next
Next
'Property anlegen und Wert eintragen
If Not bPropertyDa Then
'oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add vPropValue, sPropName
oDoc.PropertySets.Item("User Defined Properties").Add vPropValue, sPropName
End If
Set oProp = Nothing
Set oPropSet = Nothing
Set oPropSets = Nothing
End Sub
-------------------------------------------------------------------
------------------
Gruß Lothar
---------------------------------------------------
Während man es aufschiebt, verrinnt das Leben.
—Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP