Code:
Public Sub UpdateCustomiProperty(ByRef doc As Document, _
ByRef PropertyName As String, _
ByRef PropertyValue As Variant)
'Quelle: https://ww3.cad.de/foren/ubb/Forum50/HTML/034195.shtml ' 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
'Aufräumen (ergänzt)
On Error GoTo 0
Set customPropSet = Nothing
Set prop = Nothing
End Sub
Public Function ReadCustomiProperty(ByRef doc As Document, _
ByRef PropertyName As String) As Variant
'Wert aus iProp lesen
'Default-Rückgabewert (wenn Prop nicht existiert)
ReadCustomiProperty = Null
' 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
MsgBox "iProperty existiert nicht!" & vbCrLf _
& PropertyName, vbCritical, "Fkt. ReadCustomiProperty"
Else
'Prop existiert, Wert lesen
ReadCustomiProperty = prop.Value
End If
'Aufräumen (ergänzt)
On Error GoTo 0
Set customPropSet = Nothing
Set prop = Nothing
End Function