Sub RenumberBalloons()
' nummeriert die Positionsnummern-Ballons neu.
' Die Positionsnummern werden überschrieben mit der Pos.-Nr. aus der übergeordneten BG
'------------------------------------------------------------------------------
'
'(c) Boekels Ingenieurbüro für Maschinenbau (LBCAD)
'
'------------------------------------------------------------------------------



If ThisApplication.Documents.Count = 0 Then
    MsgBox "Keine Dokumente geöffnet."
    Exit Sub
End If

If ThisApplication.ActiveDocumentType <> kDrawingDocumentObject Then
    MsgBox "Das geöffnete Dokument ist keine IDW."
    Exit Sub
End If

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet
    
    Dim oPartList As PartsList
    Dim bFound As Boolean
    bFound = False
    
    Dim iSheet As Long
    iSheet = 0
    
    ' Partlist in der IDW finden
    For Each oSheet In oDrawDoc.Sheets
        iSheet = iSheet + 1
        If oSheet.PartsLists.Count = 0 Then
            bFound = False
        Else
            For Each oPartList In oSheet.PartsLists
                If oPartList.Title = "Stückliste" Then
                    bFound = True
                    Exit For
                End If
            Next oPartList
            If bFound Then Exit For
        End If
    Next oSheet

    If Not bFound Then
            MsgBox "Es wurde keine Stückliste mit Titel ""Stückliste"" gefunden!" & vbCrLf & _
                   "Makroausführung wird beendet."
            Debug.Print "Keine Stückliste mit Titel  ""Stückliste"" gefunden!"
            Exit Sub
    Else
            'Debug.Print "Stückliste vorhanden."
            Set oPartList = oSheet.PartsLists.Item(iSheet)
            Debug.Print oPartList.Title & " auf Blatt " & oSheet.name & " gefunden."
    End If
    
' Suchen der Spalte mit den Positionsnummern

    bFound = False
    Dim iPosSpalte As Long
    Dim oColumn As PartsListColumn
    
    
    For iPosSpalte = 1 To oPartList.PartsListColumns.Count
        Set oColumn = oPartList.PartsListColumns.Item(iPosSpalte)
        If oColumn.Title = "POS." Or _
           oColumn.Title = "Pos." Or _
           oColumn.Title = "ITEM" Or _
           oColumn.Title = "OBJEKT" Or _
           oColumn.Title = "OBJ" Then
            bFound = True
            Exit For
        End If
    Next iPosSpalte
    
    If bFound Then
        Debug.Print oColumn.Title & " gefunden in Spalte " & iPosSpalte
    Else
        Debug.Print "Konnte Spalte mit Postitonsnummern nicht identifizieren."
        MsgBox "Konnte Spalte mit Postitonsnummern nicht identifizieren." & vbCrLf & vbCrLf & _
               "Gesucht wurde nach folgenden Überschriften:" & vbCrLf & _
               "POS. Pos. ITEM OBJEKT OBJ"
        Exit Sub
    End If
    
    Dim oBalloon As Balloon
    Dim sBalloonValue As String
    
    Dim oRow As PartsListRow

    bFound = False
    
    Dim iBalloonNr As Integer
    
    Dim iNotBallooned As Integer
    iNotBallooned = 0
    
    Dim sFullFileName As String
    
    Dim iItem As Integer
    
    Dim sMsg As String
    sMsg = ""
    
    Dim sDisplayName As String
    sDisplayName = ""
        
    For Each oSheet In oDrawDoc.Sheets
    
        For Each oBalloon In oSheet.Balloons
      
            For iItem = 1 To oBalloon.BalloonValueSets.Count
            
                bFound = False
                sBalloonValue = oBalloon.BalloonValueSets.Item(iItem).Value
                
                sFullFileName = oBalloon.BalloonValueSets.Item(iItem).ReferencedFiles.Item(1).FullFileName
                'Debug.Print sFullFileName;
                'Debug.Print
                
                ' Durchsuchen der Stückliste nach einem Teil mit dem entsprechende Dateinamen.
                'for each
    
                For Each oRow In oPartList.PartsListRows
                    
                    If oRow.ReferencedFiles.Item(1).FullFileName = sFullFileName Then
                        bFound = True
                        iBalloonNr = oRow.Item(iPosSpalte).Value
                        Exit For
                    Else
                        'bFound = False
                    End If
                    
                    If oRow.Ballooned Then
                        
                    Else
                        
                        sDisplayName = oRow.ReferencedFiles.Item(1).DisplayName
                        
                        If InStr(1, sMsg, sDisplayName, vbTextCompare) = 0 Then
                            sMsg = sMsg & vbCrLf & sDisplayName
                            iNotBallooned = iNotBallooned + 1
                        End If
                    
                    End If
                    
                    iNotBallooned = iNotBallooned
                Next oRow
                
                bFound = True
                
                If bFound Then
                
                    sBalloonValue = CStr(bFound)
                    'oBalloon.BalloonValueSets.Item(iItem).OverrideValue = sBalloonValue
                    
                    If Not (iBalloonNr = CInt(oBalloon.BalloonValueSets.Item(iItem).Value)) Then
                        'nur ändern, falls die Werte nicht übereinstimmen
                        oBalloon.BalloonValueSets.Item(iItem).OverrideValue = CStr(iBalloonNr)
                    Else
                        oBalloon.BalloonValueSets.Item(iItem).OverrideValue = ""
                    End If
                    'oBalloon.BalloonValueSets.Item(iItem).OverrideValue = sFullFileName
                
                Else
                    
                    ' Balloon wurde nicht in der Hauptstückliste gefunden und wird gelöscht.
                    oBalloon.Delete
                
                End If
                
            Next iItem
            
        Next oBalloon
        
    Next oSheet
    

    MsgBox CStr(iNotBallooned) & " Teile wurden nicht mit einer Positionsnummer versehen." & vbCrLf & _
            sMsg
    
End Sub