Makro-Aufzeichnung aller TGAs im PDF-Format mit Teileindex

Cyril.f · 27. März 2023 um 13:02

Hallo

Möchten Sie unbedingt von einer Baugruppe ausgehen, um die Zeichnungen abzurufen oder in einem Ordner mit allen vorhandenen Zeichnungen zu verarbeiten?

_Cricri · 27. März 2023 um 13:12

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?

_Cricri · 27. März 2023 um 13:13

Vielen Dank

Cyril.f · 27. März 2023 um 13:26

Alles ist machbar, es ist nur so, dass es bereits vorhandene Makros gibt, die von einem Ordner aus arbeiten.

_Cricri · 27. März 2023 um 13:47

Ich würde es vorziehen, von der Assemblierung aus zu beginnen, wie im ersten Makro, das "pdf_des_compsants_de_lassemblage" erwähnt wurde.

Cyril.f · 28. März 2023 um 05:24

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

_Cricri · 28. März 2023 um 05:51

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.

Cyril.f · 28. März 2023 um 05:57

Sie müssen diese Zeile ändern:

Bis:

pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) + "-" +  revision + ".pdf")

_Cricri · 28. März 2023 um 06:01

Dies ist in der Tat die Zeile, in der ich das eingefügt hatte - aber ich hatte das " "
Danke Cyril.f

_Cricri · 28. März 2023 um 06:40

Und noch etwas, gibt es eine Möglichkeit, das DXF auch gleichzeitig zu machen?

Cyril.f · 28. März 2023 um 06:46

Ja, aber aus dem einfachen dxf des Plans oder im Falle von Blech mit einer Abflachung?

_Cricri · 28. März 2023 um 07:10

Ja, eine einfache DXF-Datei des Plans

Cyril.f · 28. März 2023 um 07:23

Hier ist der vollständige Code:

' 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

Ich habe die Exporteinstellungen nicht überprüft.

_Cricri · 28. März 2023 um 08:42

Danke Cyril.f
Ich kann nicht finden, wo die . Hinter dem Index für DXF-Pläne
Im Grunde habe ich den Namen AA. Für DXFs

A.R · 28. März 2023 um 08:48

Bonjour_cricri,
Nur zur Information, wenn Sie Zugriff auf die " MycadTools " Werkzeuge haben, verwenden Sie "BatchConverter".

Diese App ist dafür gemacht...
Viel Glück.
@+.
AR.

Cyril.f · 28. März 2023 um 08:57

Sorry, schlecht integriert.
Wir müssen die Linie ändern

dxfPathName = Left(pdfPathName, Len(pdfPathName) - 3)& ".dxf"

Bis:

dxfPathName = Left(pdfPathName, Len(pdfPathName) - 3)& "dxf"

_Cricri · 28. März 2023 um 09:02

Hallo AR
Leider habe ich keinen Zugriff auf das Batch-Konverter-Tool

_Cricri · 28. März 2023 um 09:06

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.

A.R · 28. März 2023 um 10:01

ok, das dachte ich mir...
Viel Glück!!!
@+.
AR.

m.blt · 28. März 2023 um 10:18

Hallo @_Cricri ,

Ein anderer Ansatz als der von @Cyril.f , abgeleitet von einem Makro von der www.codestack.net Site.
Verwenden Sie dieses Makro, um Zeichnungen der Komponenten einer Baugruppe in Unterordner im Stammverzeichnis der Baugruppe zu exportieren:

im PDF-Format in einem Unterordner pdf_files ;
DXF in einem Unterordner dxf_files
im DWG-Format in einem Unterordner dwg_files.

Für jede Komponente werden Zeichnungen in ihrem Sicherungsordner und ihren Unterordnern durchsucht und haben nicht unbedingt den gleichen Namen wie das 3D-Modell.
Prinzipiell also zu testen...

Herzliche Grüße.
AssyCompsMEPsaveAsPdfDxfDwg.swp (107.5 KB)