Office: Bereich als Bild speichern Excel 365

HerrFrie · 13. Mai 2017

Hallo zusammen,

ich möchte einen Bereich wo ein Diagramm und ein paar Tabellenzeilen abgebildet sind als Bild speichern. Dieses Bild möchte ich nachher über HTML/PHP anzeigen lassen.

Ich habe mir verschiedene Beispiele aus dem Netz gesucht und probiert, habe aber das Problem, dass der Code scheinbar nicht mit Excel 365 funktioniert. Es wird dort nur ein weißes Bild abgespeichert.

Code:

Z.B. : 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:TempTest123"
' 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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wenn ich das auf einem Rechner mit Excel 2010 ausführe funktioniert das.
Leider habe ich keinen Einfluß auf die Excel Version, da es sich um einen Firmenrechner handelt und das automatisch installiert wurde.

Hat vielleicht jemand eine Lösung die funktioniert ?

Gruß
HerrFrie

:)

Case_Germany · 15. Mai 2017

Hallo, *Smilie

in Deiner Officeversion muss die "ChartArea" aktiv sein: *wink.gif*

Code:

'.....
With objDiagramm
.Chart.ChartArea.Select
.Chart.Paste
.Chart.Export strPathFileNmame & _
"." & strExt, strExt
End With
'.....
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Servus
Case

HerrFrie · 18. Mai 2017

Sorry das ich mich erst jetzt melde.

Habe ich probiert und es funktioniert einwandfrei. In den alten Versionen war das Select dann scheinbar nicht nötig, so einfach kann es sein.

Besten Dank !

Christian007 · 27. Oktober 2020

Hallo, ich habe ein ganz ähnliches Probelm. Ich benutze ein Screenshot Makro das eigentlich problemlos unter Office 2013 lief seit der umstellung auf Office 365 legt es nur noch weiße Bilder ab.
Hat jemand eine idee was ich daran ändern muss?

Die Datei besteht aus mehreren Tabellenblättern, eine Vorlage und dann je Monat ein Tabellenblatt. Im ersten Teil wird das Tabellenblatt mit dem aktuellen Monat ausgewählt und denn der Screenshot erstellt....

Code:

Sub ExportImage()

Dim sFilePath As String
Dim sView As String
Dim s As String
'
''!!!!
''!!!HIER BITTE DEN PFAD ZUM ABLAGEORT DER BILDER FESTLEGEN!!!
St_FilePath = "C:Test_images"
''!!!!!
'
Set Sheet = Worksheets("Vorlage")
''Captures current window view
sView = ActiveWindow.View
'
'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView
ActiveWindow.Zoom = 100
'
'Temporarily disable screen updating
Application.ScreenUpdating = False
'
strMonth = Format(Date, "mmmm")
'
s = strMonth
Set Sheet = ActiveWorkbook.Worksheets(s)
'
Filename = St_FilePath & "Test1" & ".png"
'
'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef = 250 / Sheet.Parent.Windows(1).Zoom
'zuvor zoom_coef = 50
Set area = Sheet.Range("A1:AX52")
'ALt >>> Set area = Sheet.Range("GesamtBild")
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
'Error Simulated when user dont have change permission in Export folder
On Error Resume Next
chartobj.Chart.Export Filename, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

End Sub

Grüße
Christian

Nepumuk · 27. Oktober 2020

Hallo Christian,

so:

Code:

Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Activate
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Christian007 · 28. Oktober 2020

Hallo Nepumuk

ich habe die Zeile angepasst leider bekomme ich jetzt auch schon im Office 2013 ein weißes Bild. genauso verhält es sich im Office 365.

gibt es vielleicht noch eine andere Möglichkeit?

Grüße
Christian

Nepumuk · 28. Oktober 2020

Hallo Christian,

du hast die Zeile vor der Paste-Methode eingefügt?

Christian007 · 29. Oktober 2020

Danke für den Tip,

Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Activate
chartobj.Chart.Paste

Habe es jetzt so geändert. So scheint es zu klappen *Smilie Danke!!!

Jetzt habe ich schon wieder die nächste Herausforderung wenn ich das Bild unter zwei verschiedenen Ordnern speichern will, muss ich dann das Makro duplizieren und dann Pfad ändern oder gibt es dafür eine elegantere Variante?

Grüße Christian

Nepumuk · 29. Oktober 2020

Hallo Christian,

rufe einfach die Export-Methode zweimal hintereinander auf.

Office: Bereich als Bild speichern Excel 365

Bereich als Bild speichern Excel 365

Bereich als Bild speichern Excel 365

Bereich als Bild speichern Excel 365

Bereich als Bild speichern Excel 365

Bereich als Bild speichern Excel 365 - Similar Threads - Bereich Bild speichern

Bereiche eines Arbeitsblattes "nachhaltig" verknüpfen

Bereichs-Namen auf anderen Tabellen-Blättern

Bereich kopieren und als Bild einfügen

Bereich aus anderer Tabelle einfügen je nach Dropdown Wert

Teilsummen aus unterschiedlichen Bereichen (Spalten, Zeilen) autom. bilden

Hyperlinks überarbeiten

in einem Bereich, die gleiche Zellen haben, Mittelwert bilden.