AW: Mail versenden - Range in body + sheet im Anhang
19.08.2013 17:40:20
Vat
Hallo René,
das script habe ich jetzt eingebunden. die mail wird auch mit dem selektierten Bereich generiert. Leider bekomme als HTMLBody nur besagte selektion und nicht meine dynamische Range (H2:M-letzte befüllte zeile).
Range(Cells(1, 8), Cells(Cells(65536, 13).End(xlUp).Row, 13))
funktioniert nicht.
Dann müsste ich noch tabelle1 als Datei- Anhang anhängen.
Es ist für mich immer wieder das gleiche Problem... Entweder das eine geht oder das andere. Ich bekomme beides nicht kombiniert.
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
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 = "xxx@xxx.de" 'Empfänger
'.cc = "" 'optional Kopie an
'.bcc = "" 'optional Blindkopie an
'.ReadReceiptRequested = True ' optional Lesbestätigung anfordern
.Display
End With
Set rng = Nothing
Set olapp = Nothing
End Sub
Danke und Grüße
Vat