' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub exportPrintArea()
Dim lngRet As Long
Dim strPath1 As String, strPath2 As String
strPath1 = "E:\Temp"
strPath2 = "E:\Temp\Test"
With Sheets("Tabelle1")
strPath1 = IIf(Right(strPath1, 1) = "\", strPath1, strPath1 & "\") & _
Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, ".") - 1) & ".jpg"
strPath2 = IIf(Right(strPath2, 1) = "\", strPath2, strPath2 & "\") & _
Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, ".") - 1) & _
.Range("A1").Text & .Range("A2").Text & ".jpg"
lngRet = RangeToImage(strPath1, .Range(.PageSetup.PrintArea))
lngRet = RangeToImage(strPath2, .Range(.PageSetup.PrintArea))
End With
If lngRet = 0 Then
MsgBox "Druckbereich erfolgreich exportiert"
Else
MsgBox "Fehler beim Export"
End If
End Sub
Function RangeToImage(ByVal ImageFile As String, ByRef ImageRange As Object) As Long
Dim objPict As Object, objChrt As Chart
Dim strExt As String, bDelPic As Boolean
On Error GoTo ErrExit
Application.ScreenUpdating = False
RangeToImage = -1
With ImageRange.Parent
If TypeName(ImageRange) = "Range" Then
.Activate
.Range("X20000").Select
ImageRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
.PasteSpecial Format:="Bitmap"
For Each objPict In .Shapes
If objPict.TopLeftCell.Address(0, 0) = "X20000" Then Exit For
Next
.Range("A1").Select
bDelPic = True
ElseIf TypeName(ImageRange) = "Shape" Then
Set objPict = ImageRange
End If
objPict.Copy
Set objChrt = .ChartObjects.Add(1, 1, objPict.Width + 8, objPict.Height + 8).Chart
strExt = Mid(ImageFile, InStrRev(ImageFile, ".") + 1)
objChrt.Paste
objChrt.Export ImageFile, FilterName:=strExt
objChrt.Parent.Delete
If bDelPic Then objPict.Delete
DoEvents
Set objPict = Nothing
Set objChrt = Nothing
RangeToImage = 0
End With
ErrExit:
Application.ScreenUpdating = True
If Not objChrt Is Nothing Then objChrt.Parent.Delete
If bDelPic Then If Not objPict Is Nothing Then objPict.Delete
Set objPict = Nothing
Set objChrt = Nothing
End Function
