Option
Explicit
Sub
Mails_SendenLtList()
Dim
WSh
As
Worksheet, sDatei()
As
String
Dim
sPfad
As
String
, sMailtext
As
String
, sSig
As
String
Dim
iZeile
As
Long
, i
As
Long
Dim
oMail
As
Object
, sAnl
As
String
sPfad = "C:\Users\voltm\Documents\Excel-Tabellen\"
Set
WSh = Worksheets(
"Tabelle1"
)
With
CreateObject(
"Outlook.Application"
)
For
iZeile = 2
To
WSh.Cells(Rows.Count,
"C"
).
End
(xlUp).Row
If
WSh.Cells(iZeile,
"C"
).Value <>
""
Then
Set
oMail = .CreateItem(0)
With
oMail
.Getinspector: sSig = .htmlbody
.
To
= WSh.Cells(iZeile,
"C"
).Value
.cc = WSh.Cells(iZeile,
"D"
).Value
.Subject = WSh.Cells(iZeile,
"E"
).Value
sMailtext =
"<span style='font-size:13pt;font-family:Arial;color:#000000;'>"
_
& WSh.Cells(iZeile,
"B"
).Value &
"<br><br>"
_
&
"anbei senden wir Ihnen den unterzeichneten Dienstleistungsrahmenvertrag.<br><br>"
_
&
"Bei Fragen melden Sie sich gerne bei uns.<br>"
_
&
"</span>"
sAnl = WSh.Cells(iZeile,
"F"
).Value
If
sAnl <>
""
Then
sAnl = Replace(sAnl,
";"
,
","
)
sDatei = Split(Replace(sAnl, vbLf,
","
),
","
)
For
i = 0
To
UBound(sDatei)
If
InStr(sDatei(i),
":"
) = 0
Then
sDatei(i) = sPfad & sDatei(i)
End
If
If
Dir(sDatei(i)) <>
""
Then
.attachments.Add sDatei(i)
End
If
Next
i
End
If
.htmlbody = sMailtext & sSig
Rem .send
.display
End
With
Set
oMail =
Nothing
WSh.Cells(iZeile,
"I"
).Value =
"Gesendet"
End
If
Next
iZeile
End
With
End
Sub
viele Grüße
Karl-Heinz