Bonjour,
Je cherche à modifier une macro trouvé sur internet, qui n’a vraisemblablement jamais été terminé.
Le but serait de modifié la face fixe d’une pièce de tôlerie en offrant la possibilité à l’utilisateur de choisir sa propre face sur le modèle 3D. (A incorporer ensuite dans une longue macro de ma réalisation pour la réalisation en auto d’une MEP de découpe + pliage)
J’ai beau tourner autour depuis 2 jours, j’avoue que je sèche un peu.
Voici la macro modifié:
Option Explicit
Dim swApp As Object
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
'Dim boolstatus As Boolean
'Dim longstatus As Long, longwarnings As Long
'Dim swCustPrpMgr As SldWorks.CustomPropertyManager
Dim Value As String
Dim swPart As SldWorks.ModelDoc2
Dim Options As Variant
Dim SelMgr As SldWorks.SelectionMgr
Dim seltype As Variant
Dim isThisAPlane As Boolean
Dim swConfig As SldWorks.Configuration
Dim Test As Variant
Dim swFeat As SldWorks.Feature
Dim swSubFeat As SldWorks.Feature
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If (swModel.GetType <> swDocPART) Then
MsgBox "Please open a Sheet Metal Part first and then try again!"
Exit Sub
Else
'Set swCustPrpMgr = swModel.Extension.CustomPropertyManager("")
'swCustPrpMgr.Get3 "Thickness", False, "", Value
'swCustPrpMgr.Get3 "Epaisseur de tôlerie", False, "", Value
'Debug.Print "Epaisseur:" & Value
Set swFeat = swModel.FirstFeature 'Gets the first feature in the part document.
'Loops through the features until 'FlatPattern' feature if found.
Do Until swFeat Is Nothing
'Checks whether the feature type is 'FlatPattern' or not.
'Debug.Print "Type name:" & swFeat.GetTypeName
'Debug.Print "Name:" & swFeat.Name
If swFeat.GetTypeName = "FlatPattern" Then
Dim bRet As Boolean
Dim swFlatPatt As SldWorks.FlatPatternFeatureData
Dim swFixedFace As SldWorks.Face2
Dim selectData As SldWorks.selectData
Set SelMgr = swModel.SelectionManager
'xxxxxxxxxxxxxxxxxxxxxxxxx
'I need code here to select the face
' 'did the user pre-select a face?
' seltype = SelMgr.GetSelectedObjectType2(1)
' If SelMgr.GetSelectedObjectCount <> 1 Then
' seltype = SelMgr.GetSelectedObjectType3(1, 0)
' If (seltype <> SwConst.swSelFACES) Then
' ' 'user did not preselect one face
' swApp.SendMsgToUser "Please select a (one) 2D face before running this command."
' GoTo cleanupandquit
' End If
' End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxx
Set swFlatPatt = swFeat.GetDefinition
bRet = swFlatPatt.AccessSelections(swModel, Nothing)
Set swFixedFace = swFlatPatt.FixedFace2
' Set swFixedFace = seltype
bRet = swFixedFace.Select4(True, selectData)
' Stop
swFlatPatt.ReleaseSelectionAccess
swFeat.SetSuppression (1)
swFeat.SetSuppression (0)
Else
End If
Set swFeat = swFeat.GetNextFeature 'Gets the next feature in part document.
Loop
End If
cleanupandquit:
Set swConfig = Nothing
Set swApp = Nothing
Set swModel = Nothing
Set SelMgr = Nothing
End Sub
Le sujet original de la macro:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/?_gl=1n52pes_gaMjcxNTI5NDczLjE2NDAwNjkyNDQ._ga_XQJPQWHZHH*MTY3MzQyNzE4NC43Mi4wLjE2NzM0MjcyNTAuNjAuMC4w#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:koHtH74aQp2V8jPiw2IwYQ
Sinon pour le seul lien de l’API trouvé sur le sujet:
https://help.solidworks.com/2020/english/api/sldworksapi/get_fixed_face_of_sheet_metal_part_example_vb.htm?verRedirect=1
Si vous avez ne serait-ce que des pistes cela m’intéresse fortement.
Merci d’avance.
Sébastien
Il y a peut-être une erreur dans la macro car elle ne permet pas à l’utilisateur de choisir sa propre face sur le modèle 3D. Il y a des sections de codes commentées qui contiennent des instructions pour sélectionner une face spécifique, mais ces commentaires ne sont pas utilisées. Ces commentaires devraient permettre à l’utilisateur de sélectionner une face avant d’exécuter la macro, mais étant donné qu’elles sont commentées, elles ne sont pas utilisées et la macro continue à utiliser la face fixe par défaut. Les sections de codes à décommenter sont :
'did the user pre-select a face?
seltype = SelMgr.GetSelectedObjectType2(1)
If SelMgr.GetSelectedObjectCount <> 1 Then
seltype = SelMgr.GetSelectedObjectType3(1, 0)
If (seltype <> SwConst.swSelFACES) Then
' 'user did not preselect one face
swApp.SendMsgToUser "Please select a (one) 2D face before running this command."
GoTo cleanupandquit
End If
End If
Et
Set swFixedFace = seltype
a+
1 « J'aime »
Oui j’ai déjà essayé de dé-commenter mais j’ai pas obtenu ce que je souhaitais. Ni l’utilisateur de base qui postait la question. J’ai laissé ce code commenté car cela peut aider à débuguer le code initiale.
1 « J'aime »
Et si tu essaye avec ça? Ce code permet de vérifier si l’utilisateur a sélectionné une face avant de continuer à exécuter la macro:
Set SelMgr = swModel.SelectionManager
seltype = SelMgr.GetSelectedObjectType2(1)
If SelMgr.GetSelectedObjectCount <> 1 Then
seltype = SelMgr.GetSelectedObjectType3(1, 0)
If (seltype <> SwConst.swSelFACES) Then
'user did not preselect one face
swApp.SendMsgToUser "Please select a (one) 2D face before running this command."
GoTo cleanupandquit
End If
End If
de plus, Il faut que swconst soit défini dans ta macro.
Ensuite tu peux utiliser la sélection pour définir la face fixe dans la feature FlatPattern:
Set swFlatPatt = swFeat.GetDefinition
bRet = swFlatPatt.AccessSelections(swModel, Nothing)
Set swFixedFace = seltype
bRet = swFixedFace.Select4(True, selectData)
1 « J'aime »
Bonjour @tous
Ci joint deux fonctions que j’ai développé pour un de mes projets
le corps est optenu par face.getbody
Public Function get_flat_feature(bod As Body2) As Feature
Dim featurmgr As FeatureManager
Set featurmgr = swModel.FeatureManager
Dim flatpaternfolder As FlatPatternFolder
Set flatpaternfolder = featurmgr.GetFlatPatternFolder()
Dim flatfeatures As Variant
flatfeatures = flatpaternfolder.GetFlatPatterns()
Dim sFlatPatternFeatureData As FlatPatternFeatureData
Dim face As Face2
Dim feat As Variant
For Each feat In flatfeatures
Set sFlatPatternFeatureData = feat.GetDefinition()
Set face = sFlatPatternFeatureData.FixedFace2
If face.GetBody.name = bod.name Then
Set get_flat_feature = feat
Exit Function
End If
Next
End Function
Public Sub set_fixed_face(feat As Feature, face As Face2)
Dim sFlatPatternFeatureData As FlatPatternFeatureData
Set sFlatPatternFeatureData = feat.GetDefinition()
sFlatPatternFeatureData.AccessSelections swModel, Nothing
sFlatPatternFeatureData.FixedFace2 = face
feat.ModifyDefinition sFlatPatternFeatureData, swModel, Nothing
End Sub
2 « J'aime »
La première fonction localise l’état déplié pour un multicorp
La face est supposée sélectionné avant l’appellation de la fonction.
Si vous désirez attendre une sélection préviens moi 
La solution initiale ne fonctionne pas la sélection se fait bien mais la face n’est pas modifié ainsi.
Pour ta solution @Lynkoa15 je regarde ce que cela donne.
Par contre pas de pièce multicorps pour nous une tôle= une pièce.
Et l’idée est bien de passer par une sélection après coup car c’est à implanter dans une macro existante donc pas possible de sélectionner la face en 1er.
Dans tout les cas merci à vous 2 pour les pistes et je continu à creuser de mon côté!
CI JOINT UN MINIMUM
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim selManager As SldWorks.SelectionMgr
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set selManager = swModel.SelectionManager
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'code
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim swFace1 As Face2
Do While swFace1 Is Nothing
Set swFace1 = selManager.GetSelectedObject6(1, -1)
DoEvents
Loop
set_fixed_face get_flat_feature(swFace1.GetBody), swFace1
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'code
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
1 « J'aime »
Merci @Lynkoa15 , je viens d’essayer ton dernier code et cela bloque sur la ligne en jaune (erreur 424-Objet requis):
J’ai pourtant bien sélectionné ma face et le DoEvents (que je ne connaissais pas) fait bien le job.
J’ai joint ma pièce pour essai au besoin (sw2020)
Pièce1.SLDPRT (250,3 Ko)
Pour moi ça fonctionne
Avez-vous bien coller le dim swmodel avant la fonction main()
Assurez vous que le pointeur souris et dans la fonction main() (il arrive que le compilateur essaie d’exécuter la fonction en cours)
Sinon pour la pièce rien de particulier faut juste déplacer la barre reprise à la fin
1 « J'aime »
Il me manquait bien les déclarations au dessus du main, après ajout effectivement cela fonctionne beaucoup mieux!
Le code complet pour rappel:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim selManager As SldWorks.SelectionMgr
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set selManager = swModel.SelectionManager
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'code
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim swFace1 As Face2
Do While swFace1 Is Nothing
Set swFace1 = selManager.GetSelectedObject6(1, -1)
DoEvents
Loop
set_fixed_face get_flat_feature(swFace1.GetBody), swFace1
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'code
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
Public Function get_flat_feature(bod As Body2) As Feature
Dim featurmgr As FeatureManager
Set featurmgr = swModel.FeatureManager
Dim flatpaternfolder As FlatPatternFolder
Set flatpaternfolder = featurmgr.GetFlatPatternFolder()
Dim flatfeatures As Variant
flatfeatures = flatpaternfolder.GetFlatPatterns()
Dim sFlatPatternFeatureData As FlatPatternFeatureData
Dim face As Face2
Dim feat As Variant
For Each feat In flatfeatures
Set sFlatPatternFeatureData = feat.GetDefinition()
Set face = sFlatPatternFeatureData.FixedFace2
If face.GetBody.Name = bod.Name Then
Set get_flat_feature = feat
Exit Function
End If
Next
End Function
Public Sub set_fixed_face(feat As Feature, face As Face2)
Dim sFlatPatternFeatureData As FlatPatternFeatureData
Set sFlatPatternFeatureData = feat.GetDefinition()
sFlatPatternFeatureData.AccessSelections swModel, Nothing
sFlatPatternFeatureData.FixedFace2 = face
feat.ModifyDefinition sFlatPatternFeatureData, swModel, Nothing
End Sub
1 « J'aime »
