I have a macro that allows you to move selected components from an assembly into a folder.
'**********************
'Copyright(C) 2019 www.codestack.net
'Reference: https://www.codestack.net/solidworks-api/document/assembly/components/move-to-folder/
'License: https://www.codestack.net/LICENSE.md
'**********************
#If VBA7 Then
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
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
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
SelectComponentsFromCurrentSelection swModel
AddSelectedComponentsToNewFolder ""
Else
MsgBox "Please open assembly"
End If
End Sub
Sub SelectComponentsFromCurrentSelection(model As SldWorks.ModelDoc2)
Dim swComps() As SldWorks.Component2
Dim isArrInit As Boolean
isArrInit = False
Dim i As Integer
Dim swSelMgr As SldWorks.SelectionMgr
Set swSelMgr = model.SelectionManager
For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
Dim swComp As SldWorks.Component2
Set swComp = swSelMgr.GetSelectedObjectsComponent4(i, -1)
If Not swComp Is Nothing Then
Dim unique As Boolean
unique = False
If False = isArrInit Then
isArrInit = True
ReDim swComps(0)
unique = True
Else
unique = Not Contains(swComps, swComp)
If True = unique Then
ReDim Preserve swComps(UBound(swComps) + 1)
End If
End If
If True = unique Then
Set swComps(UBound(swComps)) = swComp
End If
End If
Next
If True = isArrInit Then
If UBound(swComps) + 1 <> model.Extension.MultiSelect2(swComps, False, Nothing) Then
Err.Raise vbError, , "Failed to select components"
End If
End If
End Sub
Function Contains(vArr As Variant, item As Object) As Boolean
Dim i As Integer
For i = 0 To UBound(vArr)
If vArr(i) Is item Then
Contains = True
Exit Function
End If
Next
Contains = False
End Function
Sub AddSelectedComponentsToNewFolder(dummy)
Const WM_COMMAND As Long = &H111
Const CMD_ADD_TO_NEW_FOLDER As Long = 37922
Dim swFrame As SldWorks.Frame
Set swFrame = swApp.Frame
SendMessage swFrame.GetHWnd(), WM_COMMAND, CMD_ADD_TO_NEW_FOLDER, 0
End Sub
The name of the folder is "Folder x"
I would like to change it so that the name of the folder is "VISSERIE"
The problem is that I don't know how to read VBA (nor any other language for that matter).
- In the api example, only the components " valve<1> and valve_guide<1> " are placed in a "new folder".
- In the macro I recovered, the action is done on the selected components (eventually, I intend to use a selection filter according to a custom property)
I would have to make a chimera but I don't really know where to cut the beast.
Is there in the API a function dictionary that I could refer to to better understand how the macros I get here and there work?
This would allow me to find the term that manages the name of the folder in the macro I retrieved.
Start with vba excel, it's easier to understand the language (https://www.excel-pratique.com/fr/vba.php), then on the codestack site where you took the 1st code you have a multitude of tutorials (https://www.codestack.net/solidworks-api/document/)
The person who wrote the macro you got considers that the command to create a folder does not exist in the Solidworks APIs and therefore went through the Windows APIs to send a command to Solidworks and as he puts in his explanation page that you can find HERE, "The challenge is how to discover the id of the required command ". In the Solidworks API, the function is "InsertFeatureTreeFolder2".
In the example from the API, you have to hang on to your assembly opened in Solidworks and then make a loop to retrieve the selected elements. All the functions necessary to use the Solidworks API are by ICI.
The macro, in a short version (without verification and error handling) and by the Solidworks APIs, should be able to look like this:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim modelDoc2 As SldWorks.modelDoc2
Dim assemblyDoc As SldWorks.assemblyDoc
Dim featureMgr As SldWorks.FeatureManager
Dim modelDocExt As SldWorks.ModelDocExtension
Dim selectionMgr As SldWorks.selectionMgr
Dim feature As SldWorks.feature
Dim selObj As Object
Dim count As Long
Dim componentToMove As SldWorks.Component2
Dim componentsToMove() As Object
Dim i As Long
Dim retVal As Boolean
Sub Main()
Set swApp = Application.SldWorks
Set modelDoc2 = swApp.ActiveDoc
Set assemblyDoc = modelDoc2
'Récupération des élements sélectionnés dans Solidworks
Set modelDocExt = modelDoc2.Extension
Set selectionMgr = modelDoc2.SelectionManager
Set selObj = selectionMgr.GetSelectedObject6(1, -1)
count = selectionMgr.GetSelectedObjectCount2(0)
ReDim componentsToMove(count - 1)
For i = 0 To count - 1
Set componentToMove = selectionMgr.GetSelectedObjectsComponent4(i + 1, -1)
Set componentsToMove(i) = componentToMove
Next
'Création d'un nouveau dossier
Set featureMgr = modelDoc2.FeatureManager
Set feature = featureMgr.InsertFeatureTreeFolder2(swFeatureTreeFolder_EmptyBefore)
Set feature = assemblyDoc.FeatureByName(feature.Name)
'Déplacement des élements sélectionnés dans le nouveau dossier
retVal = assemblyDoc.ReorderComponents(componentsToMove, feature, swReorderComponents_LastInFolder)
'Changement de nom du dossier
feature.Name = "Visserie"
End Sub
I just tested something on an assembly with sub-assemblies, and it has a stuck area. I have to be able to make a selection on the first level only. I don't think I have time to dive into it today.
In the end, if I get my way, it will give me a more powerful macro than MycadTool's TreeManager which doesn't allow me to do several sorting actions or save these actions.