Mails aus Excel versenden

Private Sub CommandButton1_Click()
Sub Verteilen()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim intRow As Integer, intCounter As Integer
Dim strFile As String, strRecipient As String, strSubject As String
Dim strBody As String
Dim bolStatusBar
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
bolStatusBar = Application.DisplayStatusBar
intRow = Cells(Rows.Count, 1).End(xlUp).Row
Set objOutlook = CreateObject("Outlook.Application")
For intCounter = 2 To intRow
strRecipient = Cells(intCounter, 1)
strFile = Cells(intCounter, 2)
strSubject = Cells(intCounter, 3)
strBody = Cells(intCounter, 4)
Application.StatusBar = "Sende Datei " & strFile & " an " & strRecipient & "..."
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
Set objOutlookRecip = .Recipients.Add(strRecipient)
objOutlookRecip.Type = olTo
.Subject = strSubject
.Body = strBody & vbLf & vbLf
Set objOutlookAttach = .Attachments.Add(strFile)
objOutlookRecip.Resolve
.Send
End With
Next intCounter
Set objOutlook = Nothing
Application.StatusBar = False
Application.DisplayStatusBar = bolStatusBar
End Sub