Public Sub SaveRangeScreenshot(ByVal rng As Excel.Range)
Dim objChart As ChartObject
Dim BlattName As String
Dim ws As Excel.Worksheet
Dim pic As Picture
Dim sDatei As String
Dim sZielDatei As String
Dim sPfad As String
Dim strFilename As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPfad = ActiveWorkbook.Path & "\"
sDatei = Worksheets("Tabelle1").Cells(2, 6).Value
sZielDatei = sPfad & sDatei _
& "_" & Format(Date, "yyyy_MM_dd_") _
& Format(Time, "hh-nn-ss")
strFilename = sZielDatei & ".jpg"
rng.Copy
DoEvents
Set ws = ThisWorkbook.Worksheets.Add
DoEvents
Set pic = ws.Pictures.Paste(Link:=True)
DoEvents
pic.CopyPicture Appearance:=xlScreen, Format:=xlPicture
DoEvents
Set objChart = ws.ChartObjects.Add(0, 0, pic.Width, pic.Height)
DoEvents
With objChart.Chart
DoEvents
.Paste
DoEvents
.Export strFilename
DoEvents
End With
DoEvents
ErrExit:
On Error Resume Next
DoEvents
<strong>ws.Delete
</strong>
DoEvents
Set ws = Nothing
Set pic = Nothing
Set objChart = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbCritical, "Fehler " & Err.Number & " aufgetreten!"
Resume ErrExit
End Sub