Excel Tabelle in Outlook einfügen

[Pitty-xx]

Das sieht schon super aus!!!!!!!!

Aber natürlich ein kleines Manko, die beiden Grafiken werden nicht angezeigt. Es steht nur der Textverweis "Grafik 1" und "Grafik 2" da.

Die eingebetteten Grafiken werden nicht mit übernommen.

[schauan]

Hallöchen,

werden die Grafiken als Bild angezeigt oder nur als verknüpfte Objekte? Dann musst Du die eingebetteten Objekte wohl erst als File ablegen und dann anhängen.
Hier ging es mal um Datei-Eigenschaften einer eingebundenen Datei in einer Zelle anzeigen, eventuell kann man damit was anfangen. Bin aber jetzt erst mal bis Nachmittag offline.

[Case]

Hallo,

dann so:

Code:

Option Explicit
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim StrBody As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("Test_Datei").Range("A33:H87").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
              vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    StrBody = "This is line 1" & "<br>" & _
              "This is line 2" & "<br>" & _
              "This is line 3" & "<br><br><br>"
    On Error Resume Next
    With OutMail
        .To = "Empf_1@xx.com; Empf_2@xx.com"
        .Cc = "Empf_3@xy.com; Empf_4@xy.com"
        .BCC = ""
        .Subject = "Anrede Betreff"
        .HTMLBody = StrBody & RangeToHtml("Test_Datei", "A33:H87")
        .Display '.Send
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Private Function RangeToHtml( _
    pstrWorksheetName As String, _
    pstrRangeAddress As String) As String

    Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
    Dim strFilename As String, strTempText As String
    Dim blnRangeContainsShapes As Boolean

    strFilename = Environ$("temp") & "\" & _
        Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"

    ThisWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=strFilename, _
        Sheet:=pstrWorksheetName, _
        Source:=pstrRangeAddress, _
        HtmlType:=xlHtmlStatic).Publish True

    Set objFilesytem = CreateObject("Scripting.FileSystemObject")
    Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
    strTempText = objTextstream.ReadAll
    objTextstream.Close

    For Each objShape In Worksheets(pstrWorksheetName).Shapes
        If Not Intersect(objShape.TopLeftCell, Worksheets( _
            pstrWorksheetName).Range(pstrRangeAddress)) Is Nothing Then

            blnRangeContainsShapes = True
            Exit For

        End If
    Next

    If blnRangeContainsShapes Then _
        strTempText = ConvertPictureToMail(strTempText)

    RangeToHtml = Replace(strTempText, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    Set objTextstream = Nothing
    Set objFilesytem = Nothing

    Kill strFilename

End Function

Public Function ConvertPictureToMail(pstrTempText As String) As String

    Const HTM_START = "<link rel=File-List href="
    Const HTM_END = "/filelist.xml"

    Dim strTemp As String
    Dim lngPathLeft As Long

    lngPathLeft = InStr(1, pstrTempText, HTM_START)

    strTemp = Mid$(pstrTempText, lngPathLeft, InStr( _
        lngPathLeft, pstrTempText, ">") - lngPathLeft)
    strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
    strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
    strTemp = strTemp & "/"

    pstrTempText = Replace(pstrTempText, strTemp, Environ$("temp") & "\" & strTemp)

    ConvertPictureToMail = pstrTempText

End Function

[Pitty-xx]

JA!!!

Das ist die Lösung, genau so soll es sein !!!!

Danke, Danke Case !!!!