E-Mailversand mit Anhang

Private Sub CommandButton1_Click()
'wenn Outloock Express nicht eingerichtet ist kommt .send Fehler
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim MeinArray() As String, z As Long
Set wb = ActiveWorkbook
Dim iCounter As Integer
Dim sMsg As Variant
On Error GoTo fehler 'geht das auch nicht - Fehlermeldung
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1
Set Flds = iConf.Fields
With Flds
.Item("http:// _
schemas.microsoft.com/cdo/configuration/sendusing")
= 2
.Item("http:// _
schemas.microsoft.com/cdo/configuration/smtpserver")
= "smtp.test.de" ' SMTP-Server
.Item("http:// _
schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
.Item("http:/ _
/schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= 1
.Item("http:// _
schemas.microsoft.com/cdo/configuration/sendusername")
= "test@test.de" ' Benutzername
.Item("http:// _
schemas.microsoft.com/cdo/configuration/sendpassword")
= "passwort" ' smtp Passwort
.Update
End With
For i = 1 To 100
If Cells(i, 3) = "Ja" Then
With iMsg
Set .Configuration = iConf
.To = Cells(i, 1) ' Empfänger
.CC = ""
.BCC = ""
.From = Mailtext.TextBox3 'Name, Absender
.Subject = Mailtext.TextBox2 ' Betreff
.TextBody = "Hallo " & Cells(i, 2) & "," & vbCrLf & vbCrLf & Mailtext.TextBox1 '  _
Mailtext
.AddAttachment Me.ListBox1.List(iCounter) ' Dateianhang
.send
End With
End If
Next i
GoTo weiter
fehler: ' Fehler fals es garnicht geht
MsgBox "Mail nicht versandt."
Exit Sub
weiter:
'Kill TempFilePath & TempFileName
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox i & "Nachricht wurde versendet", vbInformation, "INFO"
'Cancel = True
'End If
End Sub

Private Sub CommandButton2_Click()
Dim varRetVal As Variant
Dim n As Integer
Dim i As Integer
Dim x(100) As String
Dim pfad As String
Dim msg As Integer
i = 0
varRetVal = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel-Dateien (*.xls), *.xls", _
Title:="Eine oder mehrere Dateien zum Öffnen auswählen", _
MultiSelect:=True)
If IsArray(varRetVal) Then
On Error Resume Next
For n = LBound(varRetVal) To UBound(varRetVal)
i = i + 1
Me.ListBox1.AddItem varRetVal(n)
Next
On Error GoTo 0
End If
With Me
.ListBox1.Visible = True
End With
End Sub

Private Sub UserForm_Activate()
With Me
.TextBox3 = "Test "
End With
End Sub