Option
Explicit
Private
Const
C_DIR
As
String
=
"C:\Users\user\Desktop\tmp\Test"
Private
Const
C_RECIPIENT
As
String
=
"someone@somedomain.com"
Private
Const
C_WORKSHEETNAME
As
String
=
"Tabelle1"
Private
Const
C_VALUE
As
String
=
"Aufgabe"
Private
Const
C_SHOWMAILDIALOG
As
Boolean
=
True
Private
Const
C_SUBJECTTASK
As
String
=
"Aufgabe"
Private
Const
C_SUBJECTNOTASK
As
String
=
"Alles OK"
Dim
intWkbCount
As
Integer
, intMailCount
As
Integer
Public
Sub
analyseAndSendMails()
Dim
fso
As
New
FileSystemObject
If
Not
fso.FolderExists(C_DIR)
Then
MsgBox
"Angegebenes Verzeichnis existiert nicht."
, vbExclamation
GoTo
cleanup
End
If
intWkbCount = 0
intMailCount = 0
Dim
foldDir
As
Folder, f
As
File
Dim
colFiles
As
New
Collection
Dim
wkb
As
Workbook
Dim
rng1
As
Range, rng2
As
Range
Dim
cData
As
clsMailData
Set
foldDir = fso.GetFolder(C_DIR)
For
Each
f
In
foldDir.Files
If
f.Type =
"Microsoft Excel-Arbeitsblatt"
Then
intWkbCount = intWkbCount + 1
Set
wkb = Application.Workbooks.Open(f.Path,
ReadOnly
:=
True
)
If
worksheetExists(wkb, C_WORKSHEETNAME)
Then
With
wkb.Worksheets(C_WORKSHEETNAME)
Set
rng1 = .Range(
"A1:A10"
)
Set
rng2 = .Range(
"D1:D10"
)
End
With
Set
cData =
New
clsMailData
With
cData
.Task = containsValue(Union(rng1, rng2), C_VALUE)
.Path = f.Path
End
With
colFiles.Add cData
Set
rng1 =
Nothing
Set
rng2 =
Nothing
End
If
wkb.Close
False
Set
wkb =
Nothing
End
If
Next
f
If
colFiles.Count = 0
Then
MsgBox
"Der Wert '"
& C_VALUE &
"' wurde in keiner Arbeitsmappe gefunden."
, vbInformation
GoTo
cleanup
End
If
sendMails colFiles
MsgBox
"Es wurden "
& intWkbCount &
" Excel Arbeitsmappen gefunden und analysiert."
& vbCrLf & _
"Des Weiteren wurden "
& intMailCount &
" Mails erstellt/versendet."
, vbInformation
cleanup:
If
Err.Number > 0
Then
MsgBox
"Es ist leider ein Fehler aufgetreten."
& vbCrLf & _
"Fehlernummer: "
& Err.Number & vbCrLf & _
"Fehlerbeschreibung: "
& Err.Description, vbExclamation
End
If
If
Not
cData
Is
Nothing
Then
Set
cData =
Nothing
If
Not
rng2
Is
Nothing
Then
Set
rng2 =
Nothing
If
Not
rng1
Is
Nothing
Then
Set
rng1 =
Nothing
If
Not
wkb
Is
Nothing
Then
Set
wkb =
Nothing
If
Not
colFiles
Is
Nothing
Then
Set
colFiles =
Nothing
If
Not
foldDir
Is
Nothing
Then
Set
foldDir =
Nothing
If
Not
fso
Is
Nothing
Then
Set
fso =
Nothing
End
Sub
Private
Function
worksheetExists(
ByRef
wkb
As
Workbook,
ByVal
strWksName
As
String
)
As
Boolean
Dim
wks
As
Worksheet
On
Error
Resume
Next
Set
wks = wkb.Worksheets(strWksName)
On
Error
GoTo
0
worksheetExists =
Not
CBool
(Err.Number)
Set
wks =
Nothing
End
Function
Private
Function
containsValue(
ByRef
rng
As
Range,
ByVal
value
As
String
)
As
Boolean
Dim
c
As
Range
For
Each
c
In
rng.Cells
If
InStr(1, c.value, value)
Then
containsValue =
True
Exit
For
End
If
Next
c
End
Function
Private
Sub
sendMails(
ByRef
colFiles
As
Collection)
Dim
appOut
As
Outlook.Application
Dim
outMail
As
MailItem
On
Error
Resume
Next
Set
appOut = GetObject(
"Outlook.Application"
)
If
appOut
Is
Nothing
Then
Set
appOut = CreateObject(
"Outlook.Application"
)
On
Error
GoTo
0
If
appOut
Is
Nothing
Then
Err.Raise 1,
"sendMails"
,
"Outlook kann nicht gefunden bzw. geöffnet werden."
End
If
End
If
On
Error
GoTo
0
Dim
cData
As
clsMailData
On
Error
GoTo
cleanup
For
Each
cData
In
colFiles
intMailCount = intMailCount + 1
Set
outMail = appOut.CreateItem(olMailItem)
With
outMail
.Recipients.Add C_RECIPIENT
If
cData.Task
Then
.Subject = C_SUBJECTTASK
Else
.Subject = C_SUBJECTNOTASK
End
If
.Body = cData.Path
If
C_SHOWMAILDIALOG
Then
.Display
Else
.Send
End
If
End
With
Set
outMail =
Nothing
Next
cData
On
Error
GoTo
0
cleanup:
If
Not
cData
Is
Nothing
Then
Set
cData =
Nothing
If
Not
outMail
Is
Nothing
Then
Set
outMail =
Nothing
If
Not
appOut
Is
Nothing
Then
Set
appOut =
Nothing
End
Sub