Code:
Option ExplicitDim swApp As SldWorks.SldWorks
Dim swDocument As SldWorks.ModelDoc2
Dim Part As Object 'gyro
Dim Conf As Object 'für Erweiterung Konfigurationsnamen
Dim bRet As Boolean
Dim strDateiname As String
Dim strNEWDateiname As String
Dim strDateinameLang As String
Dim strPfad As String
Dim strNEWPfad As String
Dim subfolder As String
Dim strExtension As String
Dim PartXtension As String
Dim strMsgtxt As String ' nur wenn TestMessagebox eingeschaltet ist notwendig
Dim ZeitAlsDateiname As String
Dim Zeit1 As String
Dim Tag As String
Dim Monat As String
Dim Jahr As String
Dim StartConfigName As String 'für Erweiterung Konfigurationsnamen
Dim ConfName As String 'für Erweiterung Konfigurationsnamen
Dim i As Long
Dim intReturn As Integer
Sub main()
' Namen des Unterordners festlegen und Extension
subfolder = "05_asm2prt\"
' Zeit holen und von Sonder- und Leerzeichen befreien...
Zeit1 = Now
ZeitAlsDateiname = Zeit1
ZeitAlsDateiname = Left(ZeitAlsDateiname, 10)
Tag = Left(ZeitAlsDateiname, 2)
Monat = Left(ZeitAlsDateiname, 5)
Monat = Right(Monat, 2)
Jahr = Right(ZeitAlsDateiname, 4)
ZeitAlsDateiname = Jahr & "-" + Monat & "-" + Tag
If Left(ZeitAlsDateiname, 1) = " " Then ZeitAlsDateiname = Right(ZeitAlsDateiname, Len(ZeitAlsDateiname) - 3)
' Anbindung an SWX
Set swApp = Application.SldWorks
Set swDocument = swApp.ActiveDoc
' Abbrechen, wenn gar kein SolidWorks-Dokument geöffnet
If swDocument Is Nothing Then End
' Dateinamen inkl. Pfad holen
strDateinameLang = swDocument.GetPathName ' Dateinmae inkl. Pfad holen
If strDateinameLang = "" Then ' prüfen ob gespeichert oder nicht (leer)
MsgBox ("Datei muß zuerst gespeichert werden!")
End
End If
' Zerlegen in Pfad und Dateiname ohne Extension (7 Zeichen)
For i = Len(strDateinameLang) To 1 Step -1
If Mid(strDateinameLang, i, 1) = "\" Then
strPfad = Left(strDateinameLang, i)
strDateiname = Mid(strDateinameLang, i + 1, Len(strDateinameLang) - i - 7)
Exit For
End If
Next i
' Pfad zum Unterverzeichnis zusammensetzen
strNEWPfad = strPfad + subfolder
' Prüfung, ob das Verzeichnisse existiert, da es sonst angelegt
' werden muss
If Len(Dir(strNEWPfad, vbDirectory)) = 0 Then
MkDir (strNEWPfad)
End If
PartXtension = ".SLDPRT"
' bRet = swApp.SetUserPreferenceIntegerValue(swStepAP, 214)
Set Conf = Part.GetActiveConfiguration ' Aktive Konfig auslesen_02-02-2023
StartConfigName = Conf.Name ' Aktive Konfig merken_02-02-2023
' neuen Pfad mit Dateinamen und richtiger Extesion zusammensetzen
strNEWDateiname = strNEWPfad & strDateiname & "_#" & StartConfigName & "_#" & ZeitAlsDateiname & PartXtension
' Speicherfunktion
Set Part = swApp.ActiveDoc
Part.SaveAs3 strNEWDateiname, 0, 0
MsgBox ("erfolgreich gespeichert: " & strNEWDateiname)
End Sub
Foren auf CAD.de (alle Foren)
| 
. Bei jedem weiteren Start hab ich einen Fehler in der Zeile "Set Conf = Part.GetActiveConfiguration" 
.
