Exporteer afzonderlijke bladen van een tekening naar PDF

Hoi allemaal

Ik ben op zoek naar een manier om mijn eerste 2 vellen " SAMEN " en " BEKABELING " in pdf af te drukken en vervolgens mijn 3e vel " FLAN AV " op een andere pdf, deze moeten worden opgeslagen in de tekenmap, de eerste pdf zal de naam van de tekening hebben, bijvoorbeeld P615PL702700 en de tweede zal hetzelfde hebben, maar in plaats van het laatste teken (hier een 0) zullen we een 1.

Het is me gelukt om alle vellen op twee afzonderlijke pdf's te krijgen, maar elke keer heb ik de 3 vellen en niet 2 + 1.

Bij voorbaat dank

Hallo:
Voor het combineren van bestaande PDF-bestanden of bij het printen gebruik ik PDF_Redirect...
Zien:

Ik zie het, maar het doel hier is om een macro te maken om deze opname sneller en herhaalbaar te maken over ongeveer 200 bestanden, ik wil een macroknop maken die alles opslaat.

Met deze code benader ik het gewenste resultaat:

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 daarentegen scheelt het me alleen het blad (0), het eerste

Welnu, als we niet alle gegevens in de verklaring hebben, is het niet eenvoudig om correct aan uw verwachtingen te voldoen...
maar een werkpad is beschikbaar op de Solidworks-website (het forum):

Geschreven door: @Deepak_Gupta :

' ------------------------------------------------------------------------------
' 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

Zoveel voor mij, ik dacht dat ik duidelijk was geweest toen ik het vroeg.

Ik ben er eindelijk in geslaagd om een oplossing te vinden na het samenvoegen van verschillende gevonden codes.

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
1 like