Witam
Chciałbym zrobić makro, aby wyizolować w zespole (przechodząc przez całe drzewo) tylko te części, które zawierają właściwość niestandardową w części " REF-PIECE " i które różnią się od pustych.
Czy to możliwe? A czy masz jakiś pomysł, jak to zrobić?
chatGPT wygenerował dla mnie ten kod, to działa. Ale uważam, że to powoli, ty musisz.
20 sekund w przypadku zespołu, który nie ma jednak zbyt wielu części. Czy widzisz coś w kodzie, co można by zoptymalizować, aby działało znacznie szybciej?
Option Explicit
Const swDocPART = 1
Const swDocASSEMBLY = 2
Const swDocDRAWING = 3
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim componentsToSelect As Collection
Dim processedComponents As Object ' Dictionnaire pour suivre les composants traités
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Aucun document actif."
Exit Sub
End If
If swModel.GetType <> swDocASSEMBLY Then
MsgBox "Ce script fonctionne uniquement dans un assemblage."
Exit Sub
End If
Set swAssy = swModel
Set componentsToSelect = New Collection
Set processedComponents = CreateObject("Scripting.Dictionary") ' Utilisation d'un dictionnaire pour une recherche rapide
' Récupère le composant racine
Dim rootComp As SldWorks.Component2
Set rootComp = swModel.ConfigurationManager.ActiveConfiguration.GetRootComponent3(True)
If rootComp Is Nothing Then
MsgBox "Composant racine introuvable."
Exit Sub
End If
' Appel du parcours
Call ParcourirComposants(rootComp)
' Sélection des pièces avec REF-PIECE non vide
swModel.ClearSelection2 True
Dim comp As SldWorks.Component2
' Création de la sélection multiple
For Each comp In componentsToSelect
comp.Select4 True, Nothing, False
Next comp
' Si des pièces ont été sélectionnées, on les isole
If componentsToSelect.Count > 0 Then
swApp.SendMsgToUser2 "Isoler les pièces trouvées.", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
' Isoler avec SendKeys
SendKeys "i"
Else
MsgBox "Aucune pièce avec la propriété de configuration 'REF-PIECE' trouvée."
End If
End Sub
Sub ParcourirComposants(compParent As SldWorks.Component2)
Dim vChildComp As Variant
Dim swChild As SldWorks.Component2
Dim i As Integer
Dim swModelChild As ModelDoc2
Dim swConf As SldWorks.Configuration
Dim val As String
Dim compKey As String
Dim fileName As String
Dim confName As String
If compParent Is Nothing Then Exit Sub
' Récupérer les composants enfants
vChildComp = compParent.GetChildren
' Vérification : Si des enfants existent
If Not IsEmpty(vChildComp) Then
' On parcourt le tableau des enfants
For i = 0 To UBound(vChildComp)
Set swChild = vChildComp(i)
If Not swChild.IsSuppressed Then
If swChild.GetModelDoc2 Is Nothing Then
swChild.ReferencedConfiguration = swChild.ReferencedConfiguration ' Force le chargement
End If
Set swModelChild = swChild.GetModelDoc2
' Optimisation : Vérifie d'abord si le modèle est déjà chargé
If Not swModelChild Is Nothing Then
' Vérification que le type de modèle est une pièce
If swModelChild.GetType = swDocPART Then
confName = swChild.ReferencedConfiguration
Set swConf = swModelChild.GetConfigurationByName(confName)
If Not swConf Is Nothing Then
val = swConf.CustomPropertyManager.Get("REF-PIECE")
' Si la propriété REF-PIECE n'est pas vide
If Len(Trim(val)) > 0 Then
fileName = GetFileNameFromPath(swChild.GetPathName) ' Extraire le nom du fichier
compKey = fileName & "-" & confName ' Créer la clé unique avec le nom de fichier et la configuration
' Si la clé n'existe pas déjà dans le dictionnaire, on l'ajoute
If Not processedComponents.Exists(compKey) Then
componentsToSelect.Add swChild
processedComponents.Add compKey, True ' Ajoute la clé au dictionnaire
End If
End If
End If
End If
End If
End If
' Appel récursif sur les sous-enfants
Call ParcourirComposants(swChild)
Next i
End If
End Sub
' Fonction pour extraire le nom du fichier depuis le chemin
Function GetFileNameFromPath(filePath As String) As String
Dim fileName As String
fileName = Mid(filePath, InStrRev(filePath, "\") + 1)
GetFileNameFromPath = fileName
End Function
Witam
To, co bym zrobił, to zadeklarował wszystkie zmienne, które znajdują się w pętli For przed pętlą (innymi słowy, wyprowadź wszystkie wiersze z Dim). Nie trzeba ich ponownie deklarować w każdej iteracji, o ile ich wartość jest ponownie przypisywana w pętli.
Nie mówię, że znacznie przyspieszy, ale jest to lepsze dla procesora.
Witam, dziękuję za odpowiedź, właśnie dokonałem zmiany (odpowiednio zmodyfikowałem kod mojej podstawowej wiadomości). Niestety nie zauważyłem żadnej zaoszczędzonej czasu 
Jeśli nie jest to dla Ciebie interesujące, możesz skomentować rekurencyjne wywołanie na podrzędnych dzieciach. Z apostrofem przed Callem.
' Appel récursif sur les sous-enfants
' Call ParcourirComposants(swChild)
Możesz spróbować z blokiem With, ale nie wiem, czy Solidworks już sobie z tym radzi
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim componentsToSelect As Collection
Dim processedComponents As Object ' Dictionnaire pour suivre les composants traités
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Aucun document actif."
Exit Sub
End If
If swModel.GetType <> swDocASSEMBLY Then
MsgBox "Ce script fonctionne uniquement dans un assemblage."
Exit Sub
End If
Set swAssy = swModel
Set componentsToSelect = New Collection
Set processedComponents = CreateObject("Scripting.Dictionary") ' Utilisation d'un dictionnaire pour une recherche rapide
' Récupère le composant racine
Dim rootComp As SldWorks.Component2
Set rootComp = swModel.ConfigurationManager.ActiveConfiguration.GetRootComponent3(True)
If rootComp Is Nothing Then
MsgBox "Composant racine introuvable."
Exit Sub
End If
' Appel du parcours
Call ParcourirComposants(rootComp)
' Sélection des pièces avec REF-PIECE non vide
swModel.ClearSelection2 True
Dim comp As SldWorks.Component2
' Création de la sélection multiple
For Each comp In componentsToSelect
comp.Select4 True, Nothing, False
Next comp
' Si des pièces ont été sélectionnées, on les isole
If componentsToSelect.Count > 0 Then
swApp.SendMsgToUser2 "Isoler les pièces trouvées.", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
' Isoler avec SendKeys
SendKeys "i"
Else
MsgBox "Aucune pièce avec la propriété de configuration 'REF-PIECE' trouvée."
End If
End Sub
Sub ParcourirComposants(compParent As SldWorks.Component2)
Dim vChildComp As Variant
Dim swChild As SldWorks.Component2
Dim i As Integer
Dim swModelChild As ModelDoc2
Dim swConf As SldWorks.Configuration
Dim val As String
Dim compKey As String
Dim fileName As String
Dim confName As String
If compParent Is Nothing Then Exit Sub
' Récupérer les composants enfants
vChildComp = compParent.GetChildren
' Vérification : Si des enfants existent
If Not IsEmpty(vChildComp) Then
' On parcourt le tableau des enfants
For i = 0 To UBound(vChildComp)
Set swChild = vChildComp(i)
With swChild
If Not .IsSuppressed Then
If .GetModelDoc2 Is Nothing Then
.ReferencedConfiguration = .ReferencedConfiguration ' Force le chargement
End If
Set swModelChild = .GetModelDoc2
' Optimisation : Vérifie d'abord si le modèle est déjà chargé
If Not swModelChild Is Nothing Then
' Vérification que le type de modèle est une pièce
If swModelChild.GetType = swDocPART Then
confName = .ReferencedConfiguration
Set swConf = swModelChild.GetConfigurationByName(confName)
If Not swConf Is Nothing Then
val = swConf.CustomPropertyManager.Get("REF-PIECE")
' Si la propriété REF-PIECE n'est pas vide
If Len(Trim(val)) > 0 Then
fileName = GetFileNameFromPath(.GetPathName) ' Extraire le nom du fichier
compKey = fileName & "-" & confName ' Créer la clé unique avec le nom de fichier et la configuration
' Si la clé n'existe pas déjà dans le dictionnaire, on l'ajoute
If Not processedComponents.Exists(compKey) Then
componentsToSelect.Add swChild
processedComponents.Add compKey, True ' Ajoute la clé au dictionnaire
End If
End If
End If
End If
End If
End If
End With
' Appel récursif sur les sous-enfants
Call ParcourirComposants(swChild)
Next i
End If
End Sub
' Fonction pour extraire le nom du fichier depuis le chemin
Function GetFileNameFromPath(filePath As String) As String
Dim fileName As String
fileName = Mid(filePath, InStrRev(filePath, "\") + 1)
GetFileNameFromPath = fileName
End Function
Uwaga: Bądź ostrożny, pozostawiłem aktywną rekurencję w tym kodzie.
Alternatywnie można również umieścić punkty przerwania (w kolumnie po lewej stronie numeru wiersza edytora makr) w kluczowych miejscach, aby określić, które fragmenty kodu są najbardziej czasochłonne. Tylko po to, żeby wiedzieć, nad czym pracować.
W pierwszym kroku umieściłbym punkt przerwania przed linią, która następuje po linii początku pętli For (innymi słowy, przed linią Set swChild = vChildComp(i)). Pozwoli Ci to w czasie wykonywania dowiedzieć się, kiedy rozpoczyna się pętla i każda nowa iteracja, a tym samym ocenić/zmierzyć, ile czasu upływa między 2 iteracjami.
Kod wydaje mi się być dobrze zaprojektowany i raczej dobrze skonstruowany i zoptymalizowany. (Muszę przyznać, że jak na kota to całkiem nieźle!)
W przypadku złożenia 2296 części z 339 unikalnymi częściami czas pliku wynosi około 20 sekund (bez żadnych części z określoną właściwością REF-PIECE).
Na zespole ze 152 częściami dla 142 pojedynczych części czas 2-3 s max (bez żadnych części o właściwości, która ma być izolowana)
Wydaje mi się to całkiem poprawne, biorąc pod uwagę, że przechodzi przez wszystkie zestawy i podzbiory.
Z drugiej strony, uważaj, aby uruchamiać swój kod tylko na rozwiązanych zestawach, w przeciwnym razie może nie odizolować Cię od niektórych nierozpoznanych komponentów, jeśli się nie mylę.
W przypadku części izolacyjnej należy unikać uruchamiania skrótów w makrze (nie wykonuj niczego, jeśli skrót na stacji roboczej nie jest zainstalowany (lub, co gorsza, wykonaj coś innego, jeśli skrót jest używany do czegoś innego!)
Zastąpić:
' Isoler avec SendKeys
SendKeys "i"
Przez:
Dim status As Boolean
status = swModel.Isolate()
swModel.SetIsolateVisibility (swIsolateVisibility_e.swIsolateVisibility_HIDDEN) 'swIsolateVisibility_HIDDEN swIsolateVisibility_TRANSPARENT swIsolateVisibility_WIREFRAME
'Exit isolate
'status = swModel.ExitIsolate() 'Pour suppression éventuel de la fonction isolé (à déplacer ou rajouter du code entre isolé et suppression isolé)
Możliwość wybrania czegoś innego niż ukryte z izolowanych opcji (UKRYTE, PRZEZROCZYSTE lub SZKIELETOWE)
Witam
Dziękuję za odpowiedzi.
Aby go odizolować, możliwe byłoby wyświetlenie tego okna tak, jak w przypadku ręcznej izolacji, aby szybko je zamknąć, za pomocą swModel.SetIsolateVisibility (swIsolateVisibility_e.swIsolateVisibility_HIDDEN)
Nie sądzę, aby można było wyświetlić przycisk w makrze, który uruchamia kod, aby wyjść z izolacji:
status = swModel.ExitIsolate()
Zobacz załączone makro z dodatkiem przycisku.
Isolate-Prop.swp (70,5 KB)
Dla kodu wyświetlanego formularza użytkownika:
' Isoler avec SendKeys
'SendKeys "i"
Dim status As Boolean
status = swModel.Isolate()
swModel.SetIsolateVisibility (swIsolateVisibility_e.swIsolateVisibility_HIDDEN) 'swIsolateVisibility_HIDDEN swIsolateVisibility_TRANSPARENT swIsolateVisibility_WIREFRAME
'Exit isolate
'status = swModel.ExitIsolate()
UserformQuitter.Show vbModeless
I dla kodu UserformQuitter (z przyciskiem o nazwie Button1)
Jest idealny, to jest dokładnie to, czego potrzebowałem. 
Czy byłoby możliwe, aby ten formularz użytkownika był wyśrodkowany w oknie oprogramowania, aby łatwo go znaleźć, ponieważ jest trochę wszędzie w zależności od użytkownika, czy jest 1, 2 lub 3 ekrany. Próbowałem sztuczki do wyśrodkowania, którą miałem dla formularza użytkownika w programie Excel, ale tutaj to nie działa.
Witam
Musisz dodać procedurę w kodzie, zobacz ten temat: Centrowanie formularza użytkownika na ekranie - Makro - myCAD Forum
Nie, to, co działa w Excelu, nie działa w oprogramowaniu.
Wyśrodkowanie okna w stosunku do używanego ekranu jest bardzo skomplikowane w oprogramowaniu.
Zobacz ten temat i odpowiedź @m_blt raz jeszcze:
Dziękuję, właśnie spojrzałem na temat. Zastosowałem to, co należało zrobić. działa dobrze dla userformLeaves, jest dobrze wyśrodkowany. Zrobiłem to samo dla mojego 2. formularza użytkownikaChoix, ale tam to nie działa, mówi mi, że nie może znaleźć okna, aby móc wyśrodkować. Czy wiesz, co musiałoby zostać zmienione?
Ociepl pomieszczenie bez sprzętu.swp (117,5 KB)
Witam
Ze swojej strony umieściłem wywołanie funkcji w każdym formularzu użytkownika w procedurze aktywacji:
Private Sub UserForm_Activate()
CoincidentsCtresWindows "SOLIDWORKS", xxx.Caption, True
End Sub
Jest idealny, działa, dziękuję 