Witam
Chcę zmodyfikować makro znalezione w internecie, które prawdopodobnie nigdy nie zostało ukończone.
Celem byłaby modyfikacja nieruchomej powierzchni części arkusza blachy poprzez zaoferowanie użytkownikowi możliwości wyboru własnej powierzchni na modelu 3D.
Mimo, że chodzę po okolicy od 2 dni, przyznam, że trochę przesycham.
Oto zmodyfikowane 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
Oryginalny temat makra:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/?_gl=1n52pes_gaMjcxNTI5NDczLjE2NDAwNjkyNDQ._ga_XQJPQWHZHH*MTY3MzQyNzE4NC43Mi4wLjE2NzM0MjcyNTAuNjAuMC4w#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:koHtH74aQp2V8jPiw2IwYQ
W przeciwnym razie dla jedynego linku API znalezionego na ten temat:
https://help.solidworks.com/2020/english/api/sldworksapi/get_fixed_face_of_sheet_metal_part_example_vb.htm?verRedirect=1
Jeśli masz choć trochę tropów, to jestem bardzo zainteresowany.
Z góry dziękuję.
Sebastian
W makrze może wystąpić błąd, ponieważ nie pozwala ono użytkownikowi na wybranie własnej powierzchni na modelu 3D. Istnieją sekcje kodu z komentarzami, które zawierają instrukcje dotyczące wybierania określonej twarzy, ale te komentarze nie są używane. Te komentarze powinny umożliwiać użytkownikowi wybranie twarzy przed uruchomieniem makra, ale ponieważ są one oznaczone jako komentarze, nie są używane, a makro domyślnie nadal używa stałej powierzchni. Sekcje kodu, które mają zostać odkomentowane, to:
'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
I
Set swFixedFace = seltype
Klasa A+
1 polubienie
Tak, próbowałem już usunąć komentarz, ale nie dostałem tego, czego chciałem. Ani podstawowy użytkownik, który zamieścił pytanie. Zostawiłem ten kod jako komentarz, ponieważ może on pomóc w debugowaniu początkowego kodu.
1 polubienie
A co, jeśli spróbujesz z tym? Ten kod służy do sprawdzania, czy użytkownik wybrał twarz przed kontynuowaniem uruchamiania makra:
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
Ponadto w makrze musi być zdefiniowany parametr swconst.
Następnie można użyć wyboru, aby ustawić stałą powierzchnię w funkcji Rozwinięcie blachy:
Set swFlatPatt = swFeat.GetDefinition
bRet = swFlatPatt.AccessSelections(swModel, Nothing)
Set swFixedFace = seltype
bRet = swFixedFace.Select4(True, selectData)
1 polubienie
Witam @tous
W załączeniu dwie funkcje, które opracowałem dla jednego z moich projektów
Treść jest obsługiwana przez 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 polubienia
Pierwsza funkcja lokalizuje stan rozłożenia dla obiektu wieloobiektowego
Zakłada się, że ściana została wybrana przed nazwaniem funkcji.
Jeśli chcesz poczekać na wybór, daj mi znać 
Początkowe rozwiązanie nie działa, selekcja jest wykonana dobrze, ale twarz nie jest tak modyfikowana.
Aby uzyskać @Lynkoa15 rozwiązanie, przyjrzę się, jak to wygląda.
Z drugiej strony nie ma dla nas części wielobryłowej jeden arkusz = jedna część.
Chodzi o to, aby przejść przez selekcję po fakcie, ponieważ ma to być zaimplementowane w istniejącym makrze, więc nie jest możliwe wybranie twarzy w 1.
W każdym razie, dziękuję wam 2 za utwory i nadal kopię po swojej stronie!
W ZAŁĄCZENIU 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 polubienie
Dzięki @Lynkoa15 , właśnie wypróbowałem twój najnowszy kod i utknął na linii w kolorze żółtym (błąd 424-Wymagany obiekt):
Jednak dobrze wybrałem swoją twarz, a DoEvents (którego nie znałem) dobrze spełnia swoje zadanie.
W razie potrzeby dołączyłem swoją część do testowania (sw2020)
Pozycja1.SLDPRT (250.3 KB)
U mnie to działa
Czy przykleiłeś ciemny model swmodel przed funkcją main()?
Upewnij się, że wskaźnik myszy i w funkcji main() (czasami kompilator próbuje wykonać bieżącą funkcję)
W przeciwnym razie dla kawałka nic szczególnego wystarczy przesunąć drążek zajęty na końcu
1 polubienie
Brakowało mi deklaracji powyżej głównego, po dodaniu działa to o wiele lepiej!
Pełny kod dla przypomnienia:
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 polubienie
