Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Jede Seite einzeln

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  Jede Seite einzeln (1119 mal gelesen)
Kizz
Mitglied
Konstrukteur


Sehen Sie sich das Profil von Kizz an!   Senden Sie eine Private Message an Kizz  Schreiben Sie einen Gästebucheintrag für Kizz

Beiträge: 270
Registriert: 06.08.2010

Autodesk PDS 2019 Ultimate - IV
SolidWorks Pro 2019
MS Office 20010
Win7 64 Prof
32GB
4x 3,6 GHz
NVIDIA Quadro K2200 - 4GB

erstellt am: 05. Jun. 2019 14:40    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo Leute

ich habe eine wahrscheinlich recht blöde Frage:

Welche Zeile muss ich wohingehend ändern, das er mir die Blätter einzeln mit deren Namen oder Revision abspeichert?
Beispiel: "Zeichnung 1 - Maßblatt" / "Zeichnung 1 - Explosion" usw.
Ich habe den Code von einem Kolegen bekommen der nicht mehr da ist, habe aber selber keine große Ahnung von VBA.

Code:
Sub PDF_Export_Farbe()
Dim oDoc As Document
Dim dDoc As DrawingDocument
Dim fso As Object
Dim ret As Variant
For Each oDoc In ThisApplication.Documents
    If oDoc.DocumentType = kDrawingDocumentObject Then
        Set fso = CreateObject("Scripting.FilesystemObject")
        Call oDoc.Activate
        Set dDoc = ThisApplication.ActiveDocument
        If dDoc Is Nothing Then Exit Sub
            If Len(Trim(dDoc.FullFileName)) > 0 Then
                outfile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & ".pdf"

' Get the PDF translator Add-In.
    Dim PDFAddIn As TranslatorAddIn
    Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")


    Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
    oContext.Type = kFileBrowseIOMechanism

    ' Create a NameValueMap object
    Dim oOptions As NameValueMap
    Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

    ' Create a DataMedium object
    Dim oDataMedium As DataMedium
    Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
   
    oDataMedium.filename = outfile

    ' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(dDoc, oContext, oOptions) Then

        ' Options for drawings...
        oOptions.Value("All_Color_AS_Black") = 0

        oOptions.Value("Remove_Line_Weights") = 0
        oOptions.Value("Vector_Resolution") = 1200
        oOptions.Value("Sheet_Range") = 15
        oOptions.Value("Custom_Begin_Sheet") = 1
        oOptions.Value("Custom_End_Sheet") = 5


    'Publish document.
    Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, oDataMedium)
            Else
                MsgBox "Erst alles Speichern", vbInformation
                Exit Sub
            End If
        End If
  End If
Next

End Sub


------------------
Mit freundlichen Grüßen

Chris

__________________________________

"Faulheit ist das Bestreben, mit möglichst wenig Aufwand viel zu erreichen. "

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Meierjo
Mitglied



Sehen Sie sich das Profil von Meierjo an!   Senden Sie eine Private Message an Meierjo  Schreiben Sie einen Gästebucheintrag für Meierjo

Beiträge: 358
Registriert: 20.08.2003

erstellt am: 05. Jun. 2019 15:37    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Kizz 10 Unities + Antwort hilfreich

Hallo
So wird mal jedes Blatt einzeln als PDF gespeichert
Um die Bezeichnungen Massblatt / Explosion etc zu bekommen, müsste ich erst mal wissen, wo diese Angaben vorhanden sind.
Sind das benutzerdefinierte iProps?

