Ich habe hier ein hervorragendes Makro, um alle MEP in PDF in einem Ordner in 1 Schuss zu speichern. Auf der anderen Seite benötige ich den Namen des PDFs, um sich mit dem Index des Teils zu entwickeln. Beispiel: Teil " axe52 mit Index AB " wird zu " axe52-AB.pdf " , wenn es in pdf aufgezeichnet wird Ich habe ein Makro, das das macht, aber Einstellung für Einstellung, wenn man also viele Aufnahmen hat, braucht es viel Zeit. Wenn mir jemand helfen könnte, diese 2 Makros zu erstellen, wäre ein Makro großartig. Im Makro-Making bin ich ein Anfänger Vielen Dank im Voraus für Ihre Hilfe
Möchten Sie unbedingt von einer Baugruppe ausgehen, um die Zeichnungen abzurufen oder in einem Ordner mit allen vorhandenen Zeichnungen zu verarbeiten?
Hallo Cyril.f Die 2 Lösungen sind für mich in Ordnung, aber wenn Sie von einer Montage ausgehen, können Sie nur die Pläne davon erstellen, was ist am einfachsten?
Hallo Hier ist der Code aus den beiden Makros. Ich habe kein Steuerelement hinzugefügt, falls die Eigenschaft "REVISION" fehlt, wenn andererseits die Verbindung zwischen dem Plan und dem 3D unterbrochen ist oder kein Modell angehängt ist, geht das Makro seinen Weg, ohne das PDF zu erstellen (dies kann durch Verschieben des End if geändert werden). Ich habe auch keine Überprüfung hinzugefügt, ob die PDF-Datei existiert oder nicht (und die zugehörige Verarbeitung)
' 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 DANKE Cyril.f es funktioniert sehr gut. Nur noch eine Sache, ich mag es, einen Bindestrich zwischen dem Namen und dem Hinweis zu haben. Beispiel: Name-AA Ich habe mir Ihr Makro ein wenig angesehen, aber ich werde nicht in der Lage sein, "-" zu sagen oder hinzuzufügen.
' 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
Du brauchst dich nicht zu entschuldigen , Cyril.f Ich bin schon super froh, deine Hilfe zu haben. Das Makro funktioniert SEHR GUT, es wird das Leben meiner neuen Kollegen verändern. Ich bin erst seit knapp 3 Monaten bei Solidworks, aber ich habe 25 Jahre Creo hinter mir.