Cze wszystkim
Szukam sposobu na wydrukowanie moich pierwszych 2 arkuszy " RAZEM " i " OKABLOWANIE " w pdf, a następnie mojego 3 arkusza " FLAN AV " na innym pliku PDF, muszą one być zapisane w folderze rysunków, pierwszy plik pdf będzie miał nazwę rysunku np. P615PL702700 a drugi będzie miał to samo, ale zamiast ostatniego znaku (tutaj 0) będziemy mieli 1.
Udało mi się wyciągnąć wszystkie arkusze na dwóch oddzielnych plikach pdf, ale za każdym razem mam 3 arkusze, a nie 2 + 1.
Z góry dziękuję
Witam:
Do łączenia istniejących plików PDF lub podczas drukowania używam PDF_Redirect...
Widzieć:
Rozumiem, ale celem tutaj jest stworzenie makra, aby to nagranie było szybsze i powtarzalne na około 200 plikach, chcę zrobić przycisk makra, który wszystko zapisuje.
Zbliżam się do pożądanego rezultatu za pomocą tego kodu:
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
Tutaj z drugiej strony oszczędza mi tylko arkusz (0) pierwszy
Cóż, jeśli nie mamy wszystkich danych w zestawieniu, nie jest łatwo poprawnie spełnić Twoje oczekiwania...
ale ścieżka robocza jest dostępna na stronie internetowej Solidworks (na forum):
Napisane przez: @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
Jeśli chodzi o mnie, wydawało mi się, że wyraziłem się jasno, kiedy zapytałem.
W końcu udało mi się znaleźć rozwiązanie po scaleniu kilku znalezionych kodów.
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