VBA Outlook 2003 - Dateien automatisch versenden

Option Explicit
Sub senden()

Dim fso As Object, a as Byte
Dim ol As Outlook.Application
Dim olMail As MailItem

Set ol = CreateObject(Outlook.Application)
Set olMail = ol.CreateItem(olMailItem)
Set fso = CreateObject(Scripting.Filesystemobject)


For a = 1 To fso.getfolder(C:/bla/bla).Files.Count

With olMail
  .To = email@empfänger.de
  .Subject = Betreff
  .Attachments.Add (strgAnhang)-> hier soll jeweils die nächste Datei eingefügt werden
  .Send
End With

Set olMail = Nothing
Set ol = Nothing
Set fso = Nothing


Next a
End Sub

Sub OL_DateienImVerzVersenden()

 Const c_VERZEICHNIS_PFAD = C:/bla/bla
 Const c_FILES_EXTENSION = .csv
 
 Dim f() As String->Feld für LangeDateiNamen

 If Not FilesImVerzeichnisBestimmen(c_VERZEICHNIS_PFAD, c_FILES_EXTENSION, f()) Then GoTo AUFRAEUMEN
 If Not FilesPerOutlookVersenden(f()) Then GoTo AUFRAEUMEN

AUFRAEUMEN:
End Sub

'************************************************************************
Private Function FilesPerOutlookVersenden(f() As String) As Boolean

 Const c_MAIL_ADRESSE = [email protected]
 Const c_MAIL_BETREFF = mail an mein Programm
 Const c_MAIL_TEXT = Dies ist eine automatisch erstellte mail.
 
 Dim oOL As Outlook.Application
 Dim oMail As MailItem
 Dim x As Long

 On Error GoTo AUFRAEUMEN

 Set oOL = New Outlook.Application
 For x = LBound(f()) To UBound(f())
  Set oMail = oOL.CreateItem(olMailItem)
  With oMail
    .To = c_MAIL_ADRESSE
    .CC = 
    .BCC = 
    .Subject = c_MAIL_BETREFF
    .Body = c_MAIL_TEXT
    .Attachments.Add f(x)
    .OriginatorDeliveryReportRequested = False
    .ReadReceiptRequested = False
       ->.Display->mit .Display wird die mail erzeugt, aber nicht abgeschickt werden.
   -> .Send ist in diesem Fall auszukommentieren
    .Send
  End With
  Set oMail = Nothing
 Next
 Set oOL = Nothing

 FilesPerOutlookVersenden = True
AUFRAEUMEN:
 If Err.Number <> 0 Then
  MsgBox _
  FehlerNr:  & Err.Number & vbLf & _
  Beschreibung:  & Err.Description & vbLf, _
  vbOKOnly, Fehler beim Mail-Versand
 End If
End Function

'************************************************************************
Private Function FilesImVerzeichnisBestimmen(sPfad As String, sExtension As String, f() As String) As Boolean

 Dim oFso As Object, oFiles As Object, oF As Object
 Dim fCnt As Long, x As Long
 Dim sName As String

-> Verweis auf das FileSystemObject erstellen
 On Error Resume Next: Set oFso = CreateObject(Scripting.FileSystemObject): On Error GoTo 0
 If oFso Is Nothing Then
  MsgBox Scripting.FileSystemObject nicht vorhanden.
  GoTo AUFRAEUMEN
 End If

->prüfen, ob der Pfad vorhamdem ist
 If Not oFso.FolderExists(sPfad) Then
  MsgBox Verzeichnis nicht vorhanden:  & vbLf & sPfad: GoTo AUFRAEUMEN
 End If
 Set oFiles = oFso.getFolder(sPfad).Files

->prüfen, ob Files vorhamden sind
 If oFiles.Count < 1 Then
  MsgBox Keine Datei im Verzeichnis vorhanden:  & vbLf & sPfad
  GoTo AUFRAEUMEN
 End If
 
->Dateiendung prüfen, vollen Dateinamen merken
 fCnt = 0
 ReDim f(1 To oFiles.Count)
 For Each oF In oFiles
  sName = oF.Name
  If LCase(Right(sName, Len(sExtension))) = LCase(sExtension) Then
   fCnt = fCnt + 1
   f(fCnt) = oF.Path
  End If
 Next
 
->prüfen, ob relevante Files vorhanden sind
 If fCnt < 1 Then
  MsgBox Keine relevanten Dateien im Verzeichnis vorhanden:  & vbLf & sPfad
  GoTo AUFRAEUMEN
 End If
 ReDim Preserve f(1 To fCnt)
 
 FilesImVerzeichnisBestimmen = True
AUFRAEUMEN:
 On Error GoTo 0
 Set oFso = Nothing: Set oFiles = Nothing: Set oF = Nothing
End Function