Macro solidworks (Vba) Onderdeelselectie uit een assemblage

Out of category
1

Hallo

Ik heb een macro die vanuit een assemblage het geselecteerde onderdeel opent en er vervolgens een bepaalde bewerking op toepast.

Deze macro werkt heel goed als ik in de assemblage een vlak van het te bewerken onderdeel selecteer.

Aan de andere kant zou ik de mogelijkheid willen toevoegen om deze verwerking toe te passen door het deel ook uit de Feature manager te selecteren (zonder de huidige mogelijkheid van een gezicht in de 3D te verwijderen)

Heeft iemand een concreet voorbeeld of idee van de te gebruiken functie?

 

Hieronder vindt u de huidige code (opgeschoond):

Sub main()

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

                Dim swSelMgr As SldWorks.SelectionMgr
                Dim swCompEnt As SldWorks.Entity
                Dim swPartFeat As SldWorks.Feature
                Dim swCompModel As SldWorks.ModelDoc2
                Dim swPartEnt As SldWorks.Entity
                Dim swConfigMgr As SldWorks.ConfigurationManager
                Dim swModelDocExt As SldWorks.ModelDocExtension
                Dim nRetval As Long
                Set swSelMgr = swModel.SelectionManager
                Dim CurSelCount As Long
                CurSelCount = swSelMgr.GetSelectedObjectCount
                Set swCompEnt = swSelMgr.GetSelectedObject6(1, 0)
                Set swComp = swSelMgr.GetSelectedObjectsComponent3(1, 0)
                Set swCompModel = swComp.GetModelDoc
                Set swConfigMgr = swCompModel.ConfigurationManager
                Set swCompModelConfig = swConfigMgr.ActiveConfiguration
                Set swModelDocExt = swCompModel.Extension
                Set swPartEnt = swModelDocExt.GetCorrespondingEntity(swCompEnt)
                Set swCompModel = swApp.ActivateDoc2(swCompModel.GetPathName, True, nRetval): Debug.Assert 0 = nRetval
                Dim swConfig As SldWorks.Configuration
                Set swModel = swApp.ActiveDoc
                swModel.ShowConfiguration2 (swComp.ReferencedConfiguration)
                Debug.Print "File = " + swModel.GetPathName
                Debug.Print "  Component       = " + swComp.Name2 + " <" + swComp.ReferencedConfiguration + ">" + " [" + swComp.GetPathName + "]"
                Debug.Print "  Model           = " + swCompModel.GetPathName + " <" + swCompModelConfig.Name + ">"
End Sub

 

2

Hallo

Zoiets als het volgende misschien:

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim Model As ModelDoc2
Dim CompModel As ModelDoc2
Dim swChildComp As SldWorks.Component2
Dim SelectedObject As Object
Dim NbrSelections As Long
Dim i As Long

Sub main()

    Set swApp = Application.SldWorks
    Set Model = swApp.ActiveDoc

    Dim SelMgr As SelectionMgr
    Set SelMgr = Model.SelectionManager
        
    NbrSelections = SelMgr.GetSelectedObjectCount2(-1)
        
    For i = 1 To NbrSelections
        Set SelectedObject = SelMgr.GetSelectedObject6(i, -1)
        Debug.Print "Type object : " & SelMgr.GetSelectedObjectType3(i, -1)
        If SelMgr.GetSelectedObjectType3(i, -1) = 20 Then
            Set swChildComp = SelectedObject
            Set CompModel = swChildComp.GetModelDoc2
            
            Debug.Print "1 - Nom : " & swChildComp.Name
            Debug.Print "1 - Chemin : " & CompModel.GetPathName
            Debug.Print "1 - Titre : " & CompModel.GetTitle
        ElseIf SelMgr.GetSelectedObjectType3(i, -1) = 2 Then
            Set swChildComp = SelMgr.GetSelectedObjectsComponent3(1, 0)
            Set CompModel = swChildComp.GetModelDoc2
            
            Debug.Print "2 - Nom : " & swChildComp.Name
            Debug.Print "2 - Chemin : " & CompModel.GetPathName
            Debug.Print "2 - Titre : " & CompModel.GetTitle
        End If
    Next i
    
End Sub

Vriendelijke groeten

2 likes
3

Perfect functioneel antwoord @d.roger !

Ik ben net klaar met het aanpassen van mijn code met succes.

Bedankt.