AW: Makro für Mail aus Excel
09.05.2016 18:58:23
Nepumuk
Hallo,
teste mal:
Option Explicit
Public Sub SendMail()
Dim objOutlook As Object, objMail As Object
Dim objCell As Range
Dim strTo As String, strSubject As String
With Worksheets("Output")
strSubject = .Cells(1, 1).Text
For Each objCell In .Range("T2:T10")
If Not IsEmpty(objCell.Value) Then strTo = strTo & objCell.Text & ";"
Next
strTo = Left$(strTo, Len(strTo) - 1)
End With
Set objOutlook = CreateObject(Class:="Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = strTo
.Subject = strSubject
.HTMLBody = RangeToHtml("Output", "A4:O18")
.Display 'zum testen
' .Send 'direkt senden
End With
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
Private Function RangeToHtml( _
ByVal pvstrWorksheetName As String, _
ByVal pvstrRangeAddress As String) As String
Dim objFilesytem As Object, objTextstream As Object
Dim strFilename As String, strTempText As String
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_hh-mm-ss") & ".htm"
Call ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=pvstrWorksheetName, _
Source:=pvstrRangeAddress, _
HtmlType:=xlHtmlStatic).Publish(Create:=True)
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
Call objTextstream.Close
RangeToHtml = Replace(strTempText, "align=center x:publishsource=", _
"align=left x:publishsource=")
Set objTextstream = Nothing
Set objFilesytem = Nothing
Call Kill(PathName:=strFilename)
End Function
Gruß
Nepumuk