Witam
Chciałbym skorzystać z prośby z naszych folderów, aby zmodyfikować jedno z naszych makr, aby wykonać plan cięcia + składania, dodać za pośrednictwem Vba adnotację wskazującą stałą stronę rozłożonego na MEP.
Ręczna metoda puszkowania tej twarzy:
Z pokoju udaje mi się pobrać tę twarz w zaznaczeniu z tym kodem:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim selManager As SldWorks.SelectionMgr
Dim swFeat As SldWorks.Feature
Dim swFlatPatt As SldWorks.FlatPatternFeatureData
Dim lErrors As Long
Dim lWarnings As Long
Dim bRet As Boolean
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set selManager = swModel.SelectionManager
'********************************************************************************
'A modifier pour sélectionner depuis une MEP au lieu de depuis la pièce
'********************************************************************************
If (swModel.GetType <> swDocPART) Then
MsgBox "Merci d'ouvrir une pièce de tôlerie avant de relancer!"
Exit Sub
End If
'On lance la fonction pour afficher la face fixe (= côté protection PVC)
get_fixed_face
Dim swFace1 As Face2
Dim reponse As Integer
reponse = MsgBox("Voulez vous sélectionner une autre face protégée (film PVC) pour la pièce de tôlerie?" + Chr(10) + "Si oui merci de sélectionner une nouvelle face une fois cette fenêtre fermé.", vbQuestion + vbYesNo + vbDefaultButton1, "Selection de la face protéger (PVC)")
If reponse = vbNo Then
'On descend la barre
swFlatPatt.ReleaseSelectionAccess
Exit Sub
Else
'On descend la barre
swFlatPatt.ReleaseSelectionAccess
End If
Do While swFace1 Is Nothing
Set swFace1 = selManager.GetSelectedObject6(1, -1)
DoEvents
Loop
'On lance les 2 fonctions imbriquées
set_fixed_face get_flat_feature(swFace1.GetBody), swFace1
'On sauvegarde les changements
bRet = swModel.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
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
Public Function get_fixed_face()
Set swFeat = swModel.FirstFeature 'Va au 1er feature dans la pièce.
'Tourne jusqu'à trouver un feature 'FlatPattern'.
Do Until swFeat Is Nothing
'On vérifie si le feature est 'FlatPattern' ou pas.
Debug.Print "Type name:" & swFeat.GetTypeName
Debug.Print "Name:" & swFeat.Name
If swFeat.GetTypeName = "FlatPattern" Then
Dim swFixedFace As SldWorks.Face2
Dim selectData As SldWorks.selectData
Set swFlatPatt = swFeat.GetDefinition
bRet = swFlatPatt.AccessSelections(swModel, Nothing)
Set swFixedFace = swFlatPatt.FixedFace2
bRet = swFixedFace.Select4(True, selectData)
'********************************************************************************
'Depuis cette sélection ajout d'une annotation sur la face sélectionné avec texte face fixe
'********************************************************************************
Exit Function
Else
End If
Set swFeat = swFeat.GetNextFeature 'Va au feature suivant.
Loop
End Function
Czy masz jakiś pomysł, jak:
1-Uruchom makro z MEP zamiast z pokoju
2-Dodaj adnotację po wybranej stronie (strona stała)
Punkt 1 wydaje mi się wykonalny, punkt 2 tak naprawdę nie widzę, której funkcji użyć i kilka pomysłów byłoby mile widzianych!
Z góry dziękuję
