Option Explicit
' ce code nécessite que la référence "Microsoft Scripting Runtime" soit activée
Dim MonDico As New Scripting.Dictionary
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim featureMgr As SldWorks.FeatureManager
Dim feature As SldWorks.feature
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim bRet As Boolean
Dim Compteur As Long
Dim TestValeurDico As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent
TraverseComponent swRootComp, swRootComp.Name2, "catégorie", "visserie"
Compteur = 1
For Each TestValeurDico In MonDico.Keys
Classement swModel, MonDico(TestValeurDico), Compteur, "Visserie"
Compteur = Compteur + 1
Next TestValeurDico
Set MonDico = Nothing
Set swModel = swApp.ActiveDoc
Set swConf = swModel.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent
TraverseComponent swRootComp, swRootComp.Name2, "catégorie", "Fourniture industrielle"
Compteur = 1
For Each TestValeurDico In MonDico.Keys
Classement swModel, MonDico(TestValeurDico), Compteur, "FI"
Compteur = Compteur + 1
Next TestValeurDico
Set MonDico = Nothing
End Sub
Sub TraverseComponent(swComp As SldWorks.Component2, nomAsm As String, nomVar As String, resultVar As String)
Dim vChildCompArr As Variant
Dim vChildComp As Variant
Dim swChildComp As SldWorks.Component2
Dim swSelModel As SldWorks.ModelDoc2
Dim swCompConfig As SldWorks.Configuration
Dim Compteur As Long
Compteur = 1
vChildCompArr = swComp.GetChildren
For Each vChildComp In vChildCompArr
Set swChildComp = vChildComp
If Not swChildComp Is Nothing Then
Set swSelModel = swChildComp.GetModelDoc2
GetPropChildren swSelModel, nomAsm, swChildComp.Name2, nomVar, resultVar, Compteur
End If
Compteur = Compteur + 1
Next
End Sub
Sub GetPropChildren(swChild As SldWorks.ModelDoc2, nomAsm As String, nomPrt As String, nomVar As String, resultVar As String, Cle As Long)
Dim swModelDocExtension As SldWorks.ModelDocExtension
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim nbrProps As Long
Dim vpropsnames As Variant
Dim k As Long
Dim valeur As String
Dim val As String
Dim valout As String
Dim boolstatus As Boolean
Set swModelDocExtension = swChild.Extension
Set swCustPropMgr = swModelDocExtension.CustomPropertyManager("")
nbrProps = swCustPropMgr.count
vpropsnames = swCustPropMgr.GetNames
For k = 0 To nbrProps - 1
If vpropsnames(k) = nomVar Then
boolstatus = swCustPropMgr.Get4(nomVar, False, val, valout)
If valout = resultVar Then
valeur = nomPrt & "@" & nomAsm
If Not MonDico.Exists(Cle) Then
MonDico.Add Cle, valeur
End If
End If
End If
Next k
End Sub
Sub Classement(swModel As SldWorks.ModelDoc2, nomComposant As String, Nbr As Long, nomDossier As String)
Dim swAssy As SldWorks.AssemblyDoc
Dim featureMgr As SldWorks.FeatureManager
Dim feature As SldWorks.feature
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim bRet As Boolean
Dim modelDocExt As SldWorks.ModelDocExtension
Dim selectionMgr As SldWorks.selectionMgr
Dim selObj As Object
Dim status As Long
Dim count As Long
Dim i As Long
Dim componentToMove As SldWorks.Component2
Dim componentsToMove() As Object
Dim retVal As Boolean
swModel.ClearSelection2 True
Set modelDocExt = swModel.Extension
Set selectionMgr = swModel.SelectionManager
status = modelDocExt.SelectByID2(nomComposant, "COMPONENT", 0, 0, 0, True, 0, Nothing, 0)
Set selObj = selectionMgr.GetSelectedObject6(Nbr, -1)
count = selectionMgr.GetSelectedObjectCount2(0)
ReDim componentsToMove(count - 1)
For i = 0 To count - 1
Set componentToMove = selectionMgr.GetSelectedObjectsComponent4(i + 1, 0)
Set componentsToMove(i) = componentToMove
Next
Dim erreur As String
erreur = "Oui"
Set swAssy = swModel
Set featureMgr = swAssy.FeatureManager
Set feature = swModel.FirstFeature
Do While Not feature Is Nothing
If feature.Name = nomDossier Then
erreur = "Non"
End If
Set feature = feature.GetNextFeature
Loop
If erreur = "Oui" Then
Set feature = featureMgr.InsertFeatureTreeFolder2(swFeatureTreeFolder_EmptyBefore)
feature.Name = nomDossier
End If
Set feature = swAssy.FeatureByName(nomDossier)
retVal = swAssy.ReorderComponents(componentsToMove, feature, swReorderComponents_LastInFolder)
swModel.ClearSelection2 True
End Sub
To mi bardzo pomaga, nie byłem aż tak daleko, raczej bardzo daleko stamtąd...
Mam jeszcze problem z 1 szczególnym przypadkiem:
Części utworzone z rodziną części, w których Kategoria jest wypełniona w konfiguracji (np. lub inne) są ignorowane, musiałbym dodać warunek, jeśli właściwość "kategoria" jest pusta, a następnie spojrzeć na właściwość konfiguracji.
Na koniec muszę również dodać ulepszenie, aby usunąć folder i FI podczas uruchamiania makra, jeśli już istnieją. (w przypadku, gdy zrestartujemy makro po dodaniu nowych monet)
I na koniec chciałbym przenieść 2 foldery na sam dół menedżera funkcji, jeśli to możliwe (nie ma możliwości przeniesienia folderu).
Oto nowa wersja, która pozwala na usuwanie folderów podczas uruchamiania, jeśli istnieją, a także na wyszukiwanie wartości zmiennej we wszystkich konfiguracjach elementów 3D.
Nie próbowałem umieszczać folderów na końcu menedżera funkcji, zobaczymy później, czy będę miał czas.
Małe przypomnienie, to tylko przykład, więc zarządzanie błędami nie jest zakończone...
- jeśli część jest w stanie usuniętym (N°1-Image1) -> nie można znaleźć domyślnej konfiguracji -> błąd -> Muszę dowiedzieć się, jak ją zignorować, jeśli część jest w stanie usunięcia. (dla błędu 2 nie został usunięty)
- Przenoszenie folderu nie działa dobrze Folder studni znajduje się na samym dole, ale wszystkie elementy poniżej 1. do przeniesienia w folderze, są również w folderze.
Ponadto folderu nie można "rozszerzyć" strzałką, aby zobaczyć jego zawartość.
Natomiast bez przemieszczenia strzałka tam jest.
Myślę, że przenosi wszystkie elementy poniżej folderu, w tym inne foldery, które są tworzone jako następne.
Przykład przed makrem (zdjęcie 1)
W asemblerze nr 1 usunięto błąd 1
w N°2 ()
W nr 3 i 4 (FI)
W załączeniu, mój zestaw testowy, oraz makro z właściwościami z poprawną wielkością liter (błąd z mojej strony podczas 1 postu).
Oto nowa wersja, która pozwala uniknąć elementów, które są w stanie usuniętym, usunąłem linie, które przenoszą foldery, ponieważ rzeczywiście w niektórych przypadkach to błądzi (aby pomyśleć, jak to zrobić, ale na razie nie za dużo czasu).
Dzięki za najnowszą wersję, która skutecznie rozwiązuje problem z usuniętymi częściami.
Zamierzam zamknąć temat pomimo błędu przy przenoszeniu folderu, ale o który nie wnioskowano w podstawowym pytaniu.
Do przeniesienia folderu mam kilka pomysłów:
- Najpierw przenieś części, a nie folder, a następnie utwórz folder
- dowiedz się, skąd ten błąd (zadając pytanie na dedykowanym forum makr Solidworks)
Co do reszty, makro jest doskonale funkcjonalne i dziękuję @ d.roger za doskonale wykonaną pracę, zaoszczędziło mi to więcej niż cenny czas, a jednocześnie miało znacznie czystszy kod niż to, co zrobiłbym na moim poziomie początkującym.
Dzięki za najnowszą wersję, która skutecznie rozwiązuje problem z usuniętymi częściami.
Zamierzam zamknąć temat pomimo błędu przy przenoszeniu folderu, ale o który nie wnioskowano w podstawowym pytaniu.
Do przeniesienia folderu mam kilka pomysłów:
- Najpierw przenieś części, a nie folder, a następnie utwórz folder
- dowiedz się, skąd ten błąd (zadając pytanie na dedykowanym forum makr Solidworks)
Co do reszty, makro jest doskonale funkcjonalne i dziękuję @d.roger za doskonale wykonaną pracę, zaoszczędziło mi to więcej niż cenny czas, a jednocześnie miało znacznie czystszy kod niż to, co zrobiłbym na moim poziomie początkującym.
Serdecznie zapraszamy na podziękowania, wzajemna pomoc to zasada forum...
Jeśli chodzi o przenoszenie folderów, pierwszym pomysłem, który bierzesz pod uwagę, jest coś, o czym również myślałem, ale na razie nie ma czasu, aby to przetestować. Jeśli masz funkcjonalne rozwiązanie, jestem za tym, będzie to dobre dla mojej ogólnej kultury...
Nie zapomnij przerobić kodu, aby dodać obsługę błędów.
Nie martw się, do zarządzania błędami muszę dodać trochę kodu, ale nic do wymyślenia, tylko po to, aby przeszczepić w prawo i w lewo, co powinno mi odpowiadać!
