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
