Bereich als Bild speichern
15.09.2016 08:39:56
Nils
folgenden Code würde ich gerne zum abspeichern als Bild verwenden. Ich dachte mir ich erhöhe die Pixel indem ich zuvor auf 400% Zoom stelle (ActiveWindow.Zoom = 400), nur leider scheint das nicht zu funktionieren. Das Bild ist unscharf und der bereich falsch.
Weiß jemand wie es richtig geht?
Oder gibt es eine andere Möglichkeit die Auflösung zu verbessern?
Grüße
Nils
Sub Range_To_Image()
Dim objPict As Object, objChrt As Chart
Dim rngImage As Range, strFile As String
On Error GoTo ErrExit
With Sheets("Tabelle1") 'Tabellenname - Anpassen!
ActiveWindow.Zoom = 400
Set rngImage = .Range("A1:L38")
rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
Set objPict = .Shapes(.Shapes.Count)
strFile = "C:\Temp\meinBild.gif" 'Pfad und Dateiname für das Bild
objPict.Copy
Set objChrt = .ChartObjects.Add(1, 1, objPict.Width, objPict.Height).Chart
objChrt.Paste
objChrt.Export strFile
objChrt.Parent.Delete
objPict.Delete
ActiveWindow.Zoom = 100
End With
ErrExit:
Set objPict = Nothing
Set objChrt = Nothing
Set rngImage = Nothing
End Sub