Option Explicit
Const swDocDRAWING = 3


Sub main()
    Dim swApp                   As Object
    Dim swModel                 As SldWorks.ModelDoc2
    Dim swDraw                  As SldWorks.DrawingDoc
    Dim swSheet                 As Object
    Dim swView                  As Object
    Dim swTable, myswTable      As Object
    Dim swFeat                  As SldWorks.Feature
    Dim swFeatureName           As String
    Dim swFeatureTypeName       As String
    Dim swBomFeat               As Object
    Dim bRet, swBomFound        As Boolean
    Dim swBomOnThisSheet        As Boolean
    Dim sheetfound              As Boolean
    Dim swAnn                   As Object
    Dim i, j                    As Long
    Dim swNumberOfSheets        As Long
    Dim swTableName, swViewName As String
    Dim swMessage, tempText     As String
    Dim swActiveSheet           As String
    Dim swSheetNames            As Variant
        
    
' Vorbereitung
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

' Haben wir überhaupt etwas zu tun?

    If swModel Is Nothing Then
        MsgBox "Kein Dokument geöffnet."
        End
    End If
    If swModel.GetType <> swDocDRAWING Then
        MsgBox "Das Dokument ist keine Zeichnung."
        End
    End If
    
' Ok - wir müssen uns kümmern

    Set swDraw = swModel
    swNumberOfSheets = swDraw.GetSheetCount()
    swSheetNames = swDraw.GetSheetNames
    swActiveSheet = swDraw.GetCurrentSheet.GetName
    
' Stückliste suchen ...
    swBomFound = False
    swMessage = ""

    For i = 1 To swNumberOfSheets
    
        If swNumberOfSheets > 1 Then
            swDraw.ActivateSheet (swSheetNames(i - 1))
        End If
        ' sonst durchschalten unnötig
        Set swView = swDraw.GetFirstView  ' Zeigt auf das Blatt
    
        swViewName = swView.GetName2()  ' nur mal aus Interesse
        Set swTable = swView.GetFirstTableAnnotation
        swBomOnThisSheet = False
        
        If swTable Is Nothing Then
            swMessage = "Blatt " & i & " enthält keine Stückliste" & Chr(13)
        Else
            Do
                Select Case swTable.Type
                Case 4
                    swMessage = swMessage & "Blatt " & i & " enthält Zuschnittsliste" & Chr(13)
                Case 2
                    swBomOnThisSheet = True
                    Set myswTable = swTable
                    swTableName = myswTable.BomFeature.GetFeature.Name
                    swMessage = swMessage & "Blatt " & i & " enthält Stückliste " & swTableName & Chr(13)
                End Select
            
                Set swTable = swTable.GetNext
            Loop Until swTable Is Nothing
            If swBomOnThisSheet Then
                swBomFound = True
            Else
                swMessage = swMessage & "Blatt " & i & " enthält keine Baugruppenstückliste" & Chr(13)
            End If
        End If
    Next i
    If swNumberOfSheets > 1 Then
        swDraw.ActivateSheet (swActiveSheet)
    End If

    
    If swBomFound Then
        ' Muss wohl eine haben ;)
        ' Mal fragen, wie sie heisst ...
    
        swTableName = myswTable.BomFeature.GetFeature.Name
        
        ' und ob ich etwas damit tun soll
        swMessage = swMessage & "Stückliste gefunden: " & swTableName & Chr(13) & Chr(13)
        swMessage = swMessage & "Jetzt alle Ansichten auf allen Blättern versuchen an diese Stückliste zu hängen?"
        If (MsgBox(swMessage, 4) = 6) Then
            swMessage = ""
            j = 0
        
            'Also wieder über alle Blätter laufen
            For i = 1 To swNumberOfSheets
    
                If swNumberOfSheets > 1 Then
                    swDraw.ActivateSheet (swSheetNames(i - 1))
                End If
                ' sonst durchschalten unnötig
            
                ' Dann mal alle Ansichten durchgehen
    
                Set swView = swDraw.GetFirstView

                Do While Not swView Is Nothing
                    If (swView.SetKeepLinkedToBOM(True, swTableName)) Then
                    j = j + 1
                    End If
                    Set swView = swView.GetNextView
                Loop
            Next i
            swMessage = swMessage & Chr(13) & j & " Ansichten an Stückliste gehängt: " & swTableName & Chr(13)
        Else
            swMessage = "wusste nichts zu tun ...."
        End If
    
        If swNumberOfSheets > 1 Then
            swDraw.ActivateSheet (swActiveSheet)
        End If
    
    End If
    
    MsgBox swMessage
    ' Und alles in Wohlgefallen auflösen ...
    

    Set swApp = Nothing
    Set swModel = Nothing
    Set swDraw = Nothing
    Set swView = Nothing
    Set swTable = Nothing
    
End Sub