Wie können dazu sehr viele schöne Dinge mit neuen E-Mails machen, zum Beispiel die E-Mails oder Anhänge ausdrucken, uns die E-Mails vorlesen lassen oder die E-Mails automatisch verarbeiten, zum Beispiel wenn ein Webformular ausgefüllt wurde automatisch einen Kontakt anlegen.

Die Grundfunktion ist folgende:

shared Function GetWord(ByRef s As String) As String
Dim p As Integer
p = InStr(1, s, ",")
If p = 0 Then
     GetWord = s
     s = ""
   Else
      GetWord = Left(s, p - 1)
      s = Mid(s, p + 1)
    End If
End Function

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
   Dim mai As Object
Dim eid As String
On Error Resume Next
Do
    eid = GetWord(EntryIDCollection)
    If eid = "" Then Exit Do
    Set mai = Application.session.GetItemFromID(eid)
    DoSomethingWithMail mai
Loop
End Sub

GetWords ist eine Hilfsfunktion, welche mit Komma separierte Zeichenketten aufsplittet, bei jedem Aufruf kommt das nächste "Wort"

In Application_NewMailEx erhalten wir eine Kommaseparierte Liste von EntryIDs der neuen E-Mails, normalerweise ist dies nur eine einzige, bei Exchange können es aber schon einmal mehrere sein. Wir gehen jetzt in einer Schleife durch die E-Mails durch und öffnen jede einzelne, danach wird DoSomething (MachIrgendwas) mit jeder E-Mail aufgerufen.

Statt DoSomething können wir uns sinnvolle Dinge ausdenken:

Bestimmte eintreffende E-Mails ausdrucken
Die E-Mails (oder den Betreff) vorlesen lassen
Die Anhänge abspeichern
Falls eine E-Mail mit einer VCard eintrift, die VCard automatisch in den Kontakten anlegen.
Falls ein Webform mit Kontaktdaten eintrift, einen Kontakt anlegen
E-Mails automatisch beantworten, zum Beispiel bei Abwesenheit.
usw.

Eintreffende E-Mails ausdrucken

Um die E-Mails auszudrucken, kann folgende Funktion verwendet werden:

' Ausdruck aller Anhänge einer E-Mail

Private Sub PrintMail(mai As Object)
Dim p As String
Dim path As String
Dim ext As String
Dim f As String
Dim l As Integer
Dim printit As Boolean
Dim att As Attachment

p = Space$(256)
l = GetTempPath(255, p)
path = Left(p, l)

For Each att In mai.Attachments
        l = InStr(att.FileName, ".")
        If l <> 0 Then ext = LCase(Mid(att.FileName, l + 1)) Else ext = ""

       ' nachprüfen ob wir drucken wollen
        printit = False
        If ext = "pdf" Then printit = True
        If ext = "doc" Then printit = True
        If ext = "xls" Then printit = True

        If printit Then
             f = path + att.FileName
             att.SaveAsFile f
             ShellExecute 0, "print", f, "", "", SW_SHOW
        End If
   Next att
End Sub

sub DoSomethingWithEmail(mai as object)

PrintIt mai

end sub

Die Funktion sollte noch erweitert werden um zum Beispiel den Betreff oder den Absender zu prüfen, so dass zum Beispiel nur E-Mails aus Faxmails und Bestellungen automatisch gedruckt werden.

Schreiben Sie dazu zum Beispiel:

Private Sub PrintMail(mai As Object)
Dim p As String
Dim path As String
Dim ext As String
Dim f As String
Dim l As Integer
Dim printit As Boolean
Dim att As Attachment

p = Space$(256)
l = GetTempPath(255, p)
path = Left(p, l)

For Each att In mai.Attachments

        if mai.SenderEmailAddress = "faxmail@faxprovider.de" then
             f = path + att.FileName
             att.SaveAsFile f
             ShellExecute 0, "print", f, "", "", SW_SHOW
        End If
   Next att
End Sub

Wenn sie mai als MailItem definieren ist das Programmieren einfacher, weil Outlook nach der Eingabe des Punktes alle möglichen Felder des Objektes vorschlägt. Im Betrieb sollte es object sein, weil eine eigehende E-Mail nicht immer ein MailItem ist, was dann im Script einen Fehler produzieren würde.

Anhänge abspeichern

shared Function SaveMail(basedir As String, item As Object)
Dim attach As Attachment
Dim fname As String
If item.Attachments.count > 0 Then
    ' Verzeichnisname = Absendername
    ' Alternativ kann man auch item.subject verwenden oder Datum oder alles Zusammenbauen
     fname = basedir & MakeFname(item.SenderName)
     On Error Resume Next
     ' Dies weglassen wenn man nur VCARDS will
      MkDir fname
     On Error GoTo 0
     For Each attach In item.Attachments
          fname = basedir & "vcards\" & MakeFname(attach.filename)
          attach.SaveAsFile fname
          ReadDefaultFolderVCard fname, item.SenderEmailAddress
          End If
     Next attach
End If
End Function

S A V E