Bereich als Grafik speichern
Benedikt
Nachfolgender Code (ein Kompliment dem Autor) speichert den angegebenen Tabellenbereich als JPG ab und läuft tadellos.
Bei meinem Terminkalender ist die Spalte A fixiert, die nächsten 10 Spalten sind variabel, abhängig von der KW.
Wie kann man den Bereich A1:A30 und die nebenstehenden, unbekannten, 10 Spalten als JPG speichern?
Besteht eventuell die möglichkeit das ganze als PDF zu speichern?
Vielen Dank für eure Hilfe
Sub TabellenBereichAlsGraphicSpeichern()
Dim wbk As Excel.Workbook
Dim wksQuelle As Excel.Worksheet
Dim wksTemp As Excel.Worksheet
Dim rngB As Excel.Range
Dim chtObj As Excel.ChartObject
Dim strPathAndFile As String
Dim dblWidth As Double
Dim dblHeight As Double
Set wbk = ThisWorkbook
strPathAndFile = "O:\Terminkalender Projekt 2012\PDF\Termin.jpg" ' Ziel
Set wksQuelle = wbk.Worksheets("Tabelle1") 'Tabelle
Set rngB = wksQuelle.Range(wksQuelle.Cells(1, 1), wksQuelle.Cells(30, 11)) 'Bereich
DoEvents
rngB.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set wksTemp = wbk.Worksheets.Add
Set chtObj = wksTemp.ChartObjects.Add(10, 10, 15000, 20000)
chtObj.Chart.Paste
chtObj.Chart.Shapes(1).Top = 0
chtObj.Chart.Shapes(1).Left = 0
dblWidth = chtObj.Chart.Shapes(1).Width
dblHeight = chtObj.Chart.Shapes(1).Height
chtObj.Width = dblWidth + 8
chtObj.Height = dblHeight + 8
chtObj.Chart.Shapes(1).Width = dblWidth
chtObj.Chart.Shapes(1).Height = dblHeight
chtObj.Chart.Export Filename:=strPathAndFile, FilterName:="JPG"
Application.DisplayAlerts = False
wksTemp.Delete
Application.DisplayAlerts = True
End Sub