Attribute VB_Name = "Modul1"
Public Sub DisplayNameAufbereiten()
    ' Display Name lesbarer machen
    
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject And _
        ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
        'MsgBox "Only Part or Assymbly document", vbCritical
        Exit Sub
    End If
    
  ' Declare the Application object
    Dim oApplication As Inventor.Application

    ' Obtain the Inventor Application object.
    ' This assumes Inventor is already running.
    Set oApplication = GetObject(, "Inventor.Application")

    ' Set a reference to the active document.
    ' This assumes a document is open.
    Dim odoc As Document
    Set odoc = oApplication.ActiveDocument
    
    Dim sPartNumber As String
    Dim sDespription As String
    Dim sTrennzeichen As String
    
    sPartNumber = Property_lesen(odoc, "Part Number")
    sDespription = Property_lesen(odoc, "Description")
    
    If Len(sPartNumber) = 0 Or Len(sDespription) = 0 Then
        sTrennzeichen = ""
    Else
        sTrennzeichen = " - "
    End If
    
    'für dieses Document
    odoc.DisplayName = sPartNumber & sTrennzeichen & sDespription
    
    'für SubDocument
    Call DisplayNameSubDoc(odoc)
    
    Set oApplication = Nothing
    Set odoc = Nothing
    Set oSubDoc = Nothing
    Set oSubSubDoc = Nothing

MsgBox "fertig"
End Sub

Public Sub DisplayNameSubDoc(odoc As Document)
        
    Dim oSubDoc As Document
    Dim oSubSubDoc As Document
        
        'erste Unterebene
        For X = 1 To odoc.ReferencedFiles.Count
            Set oSubDoc = odoc.ReferencedFiles.Item(X)
                
                'wenn SubDoc eine BG ist
                If oSubDoc.DocumentType = kAssemblyDocumentObject Then
                    
                    'zweite Ebene
                    For Y = 1 To oSubDoc.ReferencedFiles.Count
                        Set oSubSubDoc = oSubDoc.ReferencedFiles.Item(Y)
                
                        sPartNumber = Property_lesen(oSubSubDoc, "Part Number")
                        sDespription = Property_lesen(oSubSubDoc, "Description")
        
                        If Len(sPartNumber) = 0 Or Len(sDespription) = 0 Then
                            sTrennzeichen = ""
                        Else
                            sTrennzeichen = " - "
                        End If
    
                        oSubSubDoc.DisplayName = sPartNumber & sTrennzeichen & sDespription
                    Next
                End If

            sPartNumber = Property_lesen(oSubDoc, "Part Number")
            sDespription = Property_lesen(oSubDoc, "Description")
        
            If Len(sPartNumber) = 0 Or Len(sDespription) = 0 Then
                sTrennzeichen = ""
            Else
                sTrennzeichen = " - "
            End If
    
            oSubDoc.DisplayName = sPartNumber & sTrennzeichen & sDespription
    
        Next
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 Is = "reso"
            Property_lesen = True
        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