Code:
Sub PDF_Export_Farbe()
    Dim oDoc As Document
    Dim dDoc As DrawingDocument
    Dim oSheetName As String
    Dim oSheet As Sheet
    Dim fso As Object
    Dim ret As Variant

    For Each oDoc In ThisApplication.Documents.VisibleDocuments 'ThisApplication.Documents.VisibleDocuments
        For Each oSheets In oDoc.Sheets
        oSheets.Activate
        oSheetName = Right(oSheets.Name, 1)
            If oDoc.DocumentType = kDrawingDocumentObject Then
                Set fso = CreateObject("Scripting.FilesystemObject")
                Call oDoc.Activate
                Set dDoc = ThisApplication.ActiveDocument
                If dDoc Is Nothing Then Exit Sub
                    If Len(Trim(dDoc.FullFileName)) > 0 Then
                        outfile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & "Blatt" & oSheetName & ".pdf"
                        ' Get the PDF translator Add-In.
                        Dim PDFAddIn As TranslatorAddIn
                        Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")

                        Dim oContext As TranslationContext
                        Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
                        oContext.Type = kFileBrowseIOMechanism

                        ' Create a NameValueMap object
                        Dim oOptions As NameValueMap
                        Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

                        ' Create a DataMedium object
                        Dim oDataMedium As DataMedium
                        Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
                        oDataMedium.FileName = outfile

                        ' Check whether the translator has 'SaveCopyAs' options
                        If PDFAddIn.HasSaveCopyAsOptions(dDoc, oContext, oOptions) Then

                            ' Options for drawings...
                            oOptions.Value("All_Color_AS_Black") = 0
                            oOptions.Value("Remove_Line_Weights") = 0
                            oOptions.Value("Vector_Resolution") = 1200
                            'oOptions.Value("Sheet_Range") = 15
                            'oOptions.Value("Sheet_Range") = kPrintAllSheets
                            oOptions.Value("Sheet_Range") = kPrintCurrentSheet
                            'oOptions.Value("Custom_Begin_Sheet") = 1
                            'oOptions.Value("Custom_End_Sheet") = 5

                            'Publish document.
                            Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, oDataMedium)
                        Else
                            MsgBox "Erst alles Speichern", vbInformation
                            Exit Sub
                        End If
                    End If
                End If
        Next
    Next

End Sub


Gruss

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Kizz
Mitglied
Konstrukteur


Sehen Sie sich das Profil von Kizz an!   Senden Sie eine Private Message an Kizz  Schreiben Sie einen Gästebucheintrag für Kizz

Beiträge: 270
Registriert: 06.08.2010

Autodesk PDS 2019 Ultimate - IV
SolidWorks Pro 2019
MS Office 20010
Win7 64 Prof
32GB
4x 3,6 GHz
NVIDIA Quadro K2200 - 4GB

erstellt am: 05. Jun. 2019 17:18    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


Benennung.jpg


Benennung-1.jpg

 
Hallo Meierjo

Erst mal vielen lieben Dank für die Hilfe!
Ich habe die Blätter so benannt. Es wäre aber auch kein Problem für mich den Namen noch in der Blattrevision an zu geben, falls du einfacher an diese Daten rankommst.
Ich habe dir dazu mal 2 Bilder angehängt.

------------------
Mit freundlichen Grüßen

Chris

__________________________________

"Faulheit ist das Bestreben, mit möglichst wenig Aufwand viel zu erreichen. "

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Meierjo
Mitglied



Sehen Sie sich das Profil von Meierjo an!   Senden Sie eine Private Message an Meierjo  Schreiben Sie einen Gästebucheintrag für Meierjo

Beiträge: 358
Registriert: 20.08.2003

erstellt am: 06. Jun. 2019 06:54    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Kizz 10 Unities + Antwort hilfreich

Guten morgen

Habe den Code nochmals angepasst
er liefert dir den Namen des Blattes, inkl Nummer

