Ich verwende 2 Makros: eines, um Einheits-STLs von jedem Körper in einem Raum zu erstellen. Und ein weiteres Makro, das eine vollständige STL der Datei, aber die gesamte Konfiguration ausführt.
Mein Wunsch ist es, ein Makro zu erstellen, das einheitliche STLs für jeden Körper aller Konfigurationen des Teils erstellen kann.
Ich bin auf SW2023 und verwende alte Makros. Aber ich weiß nicht, wie ich es modifizieren soll, um dies zu tun, können Sie mir dabei helfen?
Ich schicke Ihnen die 2 Makros im Betreff.
Option Explicit
Dim swApp As Object
Dim swPart As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim Indent As Long
Dim BodyFolderType(5) As String
Dim sModelName As String
Dim iNbCar As Integer
Dim boolstatus As Boolean
Dim fileName As String
Dim file2save As String
Dim swErrors As Long
Dim swWarnings As Long
Dim bRet As Boolean
Sub main()
BodyFolderType(0) = "dummy"
BodyFolderType(1) = "swSolidBodyFolder"
BodyFolderType(2) = "swSurfaceBodyFolder"
BodyFolderType(3) = "swBodySubFolder"
BodyFolderType(4) = "swWeldmentSubFolder"
BodyFolderType(5) = "swWeldmentCutListFolder"
Set swApp = Application.SldWorks
Set swPart = swApp.ActiveDoc
Call StlParam
Debug.Print "File = " & swPart.GetPathName
fileName = swPart.GetPathName
fileName = Strings.Left(fileName, Len(fileName) - 7)
Indent = -3
Set swFeat = swPart.FirstFeature
TraverseFeatures swFeat, True
End Sub
Function StlParam()
boolstatus = swApp.SetUserPreferenceToggle(swSTLBinaryFormat, True)
boolstatus = swApp.SetUserPreferenceIntegerValue(swExportStlUnits, 0)
boolstatus = swApp.SetUserPreferenceIntegerValue(swSTLQuality, swSTLQuality_e.swSTLQuality_Fine)
boolstatus = swApp.SetUserPreferenceToggle(swSTLShowInfoOnSave, True)
boolstatus = swApp.SetUserPreferenceToggle(swSTLComponentsIntoOneFile, True)
End Function
Function DoTheWork(thisFeat As SldWorks.Feature)
Dim IsBodyFolder As Boolean
IsBodyFolder = False
Dim FeatType As String
FeatType = thisFeat.GetTypeName
If FeatType = "SolidBodyFolder" Then IsBodyFolder = True
If IsBodyFolder Then
Debug.Print Format(String(Indent, " ") & thisFeat.Name, "!" & String(40, "@")); Format(FeatType, "!" & String(30, "@"));
Dim BodyFolder As SldWorks.BodyFolder
Set BodyFolder = thisFeat.GetSpecificFeature2
Dim BodyFolderTypeE As Long
BodyFolderTypeE = BodyFolder.Type
Debug.Print Format(BodyFolderType(BodyFolderTypeE), "!" & String(30, "@")); Format(BodyFolderTypeE, "!@@@@");
Dim BodyCount As Long
BodyCount = BodyFolder.GetBodyCount
Debug.Print "Body Count is " & BodyCount
Dim vBodies As Variant
vBodies = BodyFolder.GetBodies
Dim i As Long
If Not IsEmpty(vBodies) Then
For i = LBound(vBodies) To UBound(vBodies)
Dim Body As SldWorks.Body2
Set Body = vBodies(i)
sModelName = Body.Name
If InStr(sModelName, "[") <> 0 Then
iNbCar = Len(sModelName) - (Len(sModelName) - InStr(sModelName, "[")) - 1
sModelName = Left(sModelName, iNbCar)
End If
Debug.Print sModelName
boolstatus = swPart.Extension.SelectByID2(Body.Name, "SOLIDBODY", 0, 0, 0, False, 0, Nothing, 0)
file2save = fileName & " - " & sModelName & ".STL"
Debug.Print file2save
boolstatus = swPart.SaveToFile2(file2save, swSaveAsOptions_e.swSaveAsOptions_Silent, swErrors, swWarnings)
Set swPart = swApp.ActiveDoc
swApp.CloseDoc (swPart.GetTitle)
Set swPart = swApp.ActiveDoc
'swPart.ClearSelection2 True
Debug.Print Format(String(Indent + 3, " ") & Body.Name, "!" & String(30, "@"))
Next i
End If
Dim FeatureFromBodyFolder As SldWorks.Feature
Set FeatureFromBodyFolder = BodyFolder.GetFeature
If Not FeatureFromBodyFolder Is thisFeat Then
MsgBox "Features don't match!"
End If
Else
End If
End Function
Function TraverseFeatures(thisFeat As SldWorks.Feature, isTopLevel As Boolean)
Dim curFeat As SldWorks.Feature
Set curFeat = thisFeat
Indent = Indent + 3
While Not curFeat Is Nothing
DoTheWork curFeat
Dim subfeat As SldWorks.Feature
Set subfeat = curFeat.GetFirstSubFeature
While Not subfeat Is Nothing
TraverseFeatures subfeat, False
Dim nextSubFeat As SldWorks.Feature
Set nextSubFeat = subfeat.GetNextSubFeature
Set subfeat = nextSubFeat
Set nextSubFeat = Nothing
Wend
Set subfeat = Nothing
Dim nextFeat As SldWorks.Feature
If isTopLevel Then
Set nextFeat = curFeat.GetNextFeature
Else
Set nextFeat = Nothing
End If
Set curFeat = nextFeat
Set nextFeat = Nothing
Wend
Indent = Indent - 3
End Function
und
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim V As Variant
V = swApp.GetConfigurationNames(Part.GetPathName)
Dim i As Long
For i = 0 To UBound(V)
boolstatus = Part.ShowConfiguration2(V(i))
longstatus = Part.SaveAs3(Part.GetPathName & "-" & V(i) & ".STL", 0, 0)
Next
End Sub
