Thema Datum  Von Nutzer Rating
Antwort
21.11.2017 23:51:04 Susanne
NotSolved
Blau Dateien im Verzeichnis prüfen und wenn Bedingung erfüllt Email versenden
22.11.2017 14:19:34 SJ
NotSolved
22.11.2017 22:08:42 Susanne
NotSolved
23.11.2017 07:25:08 SJ
NotSolved
23.11.2017 19:01:41 Susanne
NotSolved
24.11.2017 07:44:04 SJ
NotSolved
24.11.2017 16:44:00 Susanne
NotSolved
24.11.2017 17:06:01 SJ
NotSolved
24.11.2017 18:00:43 Susanne
NotSolved
25.11.2017 10:10:27 SJ
NotSolved
04.12.2017 22:56:07 Susanne
NotSolved
05.12.2017 14:51:24 SJ
NotSolved

Ansicht des Beitrags:
Von:
SJ
Datum:
22.11.2017 14:19:34
Views:
852
Rating: Antwort:
  Ja
Thema:
Dateien im Verzeichnis prüfen und wenn Bedingung erfüllt Email versenden

Hallo,

hier eine Lösung für das Problem:

clsMailData:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit
 
'//Daten
Private strPath As String
Private blnOk As Boolean
 
Public Property Get Path() As Variant
    Path = strPath
End Property
 
Public Property Let Path(ByVal vNewValue As Variant)
    strPath = vNewValue
End Property
 
Public Property Get Task() As Variant
    Task = blnOk
End Property
 
Public Property Let Task(ByVal vNewValue As Variant)
    blnOk = vNewValue
End Property

modSendMails:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
Option Explicit
 
'//Verweise
'//Microsoft Scripting Runtime
'//Microsoft Outlook xx.x Object Library
 
'//Konstanten (Einstellungen) -> Bitte anpassen!
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"
 
'//Daten
Dim intWkbCount As Integer, intMailCount As Integer
 
'//Hauptroutine
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

Bitte die Einstellungen anpassen und anschließend einen Test mit einem Verzeichnis durchführen, in dem 3 Arbeitsmappen liegen.

Eine kurze Rückmeldung wäre nett.

Viele Grüße


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen