AW: Shape in PDF umwandeln
11.06.2020 17:06:00
fcs
Hallo Stefan,
bei Shapes hast du nur die Möglichkeit den Zellbereich mit dem Shape als PDF zu speichern.
Für das einzelne Shape gibt es keine Möglichkeit der direkten Speicherung.
Hier mal 2 Beispielmakros.
das 1. Makro arbeite alle Shapes in einer Arbeitsmappe ab und du kannst entscheiden, ob du es speichern möchtes.
Das 2. Makro speichert das selektierte Shape.
Nach Möglichkeit wird der Zellbereich mit dem Shape in die linke obere Exke des Ecelfensters gescrollt.
LG
Franz
Sub Shapes_to_PDF()
'Speichern der Zellbereiche mit Shapes auf allen tabellenblättern in der Arbeitsmappe.
Dim ThisRng As Range
Dim strfile As String
Dim myfile As Variant
Dim wks As Worksheet
Dim oShape As shape
Dim PathSave As String
PathSave = ThisWorkbook.Path & Application.PathSeparator
For Each wks In ActiveWorkbook.Worksheets
wks.Select
For Each oShape In wks.Shapes
Set ThisRng = wks.Range(oShape.TopLeftCell, oShape.BottomRightCell)
ActiveWindow.ScrollRow = ThisRng.Row
ActiveWindow.ScrollColumn = ThisRng.Column
oShape.Select
strfile = wks.Name & " - " & oShape.Name & ".pdf"
myfile = Application.GetSaveAsFilename _
(InitialFileName:=PathSave & strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")
If myfile False Then 'save as PDF
ThisRng.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
End If
If MsgBox("Nächstes Shape selektieren?", _
vbQuestion + vbOKCancel, "Shapes als pdf speichern") = vbCancel Then Exit Sub
Next oShape
Next wks
MsgBox "Fertig, alle Shapes wurden angezeigt/gedruckt"
End Sub
Sub Shapes_Selektiertes_to_PDF()
'Speichern des Zellbereiches mit dem selektierten Shape
Dim ThisRng As Range
Dim strfile As String
Dim myfile As Variant
Dim oShape As Object
Dim PathSave As String
On Error GoTo Fehler
PathSave = ThisWorkbook.Path & Application.PathSeparator
Set oShape = Selection
Set ThisRng = ActiveSheet.Range(oShape.TopLeftCell, oShape.BottomRightCell)
ActiveWindow.ScrollRow = ThisRng.Row
ActiveWindow.ScrollColumn = ThisRng.Column
strfile = ActiveSheet.Name & " - " & oShape.Name & ".pdf"
myfile = Application.GetSaveAsFilename _
(InitialFileName:=PathSave & strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")
If myfile False Then 'save as PDF
ThisRng.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=True
End If
Fehler:
With Err
Select Case .Number
Case 0 'alle OK
Case 438 'alle OK
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "vermutlich wurde kein Shape-Obket selektiert!", _
vbOKOnly, "Selektiertes Shape als PDF speichern"
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub