Bereich als Grafik speichern!

Frage: Wie speichere ich einen Bereich als Bild / Grafik ab? Folgend mal zwei Beispiele. Realisiert über ein "ChartObject". Im ersten Beispiel wird ein fester Bereich genommen. Im zweiten Beispiel wird der Dateiname, der Pfad und der Bereich jeweils über InputBoxen abgefragt.

Bereich als Bild / Grafik speichern...[ZIP, 80 KB]

Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal Operation As String, ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long _
= vbMinimizedFocus) As Long
Const strPathFileNmame As String = "C:\Temp\Test123"
' Pfad- und Dateiname anpassen
Const strExt As String = "bmp"
'Const strExt As String = "jpg"
'Const strExt As String = "gif"
Public Sub Pic_Range()
Dim objDiagramm As ChartObject
Dim picGrafik As Picture
Dim rngRange As Range
On Error GoTo Fin
Set rngRange = ActiveSheet.UsedRange
Application.ScreenUpdating = False
rngRange.Copy
Worksheets.Add
Set picGrafik = ActiveSheet.Pictures.Paste
picGrafik.CopyPicture 1, -4147
Set objDiagramm = ActiveSheet.ChartObjects.Add _
(0, 0, picGrafik.Width, picGrafik.Height)
With objDiagramm
.Chart.Paste
.Chart.Export strPathFileNmame & _
"." & strExt, strExt
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set objDiagramm = Nothing
Set picGrafik = Nothing
Set rngRange = Nothing
If Dir(strPathFileNmame & "." & strExt) <> "" Then _
ShellExecute 0, "Open", strPathFileNmame & _
"." & strExt, , , 1
End Sub
Public Sub Pic_Range_1()
Dim objDiagramm As ChartObject
Dim strVerzeichnis As String
Dim picGrafik As Picture
Dim rngRange As Range
Dim strTMP As String
On Error GoTo Fin
strTMP = InputBox("Dateiname!", "Eingabe!", "Bereich")
If Trim(strTMP) = "" Then Exit Sub
If Ordnerwahl(strVerzeichnis) <> "" Then
If Dir(strVerzeichnis & strTMP & "." & strExt) <> "" Then _
Kill (strVerzeichnis & strTMP & "." & strExt)
Set rngRange = Application.InputBox _
("Bereich mit der Maus wählen...", _
" Auswahl!", "A1:J22", , , , , 8)
Application.ScreenUpdating = False
rngRange.Copy
Worksheets.Add
Set picGrafik = ActiveSheet.Pictures.Paste
picGrafik.CopyPicture 1, -4147
Set objDiagramm = ActiveSheet.ChartObjects.Add _
(0, 0, picGrafik.Width, picGrafik.Height)
With objDiagramm
.Chart.Paste
.Chart.Export strVerzeichnis & strTMP & _
"." & strExt, strExt
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Else
MsgBox "Es wurde kein Ordner ausgewaehlt!"
End If
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objDiagramm = Nothing
Set picGrafik = Nothing
Set rngRange = Nothing
If Err.Number = 424 Then MsgBox "Rangeauswahl abgebrochen!"
If Err.Number <> 0 And Not Err.Number = 424 Then
MsgBox "Fehler: " & Err.Number & _
" " & Err.Description
Else
If Dir(strVerzeichnis & strTMP & "." & strExt) <> "" Then _
ShellExecute 0, "Open", strVerzeichnis & _
strTMP & "." & strExt, , , 1
End If
End Sub
Public Function Ordnerwahl(strOrdner As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
'Oder Pfad in dem die Exceldatei ist
'.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1) <> "\" Then _
strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
Ordnerwahl = strOrdner
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...