Sub main()
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swSelMgr            As SldWorks.SelectionMgr
    Dim swSelObj            As Object
    Dim swSelComp           As SldWorks.Component2
    Dim swSelModel          As SldWorks.ModelDoc2
    Dim Note                As Object
    Dim componentName       As String
    Dim ActiveDoc           As Object
    ' Disables VB's implicit error on QI
    On Error Resume Next
    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    Set swSelMgr = swModel.SelectionManager
    ' Could either have a feature or entity selected
    ' Do not try to get entity directly
    ' from feature because feature may be NULL. Instead,
    ' use SelectionMgr.
    Set swEnt = swSelMgr.GetSelectedObject4(1)
    Set swSelComp = swSelMgr.GetSelectedObjectsComponent(1)
    
    ' Could not get component from SelectionMgr
    ' so try and get component through Entity
    If swSelComp Is Nothing Then
        Set swSelComp = swEnt.GetComponent
    End If

    If Not swSelComp Is Nothing Then
        Set swSelModel = swSelComp.GetModelDoc
        componentName = swSelComp.Name2
        If (InStr(componentName, "/") > 0) Then 'wenn es eine Unterbaugruppe ist
            componentName = Right(componentName, InStr(componentName, "/") - 1)
        End If
        'die Instanz '-xx' die von SWX hinzugefügt wird entfernen
        While (Not (Right(componentName, 1)) = "-")
                'bis zum '-' entfernen
                componentName = Left(componentName, VBA.Len(componentName) - 1)
        Wend
        'Jetzt noch das  '-' entfernen
        componentName = Left(componentName, VBA.Len(componentName) - 1)
    End If
    'Stücklistensymbol anlegen
    Set Note = swModel.InsertBOMBalloon2(10, 0, 0, componentName, 0, "")
    swModel.GraphicsRedraw2

End Sub