#If VBA7 Then 'SolidWorks 2015 and later (x64 VBA engine)
    Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#Else 'SolidWorks older than 2015 (x32 VBA engine)
    Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If
 
Const WM_COMMAND As Long = 273
Const OPEN_IN_POSITION_CMD As Long = 52056
 
Dim swApp As SldWorks.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
                
Sub main()
 
    On Error Resume Next
    
    Set swApp = Application.SldWorks
    
    Set swAssy = swApp.ActiveDoc
    
    If Not swAssy Is Nothing Then
       
        Dim i As Integer
        Dim swComp As SldWorks.Component2

        Set swSelMgr = swAssy.SelectionManager
        
        Dim swComps As Collection
        Set swComps = New Collection
                
        For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
                    
            Set swComp = swSelMgr.GetSelectedObjectsComponent3(i, -1)
            
            If Not swComp Is Nothing Then
                
                If Not HasComponent(swComps, swComp) Then
                    swComps.Add swComp
                End If
            End If
        
        Next
        
        If swComps.Count() > 0 Then
            
            For i = 1 To swComps.Count
                
                swApp.ActivateDoc3 swAssy.GetTitle, False, 0, 0
                
                Set swComp = swComps.Item(i)
                
                Dim swFrame As SldWorks.Frame
            
                Set swFrame = swApp.Frame
               
                If swComp.Select4(False, Nothing, False) Then
                    SendMessage swFrame.GetHWnd(), WM_COMMAND, OPEN_IN_POSITION_CMD, 0
                End If
                
            Next
            
        Else
            
            MsgBox "Please select the component"
            
        End If
        
    Else
        MsgBox "Please open assembly"
    End If
    
End Sub

Function HasComponent(swComps As Collection, swComp As Component2) As Boolean
    
    Dim i As Integer
    
    For i = 1 To swComps.Count()
        
        If UCase(swComps.Item(i).GetPathName) = UCase(swComp.GetPathName()) Then
            HasComponent = True
            Exit Function
        End If
        
    Next
    
    HasComponent = False
    
End Function