Ik heb een macro waarmee je geselecteerde componenten van een assembly naar een map kunt verplaatsen.
'**********************
'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
De naam van de map is "Map x"
Ik zou het graag willen veranderen zodat de naam van de map "VISSERIE" is
Het probleem is dat ik niet weet hoe ik VBA moet lezen (noch welke andere taal dan ook).
- In het api-voorbeeld worden alleen de componenten " valve<1> en valve_guide<1> " in een "nieuwe map" geplaatst.
- In de macro die ik heb hersteld, wordt de actie uitgevoerd op de geselecteerde componenten (uiteindelijk ben ik van plan een selectiefilter te gebruiken volgens een aangepaste eigenschap)
Ik zou een hersenschim moeten maken, maar ik weet niet echt waar ik het beest moet snijden.
Is er in de API een functiewoordenboek dat ik zou kunnen raadplegen om beter te begrijpen hoe de macro's die ik hier en daar krijg, werken?
Dit zou me in staat stellen om de term te vinden die de naam van de map beheert in de macro die ik heb opgehaald.
Begin met vba excel, het is gemakkelijker om de taal te begrijpen (https://www.excel-pratique.com/fr/vba.php), dan heb je op de codestack-site waar je de 1e code hebt genomen een veelvoud aan tutorials (https://www.codestack.net/solidworks-api/document/)
De persoon die de macro heeft geschreven die je hebt gekregen, is van mening dat het commando om een map te maken niet bestaat in de Solidworks API's en ging daarom via de Windows API's om een commando naar Solidworks te sturen en zoals hij op zijn uitlegpagina zet die je HIER kunt vinden , "De uitdaging is hoe je de id van het vereiste commando kunt ontdekken ". In de Solidworks API is de functie "InsertFeatureTreeFolder2".
In het voorbeeld van de API moet je vasthouden aan je assembly die in Solidworks is geopend en vervolgens een lus maken om de geselecteerde elementen op te halen. Alle functies die nodig zijn om de Solidworks API te gebruiken, zijn van ICI.
De macro, in een korte versie (zonder verificatie en foutafhandeling) en door de Solidworks API's, zou er als volgt uit moeten kunnen zien:
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
Ik heb net iets getest op een assemblage met subassemblages, en het heeft een vastgelopen gebied. Ik moet alleen op het eerste niveau een selectie kunnen maken. Ik denk niet dat ik vandaag tijd heb om erin te duiken.
Uiteindelijk, als ik mijn zin krijg, krijg ik een krachtigere macro dan de TreeManager van MycadTool, die me niet in staat stelt om verschillende sorteeracties uit te voeren of deze acties op te slaan.