Ich bin auf der Suche nach einer Möglichkeit, meine ersten 2 Blätter " ZUSAMMEN " und " VERKABELUNG " in pdf zu drucken und dann mein 3. Blatt " FLAN AV " auf ein anderes pdf, diese müssen im Zeichnungsordner gespeichert werden, das erste pdf wird den Namen der Zeichnung haben, z.B. P615PL702700 und das zweite wird das gleiche haben, aber anstelle des letzten Zeichens (hier eine 0) haben wir ein 1.
Ich habe es geschafft, alle Blätter in zwei separaten PDFs zu bekommen, aber jedes Mal habe ich die 3 Blätter und nicht 2 + 1.
Ich verstehe, aber das Ziel hier ist es, ein Makro zu erstellen, um diese Aufnahme schneller und wiederholbar über etwa 200 Dateien zu machen, ich möchte eine Makroschaltfläche erstellen, die alles speichert.
Mit diesem Code nähere ich mich dem gewünschten Ergebnis:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swExportPDFData As SldWorks.ExportPdfData
Dim boolstatus As Boolean
Dim Filename As String
Dim lErrors As Long
Dim lWarnings As Long
Dim strSheetName() As String
Dim varSheetName As Variant
'
Dim swDraw As SldWorks.DrawingDoc
Dim vSheetNames As Variant
'
Dim Part As Object
Dim longstatus As Long, longwarnings As Long
Dim File As String
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
' ajout controle du bon fichier
If Part Is Nothing Then
MsgBox "Aucun fichier n'est actuellement ouvert."
Exit Sub ' If no model is currently loaded, then exit
End If
' Determine the document type. If the document is a drawing, then send a message to the user.
If (Part.GetType <> 3) Then '1Part 2Assembly 3Document
MsgBox "Cette macro ne s'applique que sur une mise en plan"
Exit Sub
End If
File = Part.GetPathName
If File = "" Then
MsgBox "Cette macro necessite que le fichier soit préalablement enregistré"
Exit Sub
End If
Dim Filepath As String
Dim Filename As String
Filepath = Left(File, InStrRev(File, "\"))
Filename = Mid(File, Len(Filepath) + 1, Len(File) - (7 + Len(Filepath)))
Set swModelDocExt = Part.Extension
Set swExportPDFData = swApp.GetExportFileData(1)
Set swDraw = Part
vSheetNames = swDraw.GetSheetNames
If swExportPDFData Is Nothing Then MsgBox "Nothing"
boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, vSheetNames(0))
swExportPDFData.ViewPdfAfterSaving = True
boolstatus = swModelDocExt.SaveAs(Filepath & "\" & Filename & ".PDF", 0, 0, swExportPDFData, lErrors, lWarnings)
End Sub
Hier hingegen spart es mir nur das Blatt (0), das erste,
Nun, wenn wir nicht alle Daten in der Erklärung haben, ist es nicht einfach, Ihre Erwartungen richtig zu erfüllen... aber ein Arbeitspfad ist auf der Solidworks Website (dem Forum) verfügbar:
' ------------------------------------------------------------------------------
' Written by: Deepak Gupta (http://gupta9665.com/)
' -----------------------------------------------------------------------------
' Version 2: Added option for selecting Output folder ------------- 08/07/14
' Version 2.1: Added revision in file name ------------- 01/20/15
Option Explicit
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder = "Desktop")
If Not F Is Nothing Then
BrowseFolder = F.Items.Item.Path
End If
End Function
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim vSheetNameArr As Variant
Dim vSheetName As Variant
Dim bRet As Boolean
Dim swExportPDFData As SldWorks.IExportPdfData
Dim lErrors As Long
Dim lWarnings As Long
Dim Path As String
Dim Value As String
Set swApp = Application.SldWorks
Path = BrowseFolder("Select a Path/Folder")
If Path = "" Then
MsgBox "Please select the path and try again"
End
Else
Path = Path & "\"
End If
Set swModel = swApp.ActiveDoc
' Is document active?
If swModel Is Nothing Then
swApp.SendMsgToUser2 "A Drawing document must be active.", swMbWarning, swMbOk
Exit Sub
End If
' Is it a Drawing document?
If swModel.GetType <> swDocDRAWING Then
swApp.SendMsgToUser2 "A Drawing document must be active.", swMbWarning, swMbOk
Exit Sub
End If
Set swDraw = swModel
Value = swDraw.CustomInfo("Revision")
Set swSheet = swDraw.GetCurrentSheet
vSheetNameArr = swDraw.GetSheetNames
Dim numberOfSheets As Integer
numberOfSheets = swModel.GetSheetCount
Dim i As Integer
i = 0
Dim sales(0) As Variant
Dim fab(1) As Variant
MsgBox vSheetNameArr(0)
Set swExportPDFData = swApp.GetExportFileData(1)
Do While i < numberOfSheets
sales(0) = vSheetNameArr(i)
fab(0) = vSheetNameArr(i + 1)
fab(1) = vSheetNameArr(i + 2)
swExportPDFData.SetSheets swExportData_ExportSpecifiedSheets, sales
swModel.Extension.SaveAs Path & sales(0) & ".PDF", 0, 0, swExportPDFData, lErrors, lWarnings
swExportPDFData.SetSheets swExportData_ExportSpecifiedSheets, fab
swModel.Extension.SaveAs Path & fab(0) & " & QC " & ".PDF", 0, 0, swExportPDFData, lErrors, lWarnings
i = i + 3
Loop
End Sub
Was mich betrifft, so dachte ich, dass ich klar war, als ich fragte.
Ich habe es endlich geschafft, eine Lösung zu finden, nachdem ich mehrere gefundene Codes zusammengeführt habe.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swExportPDFData As SldWorks.ExportPdfData
Dim boolstatus As Boolean
Dim Filename As String
Dim lErrors As Long
Dim lWarnings As Long
Dim strSheetName(4) As String
Dim varSheetName As Variant
Dim swDraw As SldWorks.DrawingDoc
Dim vSheetNames As Variant
Dim Part As Object
Dim longstatus As Long, longwarnings As Long
Dim File As String
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
File = Part.GetPathName
Dim Filepath As String
Dim Filename As String
Dim Filename2 As String
Filepath = Left(File, InStrRev(File, "\"))
Filename = Mid(File, Len(Filepath) + 1, Len(File) - (7 + Len(Filepath)))
Filename2 = Filename2 = Left(Filename, Len(Filename) - 1) & "1"
Dim PartName As String
PartName = Part.GetTitle
PartName = Split(PartName, " - ")(0) ' Résultat : "P615PL702700"
Dim PartNameAlt As String
PartNameAlt = Left(PartName, Len(PartName) - 1) & "1" ' P615PL702701
Set swModelDocExt = Part.Extension
Set swExportPDFData = swApp.GetExportFileData(1)
Set swDraw = Part
strSheetName(0) = "ENSEMBLE"
strSheetName(1) = "CABLAGE"
vSheetNames = strSheetName
If swExportPDFData Is Nothing Then MsgBox "Nothing"
boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, vSheetNames)
boolstatus = swModelDocExt.SaveAs(Filepath & "\" & PartName & ".PDF", 0, 0, swExportPDFData, lErrors, lWarnings)
strSheetName(0) = "FLAN AV"
strSheetName(1) = ""
vSheetNames = strSheetName
boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, vSheetNames)
boolstatus = swModelDocExt.SaveAs(Filepath & "\" & PartNameAlt & ".PDF", 0, 0, swExportPDFData, lErrors, lWarnings)
End Sub