I got here a superb macro to save all the mep in pdf in a folder in 1 shot. On the other hand, I will need the name of the pdf to evolve with the index of the part. Ex: part " axe52 with index AB " becomes " axe52-AB.pdf " when recorded in pdf I do have a macro that does this but shot by shot, so when you have a lot of shots it takes a lot of time. If someone could help me make these 2 macros one macro would be great. In macro making I am a novice Thank you in advance for your help
Hello Here is the code from the two macros. I didn't add a control in case of absence of the "REVISION" property, if on the other hand the link is broken between the plan and the 3D or there is no model attached, the macro goes its way without creating the PDF (this can be changed by moving the End if). I also didn't add a check on whether or not the PDF file exists (and associated processing)
' Description:
' Traverses the open assembly and activates all components and their drawings (if of the
' same name).
Option Explicit
Dim fso As Scripting.FileSystemObject
Dim swApp As SldWorks.SldWorks
Dim myDwgDoc As SldWorks.ModelDoc2
Dim swDoc As SldWorks.ModelDoc2
Dim FirstDoc As SldWorks.ModelDoc2
Dim swRefDoc As SldWorks.ModelDoc2
Dim Part As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swExportPDFData As SldWorks.ExportPdfData
Dim swView As SldWorks.View
Dim swAllDocs As EnumDocuments2
Dim NumDocsReturned As Long
Dim DocCount As Long
Dim i As Long
Dim OpenWarnings As Long
Dim OpenErrors As Long
Dim lErrors As Long
Dim lWarnings As Long
Dim dummy As Boolean
Dim bDocWasVisible As Boolean
Dim boolstatus As Boolean
Dim sMsg As String
Dim DwgPath As String
Dim drwPathName As String
Dim pdfPathName As String
Dim pdfFolderName As String
Dim revision As String
Sub ShowAllOpenFiles()
Set swApp = Application.SldWorks
Set swAllDocs = swApp.EnumDocuments2
Set FirstDoc = swApp.ActiveDoc
DocCount = 0
swAllDocs.Reset
swAllDocs.Next 1, swDoc, NumDocsReturned
While NumDocsReturned <> 0
bDocWasVisible = swDoc.Visible
'swApp.ActivateDoc swDoc.GetPathName'
DwgPath = swDoc.GetPathName
If (LCase(Right(DwgPath, 3)) <> "drw") And (DwgPath <> "") Then
DwgPath = Left(DwgPath, Len(DwgPath) - 3) & "drw"
Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
If Not myDwgDoc Is Nothing Then
swApp.ActivateDoc myDwgDoc.GetPathName
pdfFolderName = "C:\pdf files\"
Set fso = CreateObject("Scripting.FileSystemObject")
If (Not fso.FolderExists(pdfFolderName)) Then
MkDir pdfFolderName
'MsgBox (pdfFolderName + " does not exist")
'Exit Sub
End If
Set Part = swApp.ActiveDoc()
Set swDraw = Part
Set swView = swDraw.GetFirstView 'active/récupère le fond de plan pour les propri perso
Set swView = swView.GetNextView 'active/récupère la première vue pour les propri perso
Set swRefDoc = swView.ReferencedDocument ' On a maintenant swRefDoc le 3D de la mise en plan
If Not swRefDoc Is Nothing Then 'Vérification si fichier rattaché à la vue existe (lien rompu par exemple)
revision = swRefDoc.GetCustomInfoValue("", "REVISION") ' on récupère la propriété revision
'You have a drawing active
drwPathName = Part.GetPathName()
If ("" = drwPathName) Then
' GetPathName() was empty
MsgBox ("This drawing has not been saved yet")
Exit Sub
End If
pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) + revision + ".pdf")
Debug.Print pdfPathName
Set swExportPDFData = swApp.GetExportFileData(1)
swExportPDFData.ViewPdfAfterSaving = False
Part.Extension.SaveAs pdfPathName, 0, 0, swExportPDFData, lErrors, lWarnings
End If 'Déplacer ce End If juste après revision = swRefDoc.GetCustomInfoValue("", "REVISION") si le pdf doit tout de même être généré
'MsgBox ("PDF file was created")
swApp.QuitDoc (Part.GetTitle)
Set myDwgDoc = Nothing
Set swRefDoc = Nothing
Set Part = Nothing
Set swDraw = Nothing
End If
End If
swAllDocs.Next 1, swDoc, NumDocsReturned
DocCount = DocCount + 1
Wend
swApp.ActivateDoc FirstDoc.GetPathName
Set FirstDoc = Nothing
Set swApp = Nothing
End Sub
Hello THANK YOU Cyril.f it works very well. Just one more thing, I like to have a dash between the name and the clue. Ex: name-AA I looked at your macro a little but I won't be able to say or add "-"
' Description:
' Traverses the open assembly and activates all components and their drawings (if of the
' same name).
Option Explicit
Dim fso As Scripting.FileSystemObject
Dim swApp As SldWorks.SldWorks
Dim myDwgDoc As SldWorks.ModelDoc2
Dim swDoc As SldWorks.ModelDoc2
Dim FirstDoc As SldWorks.ModelDoc2
Dim swRefDoc As SldWorks.ModelDoc2
Dim Part As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swExportPDFData As SldWorks.ExportPdfData
Dim swView As SldWorks.View
Dim swAllDocs As EnumDocuments2
Dim NumDocsReturned As Long
Dim DocCount As Long
Dim i As Long
Dim OpenWarnings As Long
Dim OpenErrors As Long
Dim lErrors As Long
Dim lWarnings As Long
Dim dummy As Boolean
Dim bDocWasVisible As Boolean
Dim boolstatus As Boolean
Dim sMsg As String
Dim DwgPath As String
Dim drwPathName As String
Dim pdfPathName As String
Dim pdfFolderName As String
Dim dxfPathName As String
Dim revision As String
Sub ShowAllOpenFiles()
Set swApp = Application.SldWorks
Set swAllDocs = swApp.EnumDocuments2
Set FirstDoc = swApp.ActiveDoc
DocCount = 0
swAllDocs.Reset
swAllDocs.Next 1, swDoc, NumDocsReturned
While NumDocsReturned <> 0
bDocWasVisible = swDoc.Visible
'swApp.ActivateDoc swDoc.GetPathName'
DwgPath = swDoc.GetPathName
If (LCase(Right(DwgPath, 3)) <> "drw") And (DwgPath <> "") Then
DwgPath = Left(DwgPath, Len(DwgPath) - 3) & "drw"
Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
If Not myDwgDoc Is Nothing Then
swApp.ActivateDoc myDwgDoc.GetPathName
pdfFolderName = "C:\pdf files\"
Set fso = CreateObject("Scripting.FileSystemObject")
If (Not fso.FolderExists(pdfFolderName)) Then
MkDir pdfFolderName
'MsgBox (pdfFolderName + " does not exist")
'Exit Sub
End If
Set Part = swApp.ActiveDoc()
Set swDraw = Part
Set swView = swDraw.GetFirstView 'active/récupère le fond de plan pour les propri perso
Set swView = swView.GetNextView 'active/récupère la première vue pour les propri perso
Set swRefDoc = swView.ReferencedDocument ' On a maintenant swRefDoc le 3D de la mise en plan
If Not swRefDoc Is Nothing Then 'Vérification si fichier rattaché à la vue existe (lien rompu par exemple)
revision = swRefDoc.GetCustomInfoValue("", "REVISION") ' on récupère la propriété revision
'You have a drawing active
drwPathName = Part.GetPathName()
If ("" = drwPathName) Then
' GetPathName() was empty
MsgBox ("This drawing has not been saved yet")
Exit Sub
End If
pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) & "-" & revision & ".pdf")
dxfPathName = Left(pdfPathName, Len(pdfPathName) - 3) & "dxf"
Debug.Print pdfPathName
Set swExportPDFData = swApp.GetExportFileData(1)
swExportPDFData.ViewPdfAfterSaving = False
Part.Extension.SaveAs pdfPathName, 0, 0, swExportPDFData, lErrors, lWarnings
boolstatus = Part.SaveAs4(dxfPathName, swSaveAsCurrentVersion, swSaveAsOptions_Silent, lErrors, lWarnings)
End If 'Déplacer ce End If juste après revision = swRefDoc.GetCustomInfoValue("", "REVISION") si le pdf doit tout de même être généré
'MsgBox ("PDF file was created")
swApp.QuitDoc (Part.GetTitle)
Set myDwgDoc = Nothing
Set swRefDoc = Nothing
Set Part = Nothing
Set swDraw = Nothing
End If
End If
swAllDocs.Next 1, swDoc, NumDocsReturned
DocCount = DocCount + 1
Wend
swApp.ActivateDoc FirstDoc.GetPathName
Set FirstDoc = Nothing
Set swApp = Nothing
End Sub
No need to say sorry Cyril.f I'm already super happy to have your help. The macro works VERY WELL, it will change the life of my new colleagues. I've been on solidworks for barely 3 months, but I have 25 years of Creo behind me.
