AW: Email per Makro mit definierten Werten
27.01.2009 11:46:00
Claus
Könnten Sie mir bitte noch sagen wo ich etwas im u.g. Makro ändern muss damit er
die BCC Empfänger aus A1 nimmt. Die AN Empfänger aus A2. Den Betreff aud A3 und Emailtext aus A4.
Vielen Dank! Viele Grüße
Claus
Sub MailBodyDialog()
Dim rng As Range
Dim olapp As Object
Set olapp = CreateObject("Outlook.Application")
With olapp.CreateItem(0)
Set rng = Selection
.HtmlBody = RangetoHTML(rng)
.to = "mail@server.de" 'Empfänger
.cc = "mail1@server.de,mail2@server.de,mail3@server.de" 'optional Kopie an
'.bcc = "mail1@server.de,mail2@server.de,mail3@server.de" 'optional Blindkopie an
'.ReadReceiptRequested = True ' optional Lesbestätigung anfordern
.Display
End With
Set rng = Nothing
Set olapp = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim Fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set Fso = Nothing
Set TempWB = Nothing
End Function