Markierte Zeilen aus Tabelle per Mail versenden

[mellow]

Morgen zusammen,

Ich möchte gerne 1 oder mehrere Markierte Zeilen aus einem Tabellenblatt per Mail versenden. Ich habe im Internet folgendes Makro gefunden, aber da gibts nur ein Haken.

Code:

Option Explicit

Public Sub TableToMail()
    Dim objOutlook As Object
    Dim objMail As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .to = ""
        .Subject = "Test " & CStr(Date)
        .HTMLBody = RangeToHTML(ActiveSheet, ActiveSheet.Range("A1:L100"))
        .Display    'nur Anzeigen
'        .Send       'direkt senden
    End With
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

Private Function RangeToHTML(objSheet As Worksheet, objRange As Range) As String
    Dim strFilename As String
    strFilename = Environ$("TEMP") & "/" & Format(Now, "dd-mm-yyyy_hh-mm-ss") & ".htm"
    ActiveWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=strFilename, _
        Sheet:=objSheet.Name, _
        Source:=objRange.Address, _
        HtmlType:=xlHtmlStatic).Publish True
    RangeToHTML = CreateObject("Scripting.FileSystemObject"). _
        GetFile(strFilename).OpenAsTextStream(1, -2).ReadAll
    Kill strFilename
End Function

Es soll nur markierte Zeile oder Zeilen in Outlook übernehmen und nicht den ganzen Bereich in Outlook einfügen.

Code:

HTMLBody = RangeToHTML(ActiveSheet, ActiveSheet.Range("A1:L100"))

Danke

Gruß Mellow

[RPP63]

Moin!
Setze
.HTMLBody = RangeToHTML(ActiveSheet, Selection)

Aber Achtung!
Es muss ein zusammenhängender Bereich sein!
Außerdem sollte am Anfang überprüft werden, ob die Voraussetzungen erfüllt sind.
Mal quick & dirty:

Public Sub TableToMail()
    Dim objOutlook As Object
    Dim objMail As Object
    If TypeName(Selection) = "Range" Then
      If Selection.Areas.Count = 1 Then
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
        With objMail
            .to = ""
            .Subject = "Test " & CStr(Date)
            .HTMLBody = RangeToHTML(ActiveSheet, Selection)
            .Display    'nur Anzeigen 
    '        .Send      'direkt senden 
        End With
        Set objMail = Nothing
        Set objOutlook = Nothing
      End If
    End If
End Sub

Gruß Ralf

[mellow]

Guten Morgen,

Ich hab das mal getestet.....bekomme aber immer diese Fehlermeldung bei RangeToHTML

Siehe Bild

Gruß Mellow

[RPP63]

Die Function RangeToHTML() aus Deiner Threaderöffnung darfst Du natürlich nicht löschen!

[mellow]

Morgen,

hat funktioniert ,Danke


Gruß Mellow