Hallo
Ik wil graag een macro maken om in een assembly (door de hele boom te doorlopen) alleen de onderdelen te isoleren die de aangepaste eigenschap bevatten in een " REF-PIECE " -onderdeel en dat het anders is dan leeg.
Is het mogelijk? En heb je enig idee hoe je dat moet doen?
chatGPT heeft deze code voor mij gegenereerd, het werkt. Maar ik vind het traag, je moet wel.
20sec voor een assemblage die echter niet al te veel onderdelen heeft. Zie je iets in de code dat geoptimaliseerd kan worden om veel sneller te gaan?
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
Hallo
Wat ik zou doen is alle variabelen die in de For-lus voor de lus staan declareren (met andere woorden, alle regels met een Dim uitvoeren). Ze hoeven niet bij elke iteratie opnieuw te worden gedeclareerd, zolang hun waarde maar opnieuw wordt toegewezen in de lus.
Ik zeg niet dat het veel zal versnellen, maar het is beter voor de cpu.
Hallo, bedankt voor je antwoord, ik heb zojuist de wijziging aangebracht (ik heb de code van mijn basisbericht dienovereenkomstig aangepast). Ik heb helaas geen tijdbesparing gezien 
Als het je niet interesseert, kun je commentaar geven op de recursieve aanroep op subkinderen. Met een apostrof voor Call.
' Appel récursif sur les sous-enfants
' Call ParcourirComposants(swChild)
Je kunt het proberen met een With-blok, maar ik weet niet of Solidworks het nog aankan
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
Let op: Wees voorzichtig, ik heb recursie actief gelaten op deze code.
U kunt ook breekpunten (in de kolom links van het rijnummer van de macro-editor) op belangrijke plaatsen plaatsen om te bepalen welke delen van de code het meest tijdrovend zijn. Gewoon om te weten waar je aan moet werken.
In een 1e stap zou ik een breekpunt voor de lijn plaatsen die de lijn van het begin van de For-lus volgt (met andere woorden, voor de lijn Set swChild = vChildComp(i)). Dit stelt je in staat om tijdens de runtime te weten wanneer de lus en elke nieuwe iteratie beginnen, en dus om te evalueren/meten hoeveel tijd er verstrijkt tussen 2 iteraties.
De code lijkt mij goed ontworpen en vrij goed samengesteld en geoptimaliseerd. (Voor een kat is dat best goed, moet ik toegeven!)
Op een assemblage van 2296 onderdelen met 339 unieke onderdelen file tijd ongeveer 20s (zonder enige onderdelen met de REF-PIECE eigenschap opgegeven.)
Op een assemblage met 152 onderdelen voor 142 afzonderlijke onderdelen tijd 2-3 s max (zonder enige onderdelen met de te isoleren eigenschap)
Dit lijkt me redelijk correct, aangezien het door alle sets en subsets gaat.
Aan de andere kant, zorg ervoor dat je je code alleen start op opgeloste assembly's, anders isoleert het je misschien niet van sommige onopgeloste componenten, als ik me niet vergis.
Voor het isolatiegedeelte moet u vermijdt het uitvoeren van snelkoppelingen in een macro (voer niets uit als de snelkoppeling op het werkstation niet is geïnstalleerd (of erger nog, voer iets anders uit als de snelkoppeling voor iets anders wordt gebruikt!)
Vervangen:
' Isoler avec SendKeys
SendKeys "i"
Bij:
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é)
Mogelijkheid om iets anders dan verborgen te kiezen uit de geïsoleerde opties (VERBORGEN, TRANSPARANT of WIREFRAME)
Hallo
Dank u voor uw antwoorden.
Om het te isoleren, zou het mogelijk zijn om dit venster weer te geven zoals wanneer u handmatig isoleert om het snel te verlaten, met de swModel.SetIsolateVisibility (swIsolateVisibility_e.swIsolateVisibility_HIDDEN)
Ik denk niet dat je een knop in de macro kunt weergeven die de code start om te isoleren:
status = swModel.ExitIsolate()
Zie de bijgevoegde macro met de toevoeging van de knop.
Isolate-Prop.swp (70.5 KB)
Voor de weergavecode van het gebruikersformulier:
' 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
En voor de code van UserformQuitter (met een knop met de naam Button1)
Het is perfect, het is precies wat ik nodig had. 
Zou het mogelijk zijn om dit gebruikersformulier te centreren in het SW-venster om het gemakkelijk te vinden, omdat het overal een beetje is , afhankelijk van de gebruiker of er 1 of 2 of 3 schermen zijn. Ik heb een truc geprobeerd om te centreren die ik had voor een gebruikersformulier op Excel, maar het werkt hier niet.
Hallo
U moet een procedure toevoegen aan de code, zie dit onderwerp: Een gebruikersformulier centreren op een scherm - Macro - myCAD Forum
Nee, wat in Excel werkt, werkt niet op SW.
Het centreren van het venster ten opzichte van het gebruikte scherm is erg ingewikkeld op SW.
Bekijk dit onderwerp en @m_blt's antwoord nog eens:
Bedankt, ik heb net naar het onderwerp gekeken. Ik heb toegepast wat gedaan moest worden. het werkt goed voor de userformLeaves het is goed gecentreerd. Ik heb hetzelfde gedaan voor mijn 2e userformChoix, maar daar werkt het niet, het vertelt me dat het het venster niet kan vinden om te kunnen centreren. Weet jij wat er veranderd zou moeten worden?
Ruimte isoleren zonder hardware.swp (117.5 KB)
Hallo
Van mijn kant zet ik de functie-aanroep in elk gebruikersformulier in de activeringsprocedure:
Private Sub UserForm_Activate()
CoincidentsCtresWindows "SOLIDWORKS", xxx.Caption, True
End Sub
Het is perfect, het werkt, bedankt 