Makro Baugrupper als Stl speichern (DS SolidWorks/SolidWorks)

Hallo Forum,
ich habe mir einst ein Makro geschrieben, mit dem ich alle Einzelteile eines definierten Ordners, automatisch in ein "STL" konvertieren kann. Das hat bisher auch super funktioniert. Nun wollte ich das Makro umschreiben, dass es mir nur Baugruppen in "STL" konvertiert. So weit so gut. Leider macht mein neuer Versuch nur fast das, was ich möchte. Es öffnet die Baugruppe, speichert aber leider alle verbauten Einzelteile als "STL" und nicht die Gruppe. Ich vermute meinen Fehler im markierten Bereich, stehe aber irgenwie auf dem Schlauch. Habt Ihr eine Idee was ich anders machen muss

Gruß Timo

Sub main()
Dim Datei1 As String
Dim swApp As Object
Dim swSelMgr As SldWorks.SelectionMgr
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Part As Object
Dim Pfad As String
Dim Title As String
Dim Name As String
Dim Ort As String
Dim a As Integer
Dim swModel As SldWorks.AssemblyDoc
Dim swComponent As SldWorks.Component2
Dim Components As Variant
Dim sComponents(0) As String ' List of components to select
Dim swDocSpecification As SldWorks.DocumentSpecification
Dim sName As String
Dim Version As String
Dim strBla As String
Dim Datum As String
Dim Zeit As String
Dim Log As String

'Logdatei erzeugen
Datum = Replace(Date, ".", "", , , vbTextCompare)
Zeit = Replace(Time, ":", "", , , vbTextCompare)
Log = "C:\SAPWorkDir\" & Datum & "-" & Zeit & ".txt"
Open Log For Output As #1
Print #1, "Folgende Modelle wurden konvertiert:"

'Baugruppen im Arbeitsverz. suchen
Datei1 = Dir("C:\SAPWorkDir\*.sldasm")
Do While Datei1 <> ""
Set swApp = Application.SldWorks

'Datei in SolidWorks öffnen
Set swDocSpecification = swApp.GetOpenDocSpec("C:\SAPWorkDir\" + Datei1)
Set swModel = swApp.OpenDoc7(swDocSpecification)
longstatus = swDocSpecification.Error
longwarnings = swDocSpecification.Warning

'SAP-Version auslesen
Version = swModel.GetCustomInfoValue("", "SAPVersion")

'Baugruppe als Stl speichern
Set Part = swApp.ActiveDoc
Set swSelMgr = Part.SelectionManager
Titel = Part.GetTitle
a = Len(Titel) - 7
Name = Left(Titel, a)
strBla = Name

'Name zusammensetzen
Ort = "C:\SAPWorkdir\" + Name + "[" + Version + "]" + ".STL"
longstatus = 0
longstatus = Part.SaveAs3(Ort, 0, 0)
boolstatus = swApp.CloseAllDocuments(True)
Print #1, strBla

'Nächste Datei
Datei1 = Dir
Loop
Close #1
End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP