Ik heb hier een prachtige macro om alle MEP in pdf op te slaan in een map in 1 shot. Aan de andere kant heb ik de naam van de pdf nodig om mee te evolueren met de index van het onderdeel. Voorbeeld: onderdeel " axe52 met index AB " wordt " axe52-AB.pdf " wanneer het in pdf is opgenomen Ik heb wel een macro die dit doet, maar shot voor shot, dus als je veel shots hebt, kost het veel tijd. Als iemand me zou kunnen helpen deze 2 macro's te maken, zou een macro geweldig zijn. In het maken van macro's ben ik een beginneling Bij voorbaat dank voor uw hulp
Hallo Hier is de code van de twee macro's. Ik heb geen besturingselement toegevoegd in geval van afwezigheid van de eigenschap "REVISIE", als aan de andere kant de link tussen het plan en de 3D is verbroken of als er geen model is bijgevoegd, gaat de macro zijn weg zonder de PDF te maken (dit kan worden gewijzigd door het einde te verplaatsen als). Ik heb ook geen controle toegevoegd of het PDF-bestand al dan niet bestaat (en de bijbehorende verwerking)
' 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
Hallo BEDANKT Cyril.f het werkt heel goed. Nog één ding, ik vind het leuk om een streepje tussen de naam en de aanwijzing te hebben. Voorbeeld: naam-AA Ik keek naar je macro een beetje, maar ik zal niet in staat zijn om te zeggen of toe te voegen "-"
' 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
Je hoeft geen sorry te zeggen Cyril.f, ik ben al super blij met je hulp. De macro werkt HEEL GOED, het zal het leven van mijn nieuwe collega's veranderen. Ik zit amper 3 maanden op solidworks, maar ik heb 25 jaar Creo achter de rug.
