Hallo,
ich habe aktuell einen Code geschrieben um eine automatische Email mit gleichem Anhang an verschiedene Empfänger zu senden.
Nun würde ich gern ebenfalls den "Body" der Email basierend auf einem Word Dokument einfügen, bekomm es aber leider nicht hin.
Aktuell habe ich den "Body" noch von Zelle zu Zelle formatiert.
Vielleicht kann jemand von euch helfen.
Vielen Dank im Voraus.
BG
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Daten")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = cell.Offset(-1, 4).Value
.Body = cell.Offset(0, 4).Value & " " & cell.Offset(0, -1).Value & "," & Chr(13) & cell.Offset(1, 4).Value & Chr(13) & cell.Offset(2, 4).Value & Chr(13) & cell.Offset(3, 4).Value & Chr(13) & cell.Offset(4, 4).Value & Chr(13) & cell.Offset(5, 4).Value & Chr(13) & cell.Offset(6, 4).Value & Chr(13) & cell.Offset(7, 4).Value & Chr(13) & cell.Offset(8, 4).Value & Chr(13) & cell.Offset(9, 4).Value & Chr(13) & cell.Offset(10, 4).Value & Chr(13) & cell.Offset(11, 4).Value & Chr(13) & cell.Offset(12, 4).Value & Chr(13)
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
|