Hallo
Ich möchte ein im Internet gefundenes Makro ändern, das wahrscheinlich nie fertiggestellt wurde.
Ziel wäre es, die feste Fläche eines Blechteils zu modifizieren, indem dem Benutzer die Möglichkeit geboten wird, seine eigene Fläche auf dem 3D-Modell zu wählen.
Obwohl ich schon seit 2 Tagen herumlaufe, gebe ich zu, dass ich ein wenig austrockne.
Hier ist das geänderte Makro:
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
Das ursprüngliche Makrothema:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/?_gl=1n52pes_gaMjcxNTI5NDczLjE2NDAwNjkyNDQ._ga_XQJPQWHZHH*MTY3MzQyNzE4NC43Mi4wLjE2NzM0MjcyNTAuNjAuMC4w#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:koHtH74aQp2V8jPiw2IwYQ
Andernfalls für den einzigen API-Link, der zu diesem Thema gefunden wurde:
https://help.solidworks.com/2020/english/api/sldworksapi/get_fixed_face_of_sheet_metal_part_example_vb.htm?verRedirect=1
Wenn Sie überhaupt Hinweise haben, bin ich sehr interessiert.
Vielen Dank im Voraus.
Sebastian
Möglicherweise liegt ein Fehler im Makro vor, da der Benutzer nicht sein eigenes Gesicht im 3D-Modell auswählen kann. Es gibt kommentierte Codeabschnitte, die Anweisungen zum Auswählen eines bestimmten Gesichts enthalten, aber diese Kommentare werden nicht verwendet. Diese Kommentare sollten es dem Benutzer ermöglichen, vor dem Ausführen des Makros eine Fläche auszuwählen, aber da sie auskommentiert sind, werden sie nicht verwendet, und das Makro verwendet standardmäßig weiterhin die feste Fläche. Die Codeabschnitte, die auskommentiert werden sollen, sind:
'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
Und
Set swFixedFace = seltype
A+
1 „Gefällt mir“
Ja, ich habe bereits versucht, einen De-Kommentar abzugeben, aber ich habe nicht bekommen, was ich wollte. Auch nicht der einfache Benutzer, der die Frage gestellt hat. Ich habe diesen Code auskommentiert gelassen, da er beim Debuggen des ursprünglichen Codes helfen kann.
1 „Gefällt mir“
Was ist, wenn Sie es damit versuchen? Dieser Code wird verwendet, um zu überprüfen, ob der Benutzer ein Gesicht ausgewählt hat, bevor er mit dem Ausführen des Makros fortfährt:
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
Darüber hinaus muss swconst in Ihrem Makro definiert sein.
Dann können Sie die Auswahl verwenden, um die feste Fläche in der FlatPattern-Funktion festzulegen:
Set swFlatPatt = swFeat.GetDefinition
bRet = swFlatPatt.AccessSelections(swModel, Nothing)
Set swFixedFace = seltype
bRet = swFixedFace.Select4(True, selectData)
1 „Gefällt mir“
Hallo @tous
Beigefügt sind zwei Funktionen, die ich für eines meiner Projekte entwickelt habe
Der Körper wird von face.getbody unterstützt
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 „Gefällt mir“
Die erste Funktion lokalisiert den entfalteten Zustand für einen Mehrkörper
Es wird davon ausgegangen, dass die Fläche ausgewählt ist, bevor die Funktion benannt wird.
Wenn Sie auf eine Auswahl warten möchten, lassen Sie es mich wissen 
Die anfängliche Lösung funktioniert nicht, die Auswahl ist gut gemacht, aber die Fläche wird nicht auf diese Weise verändert.
Für Ihre @Lynkoa15 Lösung schaue ich mir an, wie es aussieht.
Auf der anderen Seite gibt es für uns kein Mehrkörperteil: ein Blatt = ein Teil.
Und die Idee ist, eine nachträgliche Auswahl zu durchlaufen, da sie in ein vorhandenes Makro implementiert werden soll, so dass es nicht möglich ist, das Gesicht in 1st auszuwählen.
Auf jeden Fall danke euch 2 für die Tracks und ich grabe weiter auf meiner Seite!
ANBEI EIN 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 „Gefällt mir“
Vielen Dank @Lynkoa15 , ich habe gerade Ihren neuesten Code ausprobiert und er bleibt in der Zeile in Gelb hängen (Fehler 424-Object erforderlich):
Allerdings habe ich mein Gesicht gut ausgewählt und die DoEvents (die ich nicht kannte) machen den Job gut.
Ich habe mein Teil angehängt, um es bei Bedarf zu testen (sw2020)
Artikel1.SLDPRT (250.3 KB)
Bei mir funktioniert es
Haben Sie das dim swmodel vor die main()-Funktion geklebt?
Stellen Sie sicher, dass der Mauszeiger und in der main()-Funktion (manchmal versucht der Compiler, die aktuelle Funktion auszuführen)
Ansonsten für das Stück nichts Besonderes, nur den am Ende aufgenommenen Balken bewegen müssen
1 „Gefällt mir“
Mir fehlten die Deklarationen über dem Hauptbuch, nachdem ich es hinzugefügt hatte, funktioniert es viel besser!
Der vollständige Code zur Erinnerung:
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 „Gefällt mir“
