| |
| 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
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 / zitieren --> Unities abgeben:
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
Beiträge: 358 Registriert: 20.08.2003
|
erstellt am: 05. Jun. 2019 15:37 <-- editieren / zitieren --> Unities abgeben: Nur für Kizz
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
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 / zitieren --> Unities abgeben:
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
Beiträge: 358 Registriert: 20.08.2003
|
erstellt am: 06. Jun. 2019 06:54 <-- editieren / zitieren --> Unities abgeben: Nur für Kizz
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
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 / zitieren --> Unities abgeben:
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
Beiträge: 358 Registriert: 20.08.2003
|
erstellt am: 06. Jun. 2019 09:37 <-- editieren / zitieren --> Unities abgeben: Nur für Kizz
|
Kizz Mitglied Konstrukteur
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 / zitieren --> Unities abgeben:
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 ansehen | Entwicklung |
|
Meierjo Mitglied
Beiträge: 358 Registriert: 20.08.2003
|
erstellt am: 06. Jun. 2019 13:22 <-- editieren / zitieren --> Unities abgeben: Nur für Kizz
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 |