[Outlook / VBA]Anhänge automatisch speichern ... Problem mit Focus

[Piatch]

Hallo,

ich habe nun folgendes Problem. Ich habe mir ein kleines Outlook script aus den Internet besorgt, welches die Anhänge speichert.

Nun speichert es aber immer nur von der Email die Anhänge welche gerade in Outlook markiert ist! Das ist natürlich falsch.

Meine Frage ist nun, wie bekomm ich es hin das wenn ich eine neue E-Mail bekomme, der Focus sofort auf diese gesetzt wird? Das würde mein Problem ja schon beheben.

Hier mal das Script welches ich nutze:

Sub AnhaengeSpeichern()


   'Festlegen der Parameter

    Dim myOrt As String

    Dim myOlApp As New Outlook.Application

    Dim myOlExp As Outlook.Explorer

    Dim myOlSel As Outlook.Selection

    Dim myteils, myteil, myAnhänge, myAnhang As Object

    'Hier wird nach dem Ort gefragt wo gespeichert werden soll, wenn Sie den Pfad ändern. Muss dieser vorher schon erstellt sein

    myOrt = "Y:\"

    'On Error Resume Next

    'arbeitet die einzelnen Nachrichten ab



    Set myOlExp = myOlApp.ActiveExplorer

    Set myOlSel = myOlExp.Selection

    'für alle Teile...

    For Each myteil In myOlSel

       'Anhänge festlegen

       Set myAnhänge = myteil.Attachments

        'wenn welche dar sind, dann

        If myAnhänge.Count > 0 Then

            'fügt einen Hinweis in die Email ein

            myteil.Body = myteil.Body & vbCrLf & "Entfernte Anhänge:" & vbCrLf

            'und für alle Anhänge...

            For i = 1 To myAnhänge.Count

                'nun werden Sie am Speicherort abgeleg

                myAnhänge(i).SaveAsFile myOrt & myAnhänge(i).DisplayName

                'hier wird Name und der Ort in der Nachricht eingetragen

                myteil.Body = myteil.Body & "Datei: " & myOrt & myAnhänge(i).DisplayName & vbCrLf

            Next i

            'für alle Anhänge...

            While myAnhänge.Count > 0

                'entferne es (wird für Outlook 2002/2003 benötigt)

                'myAnhänge.Remove 1

                 'entferne es (wird für Outlook 2000 benötigt)

               myAnhänge(1).Delete

            Wend

            'abspeichern ohne Anhang

            myteil.Save

        End If

    Next

    'free variables

    Set myteils = Nothing

    Set myteil = Nothing

    Set myAnhänge = Nothing

    Set myAnhang = Nothing

    Set myOlApp = Nothing

    Set myOlExp = Nothing

    Set myOlSel = Nothing

'Resume

End Sub

Die Outlook Version ist 2007 Ich hoffe mir kann da einer helfen