Code:
Sub PDF_Export_Farbe()
    Dim oDoc As Document
    Dim dDoc As DrawingDocument
    Dim oSheetName As String
    Dim oSheet As Sheet
    Dim fso As Object
    Dim ret As Variant
    For Each oDoc In ThisApplication.Documents.VisibleDocuments 'ThisApplication.Documents.VisibleDocuments
        For Each oSheets In oDoc.Sheets
        oSheets.Activate
        oSheetName = Replace(oSheets.Name, ":", "")
            If oDoc.DocumentType = kDrawingDocumentObject Then
                Set fso = CreateObject("Scripting.FilesystemObject")
                Call oDoc.Activate
                Set dDoc = ThisApplication.ActiveDocument
                If dDoc Is Nothing Then Exit Sub
                    If Len(Trim(dDoc.FullFileName)) > 0 Then
                        outfile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & "-" & oSheetName & ".pdf"
                        ' Get the PDF translator Add-In.
                        Dim PDFAddIn As TranslatorAddIn
                        Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")

                        Dim oContext As TranslationContext
                        Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
                        oContext.Type = kFileBrowseIOMechanism

                        ' Create a NameValueMap object
                        Dim oOptions As NameValueMap
                        Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

                        ' Create a DataMedium object
                        Dim oDataMedium As DataMedium
                        Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
                        oDataMedium.FileName = outfile

                        ' Check whether the translator has 'SaveCopyAs' options
                        If PDFAddIn.HasSaveCopyAsOptions(dDoc, oContext, oOptions) Then

                            ' Options for drawings...
                            oOptions.Value("All_Color_AS_Black") = 0
                            oOptions.Value("Remove_Line_Weights") = 0
                            oOptions.Value("Vector_Resolution") = 1200
                            'oOptions.Value("Sheet_Range") = 15
                            'oOptions.Value("Sheet_Range") = kPrintAllSheets
                            oOptions.Value("Sheet_Range") = kPrintCurrentSheet
                            'oOptions.Value("Custom_Begin_Sheet") = 1
                            'oOptions.Value("Custom_End_Sheet") = 5

                            'Publish document.
                            Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, oDataMedium)
                        Else
                            MsgBox "Erst alles Speichern", vbInformation
                            Exit Sub
                        End If
                    End If
                End If
        Next
    Next

End Sub



Gruss

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Kizz
Mitglied
Konstrukteur


Sehen Sie sich das Profil von Kizz an!   Senden Sie eine Private Message an Kizz  Schreiben Sie einen Gästebucheintrag für Kizz

Beiträge: 270
Registriert: 06.08.2010

Autodesk PDS 2019 Ultimate - IV
SolidWorks Pro 2019
MS Office 20010
Win7 64 Prof
32GB
4x 3,6 GHz
NVIDIA Quadro K2200 - 4GB

erstellt am: 06. Jun. 2019 08:18    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


Benennung-2.jpg

 
Hallo Meierjo

Funktioniert super!
Die Blätter haben dann zwar noch jeweils 1, 2, 3 usw. dahinter, aber die kann man ja einfach aus dem Namen löschen oder bei sehr vielen Blättern einfach mit "Advanced Renamer" entfernen.

Vielen Dank!

------------------
Mit freundlichen Grüßen

Chris

__________________________________

"Faulheit ist das Bestreben, mit möglichst wenig Aufwand viel zu erreichen. "

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Meierjo
Mitglied



Sehen Sie sich das Profil von Meierjo an!   Senden Sie eine Private Message an Meierjo  Schreiben Sie einen Gästebucheintrag für Meierjo

Beiträge: 358
Registriert: 20.08.2003

erstellt am: 06. Jun. 2019 09:37    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Kizz 10 Unities + Antwort hilfreich

Hallo

Ist denn die Blattnummer immer einstellig? Wenn ja, kann ich das noch anpassen

Gruss

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Kizz
Mitglied
Konstrukteur


Sehen Sie sich das Profil von Kizz an!   Senden Sie eine Private Message an Kizz  Schreiben Sie einen Gästebucheintrag für Kizz

Beiträge: 270
Registriert: 06.08.2010

Autodesk PDS 2019 Ultimate - IV
SolidWorks Pro 2019
MS Office 20010
Win7 64 Prof
32GB
4x 3,6 GHz
NVIDIA Quadro K2200 - 4GB

