Weet u hoe u toegang kunt krijgen tot het afgeleide vouwelement in VBA om de verwijdering ervan te annuleren voordat u het naar DXF exporteert (foto hieronder)? Dit wordt gedaan door een lus te doorlopen die de verwijderstatus controleert.
Ik weet hoe ik toegang kan krijgen tot de uitgevouwen staat met de volgende code. Dim swFlatPattern als SldWorks.FlatPatternFeatureData Stel swFlatPatternFeat in = vFlatPatternFeats(i)
Maar niet op het niveau eronder om bij de afgeleide vouw te komen.
Sub AccederPliDeriveEtAnnulerSuppression()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.Model
Dim swFlatPatternFeat As SldWorks.FlatPatternFeatureData
Dim vFlatPatternFeats As Variant
Dim i As Integer
Dim swDerivedFoldFeat As SldWorks.Feature
Dim swFoldFeat As SldWorks.Feature
' Initialisation de l'application SolidWorks
Set swApp = Application.SldWorks
' Sélection du modèle actif
Set swModel = swApp.ActiveDoc
' Récupération des fonctionnalités de type "Flat Pattern"
vFlatPatternFeats = swModel.GetFeaturesOfType(SldWorks.swFeatureType_e.swFlatPattern)
' Boucle pour chaque fonctionnalité "Flat Pattern"
For i = 0 To UBound(vFlatPatternFeats)
Set swFlatPatternFeat = vFlatPatternFeats(i)
' Itération à travers les fonctionnalités enfants pour trouver le "Pli dérivé"
For Each swFoldFeat In swFlatPatternFeat.GetChildren
' Vérification du type de fonctionnalité (Adapter le type si nécessaire)
If swFoldFeat.GetTypeName = "Fold" Then ' ou "DerivedFold" selon votre version/nomenclature
Set swDerivedFoldFeat = swFoldFeat
' Vérifier l'état de suppression
If swDerivedFoldFeat.IsDeleted Then
' Annuler la suppression (Note: Cette action peut nécessiter des adaptations en fonction de la version de SolidWorks et de vos besoins spécifiques)
' **Attention : L'exécution de cette ligne peut avoir des conséquences sur votre modèle. Testez dans un environnement contrôlé.**
' swDerivedFoldFeat.SetDelete False ' (Décommenter et adapter si nécessaire)
' Affichage d'un message pour indiquer que le "Pli dérivé" était marqué pour suppression
MsgBox "Le Pli dérivé de la fonctionnalité " & swFlatPatternFeat.Name & " était marqué pour suppression."
End If
End If
Next swFoldFeat
Next i
' Nettoyage
Set swDerivedFoldFeat = Nothing
Set swFoldFeat = Nothing
Set swFlatPatternFeat = Nothing
Set swModel = Nothing
Set swApp = Nothing
End Sub
Ik zie dat de Bing-vertaling weer zijn ding heeft gedaan: VS Einde sub. Ik weet niet of ik moet lachen of huilen! @Coralie is te zien als het gaat om code tussen tags om te voorkomen dat de vertaler er rekening mee houdt. Edit: en dan heb ik het niet over de declaraties die door de vertaler zijn gewijzigd en die de code onbruikbaar maken zonder kennis.
Dim swApp As SldWorks.SldWorks
Dim myModel As SldWorks.ModelDoc2
Dim featureMgr As SldWorks.FeatureManager
Dim feat As SldWorks.Feature
Dim featArray As Variant
Dim i As Long
Dim j As Long
Dim bret As Boolean
Dim vFeatState As Variant
Option Explicit
Sub main()
Set swApp = Application.SldWorks
Set myModel = swApp.ActiveDoc
Set featureMgr = myModel.FeatureManager
Dim flatPatternFolder As SldWorks.flatPatternFolder
Set flatPatternFolder = featureMgr.GetFlatPatternFolder
Set feat = flatPatternFolder.GetFeature
Debug.Print "Flat-pattern folder name: " & feat.Name
Debug.Print " Number of flat-pattern features in the folder: " & flatPatternFolder.GetFlatPatternCount
featArray = flatPatternFolder.GetFlatPatterns
For i = LBound(featArray) To UBound(featArray)
Set feat = featArray(i)
vFeatState = feat.IsSuppressed2(swAllConfiguration, featArray)
For j = LBound(vFeatState) To UBound(vFeatState)
If vFeatState(j) = True Then
bret = feat.SetSuppression2(1, 2, featArray)
MsgBox "Le Pli dérivé de la fonctionnalité " & feat.Name & " était marqué pour suppression."
End If
Next j
Next i
End Sub
Ik heb er niet op gelet of de @max59 code bewoog toen ik hem terug tussen de tags plaatste, maar er zijn regels met functies die niet bestaan op de SW API.
Na het identificeren van de " FaltPattern " functie, moet je graven in de sub-kenmerken om de schetsen en vouwen (" UiBend "). te vinden. Hoe verder je naar beneden gaat, hoe gieriger het API-document is met informatie.
Sub AccederPliDeriveEtAnnulerSuppression()
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swFeature As Feature
Dim swFlatPatternFeat As Feature
Dim vSupprStateArr As Variant
Dim bret As Boolean
Set swApp = Application.SldWorks ' Initialisation de l'application SolidWorks
Set swModel = swApp.ActiveDoc ' Sélection du modèle actif
Set swFeature = swModel.FirstFeature ' Récupération des fonctionnalités de type "Flat Pattern"
While Not swFeature Is Nothing
If swFeature.GetTypeName = "FlatPattern" Then ' La fonction est un "état déplié"
If Not swFeature Is Nothing Then
Debug.Print swFeature.GetTypeName, swFeature.Name
Set swFlatPatternFeat = swFeature.GetFirstSubFeature 'Première sous-fonction
Do While Not swFlatPatternFeat Is Nothing
If swFlatPatternFeat.GetTypeName2 = "UiBend" Then ' UiBend est le nom de la fonction pour un dépliage (ProfileFeature pour une esquisse)
Debug.Print swFlatPatternFeat.GetTypeName, swFlatPatternFeat.Name
vSupprStateArr = swFlatPatternFeat.IsSuppressed2(swThisConfiguration, Nothing) ' Test de l'état supprimé
If vSupprStateArr(0) = True Then
bret = swFlatPatternFeat.SetSuppression2(swUnSuppressFeature, swThisConfiguration, Nothing)
End If
End If
Set swFlatPatternFeat = swFlatPatternFeat.GetNextSubFeature ' Sous fonction suivante
Loop
End If
End If
Set swFeature = swFeature.GetNextFeature ' Fonction suivante
Wend
Set swModel = Nothing
Set swApp = Nothing
End Sub
Bedankt @Cyril_f voor de eerste code, en @m_blt voor de aanvulling op de subfuncties waar ik al een tijdje tevergeefs naar op zoek was in de API's. De code is perfect functioneel en kan worden toegevoegd aan een van mijn macro's.
