Bild Export - schlechte Qualität
30.03.2016 18:51:25
Rudolf
Hallo Zusammen
Ich habe für mein Büro ein Userform eingerichtet, bei dem nach einem click die erfassten Daten in eine Template Tabelle eingefügt werden und gleichzeitig ein Email generiert und das Template-Bereich als Bild(ChartObject) in das Email kopiert wird.
Nur leider wirkt das Bild verschwommen im Email und das sieht nicht so schön aus.
Gleichzeitig möchte ich das Bild mit verkleinern damit es besser aussieht.
Wie kriege ich es hin, dass das Bild bzw. Chart Object welche der Code aus eine template Tabelle rauskopiert auch wirklich hochauflösend im Email aussieht?
Ich habe den u.a. Code als Modul, welches beim CLICK auf den Command Button per Call ausgeführt wird
Sub Email()
' Export Range as JPG file
' Set Range you want to export to file
Dim r As Range
Dim co As ChartObject
Dim picFile As String
Set r = Tabelle4.Range("B2:F42")
' Copy range as picture onto Clipboard
r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
picFile = Environ("Temp") & "\TempExportChart.jpg"
' Create an empty chart with exact size of range copied
Set co = r.Parent.ChartObjects.Add(Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:=r. _
Height)
With co
' Paste into chart area, export to file, delete chart.
.Chart.Paste
.Chart.Export picFile
.Delete
End With
' Create Email and Import Picture
' Send out the email
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(olMailItem)
Dim signature As String
Dim tstamp As String
Dim strBody As String
' Subject location
OutMail.Display
signature = OutMail.HTMLBody
' Change change email list here
strBody = "Dear Collegues
We will execute following trade
Bewerten Sie hier bitte das Excel-Portal
Best regards
Value _
Team"
On Error Resume Next
With OutMail
.To = Tabelle4.Range("I2")
.CC = Tabelle4.Range("I3")
.BCC = Tabelle4.Range("I4")
.Subject = Tabelle4.Range("I5")
.HTMLBody = strBody & vbNewLine & signature
.Attachments.Add Sheets("Save and Send").Range("D4") & Sheets("Save and Send").Range(" _
_
D23") ' attaching the pdf
End With
Kill picFile
On Error GoTo 0
'Tidy Up
Set OutMail = Nothing
Set OutApp = Nothing
Set co = Nothing
Set r = Nothing
End Sub