Code:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim sModelName As String
Dim sName As String
Dim sPath As String
Dim bRebuild As Boolean
Dim bRet As Boolean
Dim sRev As String
Dim stepFilename As String
Dim dxfFilename As String
Dim oframe As SldWorks.Frame
Dim varAlignment As Variant
Dim dataAlignment(11) As Double
Dim options As Long
Dim swBody As Body2
Dim varBodies As Variant
Dim Boolstat As Boolean
Dim i As Integer
Sub SaveAsStep()
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
Set oframe = swApp.Frame
If swModel Is Nothing Then
swApp.SendMsgToUser2 "Kein(e) Teil/Baugruppe offen", swMbWarning, swMbOk
Exit Sub
End If
If swModel.GetType = swDocDRAWING Then
swApp.SendMsgToUser2 "Kein(e) Teil/Baugruppe offen", swMbWarning, swMbOk
Exit Sub
End If
bRebuild = swModel.ForceRebuild3(True)
sName = swModel.CustomInfo("PartNo")
sRev = swModel.CustomInfo("Revision") 'Revision Property Name
sPath = "C:\Dokumente\" 'Dateipfad Ausgabeordner
stepFilename = sPath & sName & "-REV-" & sRev & ".step"
swModel.SaveAs (stepFilename)
If isBlocked(stepFilename) Then
Status "Fehler beim Speichern als " & stepFilename
MsgBox "Fehler!" & vbCrLf & sName & "-REV-" & sRev & ".step" & " konnte nicht gespeichert werden!" & vbCrLf & "Step-Datei existiert bereits!", vbCritical, "ERROR"
Exit Sub
End If
Set swPart = swModel
varBodies = swPart.GetBodies2(swBodyType_e.swSolidBody, False)
For i = 0 To UBound(varBodies)
Set swBody = varBodies(i)
If (swBody.IsSheetMetal) Then
dxfFilename = sPath & sName & "-REV-" & sRev & ".dxf"
sModelName = swModel.GetPathName
Set swPart = swModel
dataAlignment(0) = 0#
dataAlignment(1) = 0#
dataAlignment(2) = 0#
dataAlignment(3) = 0#
dataAlignment(4) = 0#
dataAlignment(5) = 0#
dataAlignment(6) = 0#
dataAlignment(7) = 1#
dataAlignment(8) = 0#
dataAlignment(9) = 0#
dataAlignment(10) = 0#
dataAlignment(11) = 0#
varAlignment = dataAlignment
options = 5 ' This value determines what would be exported in the DXF/DWG file.
swPart.ExportToDWG2 dxfFilename, sModelName, swExportToDWG_ExportSheetMetal, True, varAlignment, False, False, options, Null
Else
End If
Next i
Exit Sub
End Sub
Function isBlocked(filename As String) As Boolean
On Error GoTo Fehler
Open filename For Append As #1
Close #1
isBlocked = False
On Error GoTo 0
Exit Function
Fehler:
isBlocked = True
On Error GoTo 0
End Function
Sub Status(txt As String)
If txt = "" Then Exit Sub
oframe.SetStatusBarText ("SAVE (SLDPRT/SLDASM + STEP): " & txt)
End Sub