Hallo
Ik ben op zoek naar een macro die ik op internet heb gevonden, die waarschijnlijk nooit is afgemaakt.
Het doel zou zijn om het vaste vlak van een plaatwerkonderdeel aan te passen door de gebruiker de mogelijkheid te bieden zijn eigen gezicht te kiezen op het 3D-model.
Ook al loop ik al 2 dagen rond, ik geef toe dat ik een beetje aan het opdrogen ben.
Hier is de gewijzigde macro:
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
Het oorspronkelijke macro-onderwerp:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/?_gl=1n52pes_gaMjcxNTI5NDczLjE2NDAwNjkyNDQ._ga_XQJPQWHZHH*MTY3MzQyNzE4NC43Mi4wLjE2NzM0MjcyNTAuNjAuMC4w#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:koHtH74aQp2V8jPiw2IwYQ
Anders voor de enige API-link die over het onderwerp is gevonden:
https://help.solidworks.com/2020/english/api/sldworksapi/get_fixed_face_of_sheet_metal_part_example_vb.htm?verRedirect=1
Als je ook maar aanknopingspunten hebt, ben ik zeer geïnteresseerd.
Bij voorbaat dank.
Sebastian
Er kan een fout in de macro zitten omdat de gebruiker niet zijn eigen gezicht op het 3D-model kan kiezen. Er zijn codesecties met opmerkingen die instructies bevatten voor het selecteren van een specifiek gezicht, maar deze opmerkingen worden niet gebruikt. Deze opmerkingen moeten de gebruiker in staat stellen een gezicht te selecteren voordat de macro wordt uitgevoerd, maar omdat ze worden becommentarieerd, worden ze niet gebruikt en blijft de macro standaard het vaste gezicht gebruiken. De codesecties die niet van commentaar moeten worden voorzien, zijn:
'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
En
Set swFixedFace = seltype
een+
1 like
Ja, ik heb al geprobeerd om te de-reageren, maar ik kreeg niet wat ik wilde. Noch de basisgebruiker die de vraag heeft gepost. Ik heb deze code becommentarieerd gelaten omdat het kan helpen bij het debuggen van de initiële code.
1 like
Wat als je dat probeert? Deze code wordt gebruikt om te controleren of de gebruiker een gezicht heeft geselecteerd voordat de macro wordt uitgevoerd:
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
Bovendien moet swconst in uw macro worden gedefinieerd.
Vervolgens kunt u de selectie gebruiken om het vaste gezicht in de FlatPattern-functie in te stellen:
Set swFlatPatt = swFeat.GetDefinition
bRet = swFlatPatt.AccessSelections(swModel, Nothing)
Set swFixedFace = seltype
bRet = swFixedFace.Select4(True, selectData)
1 like
Hallo @tous
Bijgevoegd zijn twee functies die ik heb ontwikkeld voor een van mijn projecten
Het lichaam wordt ondersteund door 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 likes
De eerste functie lokaliseert de uitgevouwen toestand voor een multibody
Het gezicht wordt verondersteld te zijn geselecteerd voordat de functie een naam krijgt.
Als je wilt wachten op een selectie, laat het me weten 
De eerste oplossing werkt niet, de selectie is goed gedaan, maar het gezicht is niet op deze manier gewijzigd.
Voor jouw @Lynkoa15 oplossing kijk ik hoe het eruit ziet.
Aan de andere kant, geen multibody deel voor ons, één vel = één deel.
En het idee is om een selectie achteraf te doorlopen, omdat het in een bestaande macro moet worden geïmplementeerd, dus het is niet mogelijk om het gezicht op de 1e te selecteren.
In ieder geval, bedankt aan jullie 2 voor de tracks en ik blijf graven aan mijn kant!
INGESLOTEN MINIMAAL
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 like
Bedankt @Lynkoa15 , ik heb net je nieuwste code geprobeerd en het loopt vast op de regel in geel (fout 424-Object vereist):
Ik heb mijn gezicht echter goed geselecteerd en de DoEvents (die ik niet kende) doet het werk goed.
Ik heb mijn onderdeel bevestigd om indien nodig te testen (sw2020)
Item1.SLDPRT (250.3 KB)
Voor mij werkt het
Heb je de dim swmodel gelijmd voor de main() functie
Zorg ervoor dat de muisaanwijzer en in de main() functie (soms probeert de compiler de huidige functie uit te voeren)
Anders hoeft voor het stuk niets bijzonders te worden verplaatst, maar de balk die aan het einde wordt opgenomen
1 like
Ik miste de declaraties boven de hoofd, na het toevoegen werkt het veel beter!
De volledige code ter herinnering:
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 like
