Range2HTML - EMail mit HTML-Text und Bildern

[volti]

Hallo,

heute stelle ich mal mein Range2HTML hier zur weiteren Verwendung bereit.

Das alte im Netz zu findende RangeToHTML ist größer und m.E. ohne Bilderverarbeitung.

Natürlich lassen sich Tabellenbereiche und Bilder auch über .Paste in Mails einfügen, aber das soll in anderen Artikeln behandelt werden.

Code:

Option Explicit

Private Sub Mail_BereichalsBereich_Range2HTML()
' Sendet Mail mit integriertem Bereich mit Signatur
' Bereich wird über Range2HTML bereitgestellt
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sMailtext As String, sBer As String
  
  sBer = "A1:J20"                                   ' Kopierbereich
  Set WSh1 = ThisWorkbook.Sheets("Tabelle1")        ' Blatt mit Maildaten
  Set WSh2 = ThisWorkbook.Sheets("Tabelle2")        ' Datenblatt
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .BodyFormat = 2                               ' HTML-Format, Angabe optional
      .Subject = WSh1.Range("A2").Value             ' Betreff
      .To = WSh1.Range("A3").Value                  ' Empfänger
      .Cc = WSh1.Range("A4").Value                  ' Kopie an
'     .Bcc = WSh1.Range("A4").Value
      sMailtext = WSh1.Range("A5").Value            ' Mailtext
      .GetInspector                                 ' Signatur
      .HTMLBody = Replace(sMailtext, vbLf, "<br>") _
      & Range2Html(WSh2.Range(sBer)) & .HTMLBody
      .Display
  End With

End Sub

Private Function Range2Html(oBereich As Range) As String
' Gibt den angegebenen Bereich als HTML zurück, incl.Bilder
  Dim sTmpDatei As String, sTmp As String, sTmpVz As String
  Dim iff As Integer, P As Long

' Bereich in Datei exportieren
  With oBereich
      sTmpVz = Environ$("temp") & "\"
      sTmpDatei = sTmpVz & Format(Now, "ddmmyy" & Int(Timer) * 10) & ".htm"
      .Parent.Parent.PublishObjects.Add( _
              SourceType:=xlSourceRange, _
              Filename:=sTmpDatei, Sheet:=.Parent.Name, _
              Source:=.Address, _
              HtmlType:=xlHtmlStatic).Publish Create:=True
      iff = FreeFile
      Open sTmpDatei For Input As iff
      Range2Html = Replace(Input(LOF(iff), iff), "align=center x:publishsource=", _
                   "align=left x:publishsource=")
      Close iff

' Feststellen, ob auch Bilder im Bereich sind
      P = InStr(1, Range2Html, "<link rel=File-List href=") + 26
      If P > 26 Then
         sTmp = Mid$(Range2Html, P, InStr(P, Range2Html, "/filelist.xml") - P)
         Range2Html = Replace(Range2Html, sTmp, sTmpVz & sTmp)
      End If
      
  End With
  
  On Error Resume Next
  Kill sTmpDatei
  Kill sTmpVz & sTmp

End Function

_________
viele Grüße
Karl-Heinz