Unten ist ein Code, der geeignet sein sollte,
Hier werden die Unterordner dwg, pdf und step in Bezug auf den Arbeitsordner deklariert, mit prp revision
Die prp-Revision und die Konfiguration für den Schritt kamen von dort
So kann das Blatt mit mehreren verschiedenen Komponenten umgehen (ansonsten lade ich Sie ein, eine neue Station für den Schritt zu öffnen)
Auf meiner Seite füge ich für die Blechschnitte immer ein Maß hinzu, damit mein Nesting-Kollege jeden Skalierungsfehler überprüfen und mir melden kann (man weiß nie)
'----------------------------------------------------------------------------
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swdrawing As DrawingDoc
Dim spathname As String
Dim nErrors As Long
Dim nWarnings As Long
Dim bRet As Boolean
Const dxfSubFolder As String = "\dwg"
Const pdfSubFolder As String = "\pdf"
Const stepSubFolder As String = "\step"
Const prpRevision As String = "indice"
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swdrawing = swModel
swApp.SetUserPreferenceIntegerValue swUserPreferenceIntegerValue_e.swDxfOutputNoScale, 1
swApp.SetUserPreferenceDoubleValue swDxfOutputScaleFactor, getScaleFactor()
Dim path As String, name As String, configuration As String, revision As String
Dim model As ModelDoc2
getParameters model, configuration, revision, prpRevision
name = getPathName(swModel)(0)
name = name + "_" + revision
path = getPathName(swModel)(1)
Dim newPath As String
Select Case MsgBox("Saving folder is : " + name + Chr(10) + "Export configuration for STEP is : " + configuration + Chr(10) + "working folder is : " + path + Chr(10) + Chr(10) + "press yes to save , no to browse for path or cancel to abort", vbYesNoCancel)
Case 7
path = browseFolder(path)
Case 2
End
End Select
createpath path + dxfSubFolder
savedrawingasdxf path + dxfSubFolder + "\" + name
createpath path + pdfSubFolder
savedrawingaspdf path + pdfSubFolder + "\" + name
createpath path + stepSubFolder
savedrawingasstep model, configuration, path + stepSubFolder + "\" + name
swApp.SendMsgToUser2 "Finish", swMbInformation, swMbOk
End Sub
Sub createpath(path As String)
Dim fold As Variant
Dim cpath As String
For Each fold In Split(path, "\", -1, vbTextCompare)
cpath = cpath + CStr(fold) + "\"
If Len(Dir(cpath, vbDirectory)) = 0 Then MkDir cpath
Next fold
End Sub
Sub savedrawingasdxf(path As String)
bRet = swModel.Extension.SaveAs(path + ".dwg", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings)
If bRet = False Then
swApp.SendMsgToUser2 "Problems saving file as dxf.", swMbWarning, swMbOk
End If
End Sub
Sub savedrawingaspdf(path As String)
Dim expdata As ExportPdfData
Set expdata = swApp.GetExportFileData(1)
expdata.SetSheets 2, Nothing
bRet = swModel.Extension.SaveAs(path + ".pdf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, expdata, nErrors, nWarnings)
If bRet = False Then
swApp.SendMsgToUser2 "Problems saving file as pdf.", swMbWarning, swMbOk
End If
End Sub
Sub savedrawingasstep(model As ModelDoc2, conf As String, path As String)
If model Is Nothing Then Exit Sub
Set model = swApp.ActivateDoc3(model.getPathName, False, 1, nErrors)
model.ShowConfiguration2 conf
bRet = model.Extension.SaveAs(path + ".step", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings)
If bRet = False Then
swApp.SendMsgToUser2 "Problems saving file as step.", swMbWarning, swMbOk
End If
swApp.CloseDoc model.GetTitle
End Sub
Function getScaleFactor() As Double
Dim sview As View
Dim scalfactor As Double
Set sview = swdrawing.GetFirstView
scalfactor = sview.ScaleRatio(1) / sview.ScaleRatio(0)
Set sview = sview.GetNextView
Do While Not sview Is Nothing
If sview.IsFlatPatternView Then
scalfactor = sview.ScaleRatio(1) / sview.ScaleRatio(0)
Exit Do
End If
Set sview = sview.GetNextView
Loop
getScaleFactor = scalfactor
End Function
Function getPathName(model As ModelDoc2) As Variant
Dim pathname(1) As String
Dim spathname As String
spathname = model.getPathName
If spathname = "" Then
swApp.SendMsgToUser2 "Please save file then retry.", swMbStop, swMbOk
End
End If
spathname = Left(spathname, Len(spathname) - 7)
pathname(0) = Right(spathname, Len(spathname) - InStrRev(spathname, "\", -1, vbTextCompare))
pathname(1) = Left(spathname, InStrRev(spathname, "\", -1, vbTextCompare) - 1)
getPathName = pathname
End Function
Sub getParameters(ByRef model As ModelDoc2, ByRef configuration As String, ByRef revision As String, Optional prp As String = "revision")
Dim ssheet As Sheet, csheet As Sheet
Set csheet = swdrawing.GetCurrentSheet()
Set ssheet = csheet
Dim prpDoc As Boolean
prpDoc = ssheet.GetProperties2()(7)
If prpDoc = True Then
swdrawing.ActivateSheet swdrawing.GetSheetNames()(0)
Set ssheet = swdrawing.GetCurrentSheet()
End If
Dim prpsheet As String
prpsheet = ssheet.CustomPropertyView
Dim sview As View
If prpsheet = "Par défaut" Then
Set sview = swdrawing.GetFirstView
Set sview = sview.GetNextView
Else
Dim views As Variant
Dim found As Boolean
found = False
views = swdrawing.GetViews()
Dim i As Long
For i = 0 To UBound(views)
If UBound(views(i)) = 0 Or found = True Then Exit For
Dim j As Long
For j = 1 To UBound(views(i))
Set sview = views(i)(j)
If sview.GetName2() = prpsheet Then
found = True
Exit For
End If
Next j
Next i
End If
swdrawing.ActivateSheet csheet.GetName
If sview Is Nothing Then Exit Sub
Set model = sview.ReferencedDocument
Dim scustomprpmgr As CustomPropertyManager
configuration = sview.ReferencedConfiguration
If sview.IsFlatPatternView Then
Dim confvf As configuration
Set confvf = model.GetConfigurationByName(configuration)
Set confvf = confvf.GetParent()
configuration = confvf.name
End If
Set scustomprpmgr = model.Extension.CustomPropertyManager(configuration)
Dim svOut As String
Dim sWRout As Boolean
Dim sLPout As Boolean
Dim srevision As String
'scustomprpmgr.Get6 prp, False, svOut, srevision, sWRout, sLPout
scustomprpmgr.Get5 prp, False, svOut, srevision, sWRout
revision = srevision
End Sub
Function browseFolder(defpath As String) As String
browseFolder = defpath
Dim obgShell As Object
Dim obgFolder As Object
Set obgShell = CreateObject("shell.application")
Set obgFolder = obgShell.browseforfolder(0, "", 0)
If Not obgFolder Is Nothing Then
browseFolder = obgFolder.self.path
End If
Set obgShell = Nothing
End Function
