Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
Dim wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Object
Dim objEmail As Object
Dim arrRange As Range
Dim intRow As Integer
Dim iRows As Integer
Dim path As String
Dim strOrdner As String
Dim strBody As String
Dim i As Integer
Set wb = ThisWorkbook
Set ws = ThisWorkbook.Worksheets("Contacts")
Set arrRange = ThisWorkbook.Names("ContactsRange").RefersToRange
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\Users\abcdef\Desktop"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then
MsgBox ("Kein Ordner gew‰hlt")
Exit Sub
End If
For intRow = 1 To arrRange.Rows.Count
If Not IsEmpty(arrRange.Cells(intRow, 1)) = True Then
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(olMailItem)
strBody = "Dear " & arrRange.Cells(intRow, 2) & "," & "<br><br>"
With wb.Worksheets("Options")
For i = 6 To 9
strBody = strBody & .Cells(i, "C").Value & "<br>"
Next i
End With
With objEmail
.GetInspector.Display
.To = arrRange.Cells(intRow, 3)
.Subject = wb.Worksheets("Options").Range("C3").Value & " " & arrRange.Cells(intRow, 1)
.Display
.htmlBody = strBody
.Attachments.Add strOrdner & arrRange.Cells(intRow, 4) & ".xlsm"
End With
Set objEmail = Nothing
Set objOutlook = Nothing
End If
Next intRow
ErrHandler: Exit Sub
End Sub