Bild Export - schlechte Qualität

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
schau mal ob die Qualität damit besser ist. Vom verkleinern würde ich abraten denn das macht das Bild nicht besser.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef PicDesc As PICT_DESC, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As LongPtr, _
    ByRef IPic As IPicture) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
    ByVal handle As LongPtr, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
    ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As Any, _
    ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type PICT_DESC
Size As Long
Type As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

Private Const PICTYPE_BITMAP As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG  As Long = &H4
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Private llngptrCopy As LongPtr

Private Function Paste_Picture() As IPictureDisp
    
    Dim lngReturn As Long, lngptrPointer As LongPtr
    
    If Cbool(IsClipboardFormatAvailable(CF_BITMAP)) Then
        
        lngReturn = OpenClipboard(Application.hwnd)
        
        If lngReturn > 0 Then
            
            lngptrPointer = GetClipboardData(CF_BITMAP)
            
            llngptrCopy = CopyImage(lngptrPointer, _
                IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            
            Call CloseClipboard
            
            If lngptrPointer <> 0 Then Set Paste_Picture = _
                Create_Picture(llngptrCopy, 0&)
            
        End If
    End If
End Function

Private Function Create_Picture( _
        ByVal lngptrhPic As LongPtr, _
        ByVal lngptrhPal As LongPtr) As IPictureDisp
    
    Dim udtPicInfo As PICT_DESC, udtID_IDispatch As GUID
    Dim objPicture As IPictureDisp
    
    Call CLSIDFromString(StrPtr( _
        GUID_IPICTUREDISP), udtID_IDispatch)
    
    With udtPicInfo
        .Size = Len(udtPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = lngptrhPic
        .hPal = lngptrhPal
    End With
    
    Call OleCreatePictureIndirect(udtPicInfo, _
        udtID_IDispatch, 0, objPicture)
    
    Set Create_Picture = objPicture
    
    Set objPicture = Nothing
    
End Function

Public Sub SaveRange()
    
    Dim objPicture As IPictureDisp
    
    Call OpenClipboard(Application.hwnd)
    Call EmptyClipboard
    Call CloseClipboard
    
    Call Tabelle1.Range("B2:F42").CopyPicture( _
        Appearance:=xlScreen, Format:=xlBitmap)
    
    Set objPicture = Paste_Picture()
    
    If Not objPicture Is Nothing Then
        Call SavePicture(objPicture, Environ$("Temp") & "\TempExport.bmp")
    Else
        Call MsgBox("Error - Picture can't saved", vbCritical, "Error")
    End If
    
    Call DeleteObject(llngptrCopy)
    
    Set objPicture = Nothing
    
End Sub


Gruß

Nepumuk

Beliebteste Forumthreads (12 Monate)

Bild Export - schlechte Qualität

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread