Tabellenbereich als Bild speichern

Hallo Excelgemeinde,
ich versuche nun schon seit geraumer Zeit einen Tabellenbereich als Bild zu speichern.
Leider gelingt mir das nur sehr schlecht. Ich habe duzende Beiträge gefunden, ebensoviele Makros getestet. Aber leider stellt mich nichts von dem, was ich im Archiv finde, zufrieden. :-(
Ich habe mal den Bereich in eine Datei kopiert:
https://www.herber.de/bbs/user/78899.xls
Leider sind nach dem Export die Linien und die Schrift ganz anders. Die Schrift wirkt unleserlich auf dem Foto. Die Linien sind Unterschiedlich und das obwohl in der Datei die Linien gleich sind.
Ich benötige aber die Bilder in nahezu perfekter Kopie zum reelen Druck!
Immer wieder versuche ich mit neuem Mut verschiedene Makros aber leider ohne Erfolg. Langsam glaube ich schon, dass es an meiner Bildschirmauflösung oder etwas Anderem an meinem PC liegt!?!?!
Ich hoffe, dass jemand mir helfen kann!?!?!
Gruß DirkR

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub copy_Bild() Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture Sheets("Tabelle2").Select ActiveSheet.PasteSpecial Format:="Bild (Erweiterte Metadatei)", Link:=False _ , DisplayAsIcon:=False End Sub

Hallo Detlef,
ich würde gernen deinen Vorschlag in meinem vorhandenen Code einfließen lassen und testen, weiß aber nicht genau wie? Ich finde den Ansatz für PastSpecial nicht wirklich.
Kannst du mir helfen?

Sub Bild_erzeugen(x As Boolean)
Application.ScreenUpdating = False
Dim myChartObject As ChartObject, myShape As Shape
Dim bolfound As Boolean
With Sheets("Z2 R")
.Range("B3:AP51").Copy
.Range("A1").Select
.Pictures.Paste.Select
Application.CutCopyMode = False
With Selection
.ShapeRange.LockAspectRatio = msoTrue 'msoFalse
.ShapeRange.Rotation = 0#
.Width = 1550
'.Height = 786
For Each myShape In ActiveSheet.Shapes
If myShape.Type = msoPicture Then bolfound = True: Exit For
Next
If bolfound Then
myShape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 'Format:=xlPicture
Worksheets.Add
Set myChartObject = ActiveSheet.ChartObjects.Add(0, 0, myShape.Width, myShape. _
Height)
With myChartObject
.Activate
.Border.LineStyle = xlNone
.Chart.Paste
.Chart.Export Filename:=GetCustProp(cstrPropertyName, cstrDefaultPath) & "\Neue  _
Aufnahmen\KO-" _
& Sheets("Datenbank").Cells(17, 8).Value & "-ZF.gif", _
FilterName:="gif", Interactive:=False
.Chart.Export Filename:=GetCustProp(cstrPropertyName, cstrDefaultPath) & "\Neue  _
Aufnahmen\KO-" _
& Sheets("Datenbank").Cells(17, 8).Value & "-ZF.jpg", _
FilterName:="jpg", Interactive:=False
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Set myChartObject = Nothing
Set myShape = Nothing
End If
.Delete
End With
End With
Application.ScreenUpdating = True
End Sub

Gruß Dirk

Beliebteste Forumthreads (12 Monate)

Tabellenbereich als Bild speichern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

318 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenbereich als Bild speichern

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

318 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread