Sub Property_schreiben(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



'=================================================================================================



Public Function Property_lesen(oDoc As Document, sPropName As String) As Variant
' Liest eine Property.
' Ist die Property nicht vorhanden, so wird "" zurückgegeben.

    Select Case Left$(sPropName, 4)
        Case Is = "Cost"
            Property_lesen = 0
        Case Else
            Property_lesen = ""
    End Select
    

    ' Obtain the PropertySets collection object
    Dim oPropSets As PropertySets
    Set oPropSets = oDoc.PropertySets
 
    Dim oProp As Property
    
    ' Iterate through all the PropertySets one by one using for loop
    Dim oPropSet As PropertySet
    For Each oPropSet In oPropSets
    
        For Each oProp In oPropSet
            'Debug.Print oProp.Name
            If oProp.Name = sPropName Then
                Property_lesen = oProp.Value
                Exit For
            End If
        Next
        
    Next

    Set oProp = Nothing
    Set oPropSet = Nothing
    Set oPropSets = Nothing

End Function