Posiadam makro, które pozwala na przenoszenie wybranych komponentów ze złożenia do folderu.
'**********************
'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
Nazwa folderu to "Folder x"
Chciałbym to zmienić tak, aby nazwa folderu to "VISSERIE"
Problem polega na tym, że nie umiem czytać VBA (ani żadnego innego języka).
- W przykładzie z api tylko komponenty " valve<1> i valve_guide<1> " są umieszczone w "nowym folderze".
- W makrze, które odzyskałem, akcja jest wykonywana na wybranych komponentach (docelowo zamierzam użyć filtra wyboru zgodnie z niestandardową właściwością)
Musiałbym zrobić chimerę, ale tak naprawdę nie wiem, gdzie przeciąć bestię.
Czy w interfejsie API znajduje się słownik funkcji, do którego mógłbym się odwołać, aby lepiej zrozumieć, jak działają makra, które otrzymuję tu i tam?
Pozwoliłoby mi to znaleźć termin, który zarządza nazwą folderu w pobranym makrze.
Zacznij od vba excel, łatwiej jest zrozumieć język (https://www.excel-pratique.com/fr/vba.php), a następnie na stronie codestack, gdzie wziąłeś 1. kod, masz wiele samouczków (https://www.codestack.net/solidworks-api/document/)
Osoba, która napisała makro, które otrzymałeś, uważa, że polecenie utworzenia folderu nie istnieje w interfejsach API Solidworks i dlatego przeszła przez interfejsy API systemu Windows, aby wysłać polecenie do Solidworks i jak umieszcza na swojej stronie z wyjaśnieniem, którą można znaleźć TUTAJ, "Wyzwanie polega na tym, jak odkryć identyfikator wymaganego polecenia ". W API Solidworks funkcją jest "InsertFeatureTreeFolder2".
W przykładzie z API należy zawiesić się na złożeniu otwartym w Solidworks, a następnie utworzyć pętlę, aby pobrać wybrane elementy. Wszystkie funkcje niezbędne do korzystania z interfejsu API Solidworks są obsługiwane przez ICI.
Makro, w wersji skróconej (bez weryfikacji i obsługi błędów) oraz przez API Solidworks, powinno być w stanie wyglądać tak:
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
Właśnie przetestowałem coś na zespole z podzespołami i ma zablokowany obszar. Muszę być w stanie dokonać wyboru tylko na pierwszym poziomie. Chyba nie mam dziś czasu, żeby się w to zagłębić.
W końcu, jeśli postawię na swoim, da mi to potężniejsze makro niż TreeManager MycadTool, które nie pozwala mi wykonać kilku akcji sortowania ani zapisać tych akcji.