VBA: Outlook-Mail-Export

[freeman_sb]

Hallo Leute,

folgendes Problem aus dem ich einfach nicht schlau werde.

Ich habe ein Makro geschrieben, das je nach Useraktion zwei unterschiedliche Funktionen ausführt. Es werden aber in jedem Fall Mails aus dem Posteingang in Outlook in ein Verzeichnis exportiert.

Das Programm funktioniert soweit einwandfrei, jedoch überspringt es ohne ersichtlichen Grund immer wieder Nachrichten im Posteingang und exportiert diese nicht. Ich habe schon getestet, getan und gemacht was ich nur konnte. Es ist einfach nur völlig irrational!

Jemand eine Idee? Der Fokus sollte auf den for - each - Schleifen liegen...

'------------------------------------------------------------------------------------------------------------------------

'Programm ermöglicht das Exportieren von Nachrichten in das Dateisystem

'hierzu werden die Nachrichten im Posteingang auf den Absender und Betreff überprüft

'es sind zwei unterschiedliche Exportmethoden möglich - eine vordefinierte für den Absender ************, dass

'** Zielverzeichnisse berücksichtigt - je nach Betreffzeile

'oder die Methode, welche Nachrichten auf Absender überprüft und diese in ein eingegebenes Verzeichnis exportiert und löscht

'hierzu muss der User in einem Formular Absender und Zielverzeichnis eingeben.


'Erstellt von: ********** Fachinformatiker Anwendungsentwicklung (FIAE)

'Stand: 19.06.2007


Option Explicit


'benötigte globale Konstante(n)

'------------------------------------------------------------------------------------------------------------------------

Const fill As String = "_"

'------------------------------------------------------------------------------------------------------------------------


Public WithEvents myOlItems As Outlook.Items


Public Sub Initialize_handler()


    Set myOlItems = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(5).Items


End Sub


'Startoption des Codes festlegen. Bei Wunsch bitte anpassen!-------------------------------------------------------------


'Programmstart bei Eingang jeder neuen Nachricht

'Private Sub Application_NewMail()


'Programmstart beim Starten des Email - Clients Outlook.exe

Private Sub Application_Startup()


'Programmstart beim Beenden von Outlook

'Private Sub Application_Quit()


'Konfigurationsbereich -hier können Anpassungen vorgenommen werden-

'------------------------------------------------------------------------------------------------------------------------

'String für Absenderadresse

Dim Absender As String

'String(s) für (die) Zielordner

Dim DestinationFolderTest As String

Dim DestinationFolder1 As String

Dim DestinationFolder2 As String

Dim DestinationFolder3 As String

Dim DestinationFolder4 As String

'------------------------------------------------------------------------------------------------------------------------


'Variablendeklaration

'------------------------------------------------------------------------------------------------------------------------

Dim OApplication As Application

Dim Folder As MAPIFolder

Dim Folder2 As MAPIFolder

Dim Message As Object

Dim DestinationFolder As String

Dim MessageSubject As String

Dim pos1 As Integer

Dim pos2 As Integer

Dim List As Variant

Dim StrTemp As String

Dim decision1 As String

Dim decision2 As String

Dim counter As Integer

Dim error As Integer

Dim Verzeichnis As String

'------------------------------------------------------------------------------------------------------------------------


'Variableninitialisierung

'------------------------------------------------------------------------------------------------------------------------

Set OApplication = CreateObject("Outlook.Application")

'Folder wird auf Posteingang gesetzt

Set Folder = OApplication.Session.GetDefaultFolder(olFolderInbox)

'Debug.Print (Folder)

'Debug.Print (OApplication.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox))

Set Folder = OApplication.Session.GetDefaultFolder(olFolderInbox)




'Festlegung der Zielverzeichnisse -- Reihenfolge nicht verändern! -- Anpassung hier vornehmen

'-------------------------------------------------------------------------------


DestinationFolder1 = "M:\Daten\testing\"

DestinationFolder2 = "M:\Daten\testing\"

DestinationFolder3 = "M:\Daten\testing\"

DestinationFolder4 = "M:\Daten\testing\"


'-------------------------------------------------------------------------------

pos1 = 0

pos2 = 0

counter = 0

'------------------------------------------------------------------------------------------------------------------------

'Userabfrage ob die Nachrichten jetzt exportiert und aus dem Posteingang gelöscht werden sollen

decision1 = MsgBox("Möchten sie nun Nachrichten von '******' in die Verzeichnisse exportieren und aus dem Posteingang löschen?", vbYesNo, "Nachrichten exportieren?")

If decision1 = vbYes Then

'Programmbeginn

'Jede Nachricht im globalen Posteingang wird auf den Absendernamen überprüft

'For Each Folder2 In Folder.Folders

For Each Message In Folder.Items

    'handelt es sich auch um ein MailItem - Objekt?

    If TypeOf Message Is MailItem Then

    If (Message.SenderName = "******") Then

        counter = counter + 1

        StrTemp = Message.Subject

        'Auswertung von StrTemp und schreiben der Dateien

        If StrTemp Like "***********************" Then

            MessageSubject = FileName(Message.Subject)

            Message.SaveAs (DestinationFolder1 & MessageSubject & ".txt"), olTXT

        ElseIf StrTemp Like "*******************" Then

            MessageSubject = FileName(Message.Subject)

            Message.SaveAs (DestinationFolder2 & MessageSubject & ".txt"), olTXT

        ElseIf StrTemp Like "*******************" Then

            MessageSubject = FileName(Message.Subject)

            Message.SaveAs (DestinationFolder3 & MessageSubject & ".txt"), olTXT

        ElseIf StrTemp Like "*******************" Then

            MessageSubject = FileName(Message.Subject)

            Message.SaveAs (DestinationFolder4 & MessageSubject & ".txt"), olTXT

	'usw.

	Else

        error = error + 1

        End If

        'Löschen der Nachricht

        Message.Delete

        StrTemp = ""

    End If

    'pos1 = 0

    'pos2 = 0

    StrTemp = ""

    End If

Next

'Next

'Message Box mit der Anzahl der exportierten Nachrichten anzeigen


If counter > 1 Then

    MsgBox "Es wurden " & counter & " Nachrichten gefunden, exportiert und aus dem Posteingang entfernt", vbInformation

ElseIf counter = 1 Then

    MsgBox "Es wurde " & counter & " Nachricht gefunden, exportiert und aus dem Posteingang entfernt", vbInformation

ElseIf counter = 0 Then

    MsgBox "Es wurden keine Nachrichten des Absenders '**********' im Posteingang gefunden", vbInformation

End If

'Sollten Fehler aufgetreten sein werden diese hier ausgegeben

If error <> 0 Then

    MsgBox ("Bei " & error & " Nachricht(en) konnte die Betreffzeile nicht ausgewertet werden, da diese unbekannt ist. Bitte im Quellcode korrigieren und gelöschte Nachrichten mit exportieren Nachrichten vergleichen und ggf. wieder herstellen."), vbInformation

End If

'Ressourcen freigeben

Set Message = Nothing

Set Folder = Nothing

Set OApplication = Nothing

counter = 0

error = 0

Else

'Exportierne anderer Nachrichten ermöglichen

decision2 = MsgBox("Möchten sie Nachrichten eines anderen Absenders in ein Verzeichnis exportieren?", vbYesNo, "Nachrichten exportieren?")

If decision2 = vbYes Then

UserForm1.Show

'Idle solange bis der OK Button des Formulares betätigt wurde

Do While UserForm1.ActiveControl = True

'Idle-Prozess

Loop

Absender = UserForm1.TextBox1.Value

Verzeichnis = UserForm1.TextBox2.Value & "\"

'Debug.Print (Absender)

'Debug.Print (Verzeichnis)

'Programmbeginn

'Jede Nachricht im globalen Posteingang wird auf den Absendernamen überprüft

'For Each Folder2 In Folder.Folders

For Each Message In Folder.Items

'Überprüfung ob es sich tatsächlich auch um ein MailItem - Objekt handelt

'Debug.Print TypeName(Message)

If TypeOf Message Is MailItem Then

    If (Message.SenderName = Absender) Then

        counter = counter + 1

        'Debug.Print (Absender)

        MessageSubject = FileName(Message.Subject)

        Message.SaveAs (Verzeichnis & " - " & Absender & " - " & " " & MessageSubject & ".txt"), olTXT

        'Nachricht löschen

        Message.Delete

    End If

Else

End If

Next

'Next

'UserForm zurücksetzen

UserForm1.TextBox1.Value = "Absender so eingeben wie im Posteingang angezeigt!"

UserForm1.TextBox2.Value = "M:\Daten"

'Ausgabe für User generieren

If counter = 0 Then

    MsgBox ("Es wurden keine Nachrichten vom Absender '" & Absender & "' im Posteingang gefunden."), vbInformation

ElseIf counter = 1 Then

    MsgBox ("Es wurde eine Nachrichten vom Absender '" & Absender & "' im Posteingang gefunden, exportiert und gelöscht."), vbInformation

Else

    MsgBox ("Es wurden " & counter & " Nachrichten vom Absender '" & Absender & "' im Posteingang gefunden, exportiert und gelöscht."), vbInformation

End If

ElseIf decision2 = vbNo Then

End If

counter = 0

End If

End Sub


'Mit dieser Funktion wird ein "erlaubter Dateiname generiert um die Nachrichten abspeichern zu können"

Private Function FileName(IncomingString As String) As String

Dim Temp As String

    Temp = IncomingString

    Temp = Replace(Temp, "/", fill)

    Temp = Replace(Temp, "\", fill)

    Temp = Replace(Temp, "*", fill)

    Temp = Replace(Temp, "?", fill)

    Temp = Replace(Temp, """", fill)

    Temp = Replace(Temp, "<", fill)

    Temp = Replace(Temp, ">", fill)

    Temp = Replace(Temp, "|", fill)

    Temp = Replace(Temp, ":", fill)


    FileName = Temp

End Function