erstellt am: 06. Jun. 2019 11:13    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Moin.

Ja. In der Regel schon.
Es kommt denke ich eher selten bis nie vor, das es mehr als 9 Blätter werden.

------------------
Mit freundlichen Grüßen

Chris

__________________________________

"Faulheit ist das Bestreben, mit möglichst wenig Aufwand viel zu erreichen. "

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP



Entwicklungsingenieur Hydraulik (m/w/d)

Sie möchten mehr über die Rheinmetall Landysteme GmbH erfahren? Dann klicken Sie hier.

Ihre Stärken und Erfahrungen zählen bei Rheinmetall. Zudem legen wir Wert auf Vielfalt und Chancengleichheit. Schwerbehinderte Bewerberinnen und Bewerber werden bei gleicher Eignung besonders berücksichtigt. Auf Ihre Bewerbung freuen wir uns.


  • Auslegung von Hydrauliksystemen ...
Anzeige ansehenEntwicklung
Meierjo
Mitglied



Sehen Sie sich das Profil von Meierjo an!   Senden Sie eine Private Message an Meierjo  Schreiben Sie einen Gästebucheintrag für Meierjo

Beiträge: 358
Registriert: 20.08.2003

erstellt am: 06. Jun. 2019 13:22    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Kizz 10 Unities + Antwort hilfreich

Hallo

So, dieser Code kürzt den Doppelpunkt und die Zahl (1 stellig)rechts aussen weg

Code:
Sub PDF_Export_Farbe()
    Dim oDoc As Document
    Dim dDoc As DrawingDocument
    Dim oSheetName As String
    Dim oSheet As Sheet
    Dim fso As Object
    Dim ret As Variant
    For Each oDoc In ThisApplication.Documents.VisibleDocuments 'ThisApplication.Documents.VisibleDocuments
        For Each oSheets In oDoc.Sheets
        oSheets.Activate
        oSheetName = Left((oSheets.Name), Len(oSheets.Name) - 2)
            If oDoc.DocumentType = kDrawingDocumentObject Then
                Set fso = CreateObject("Scripting.FilesystemObject")
                Call oDoc.Activate
                Set dDoc = ThisApplication.ActiveDocument
                If dDoc Is Nothing Then Exit Sub
                    If Len(Trim(dDoc.FullFileName)) > 0 Then
                        outfile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & "-" & oSheetName & ".pdf"
                        ' Get the PDF translator Add-In.
                        Dim PDFAddIn As TranslatorAddIn
                        Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
                        Dim oContext As TranslationContext
                        Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
                        oContext.Type = kFileBrowseIOMechanism

                        ' Create a NameValueMap object
                        Dim oOptions As NameValueMap
                        Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

                        ' Create a DataMedium object
                        Dim oDataMedium As DataMedium
                        Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
                        oDataMedium.FileName = outfile

                        ' Check whether the translator has 'SaveCopyAs' options
                        If PDFAddIn.HasSaveCopyAsOptions(dDoc, oContext, oOptions) Then

                            ' Options for drawings...
                            oOptions.Value("All_Color_AS_Black") = 0
                            oOptions.Value("Remove_Line_Weights") = 0
                            oOptions.Value("Vector_Resolution") = 1200
                            'oOptions.Value("Sheet_Range") = 15
                            'oOptions.Value("Sheet_Range") = kPrintAllSheets
                            oOptions.Value("Sheet_Range") = kPrintCurrentSheet
                            'oOptions.Value("Custom_Begin_Sheet") = 1
                            'oOptions.Value("Custom_End_Sheet") = 5

                            'Publish document.
                            Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, oDataMedium)
                        Else
                            MsgBox "Erst alles Speichern", vbInformation
                            Exit Sub
                        End If
                    End If
                End If
        Next
    Next

End Sub


Gruss

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz