AW: Email aus excel und anschließend löschen
07.08.2020 20:25:06
Nico
Ich habe versuch den hinweiß einzubauen:
Sub SendRange()
Dim oOutlookApp As Object, oOutlookMessage As Object
Dim oFSObj As Object, oFSTextStream As Object
Dim rngeSend As Range, strHTMLBody As String, strTempFilePath As String
Dim i As Long
On Error Resume Next
Set rngeSend = ActiveSheet.Range("A2:D20")
If rngeSend Is Nothing Then Exit Sub 'User pressed Cancel
On Error GoTo 0
Set oFSObj = CreateObject("Scripting.FilesystemObject")
strTempFilePath = oFSObj.GetSpecialFolder(2)
strTempFilePath = strTempFilePath & "\XLRange.htm"
ActiveWorkbook.PublishObjects.Add(4, strTempFilePath, _
rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
Set oOutlookApp = CreateObject("Outlook.Application")
Set oOutlookMessage = oOutlookApp.CreateItem(0)
For i = 1 To 1 'Für einen Serienbrief muss hier der zweite um die jeweilige Briefanzahl erhö _
ht werden.
oOutlookMessage.To = ActiveSheet.Cells(i, 1) 'Emailadresse
oOutlookMessage.cc = ActiveSheet.Cells(i, 3) 'Kopieempfänger
oOutlookMessage.Subject = ActiveSheet.Cells(i, 2) 'Betreffzeile
Set oFSTextStream = oFSObj.OpenTextFile(strTempFilePath, 1)
strHTMLBody = oFSTextStream.ReadAll
strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", , , vbTextCompare)
oOutlookMessage.htmlbody = strHTMLBody
oOutlookMessage.Send
oOutlookMessage.DeleteAfterSubmit = True
Next i
End Sub
Funktioniert aber leider nicht. Es kommt die Fehlermeldung, Objekt wurde bereits gelöscht oder verschoben.
Was mache ich Falsch?
Vielen Dank & Grüße,
Nico