outlook aufklappen Versuch2

Sub ExpandAllFolders()

    Dim objOlApp As Outlook.Application
    Dim objFolder As Outlook.Folder

    On Error Resume Next

    Set objOlApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
       Set objOlApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    Msgbox("Klappe TG-Kontakte auf")
    'Entwicklungsbeispiel, im Echten Testlauf auskommentieren und untere Variante verwenden
    Set objFolder = Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("TG Kontakte").Folders("Asia")

    'Echtes Beispiel: Kann wegen fehlendem Exchange nicht getesetet werden
    'Set objFolder = Session.GetDefaultFolder(olPublicFoldersAllPublicFolder).Folders("Aufgaben DTP").Folders("Aufgaben Office")

    Msgbox("Wechsele wieder zu Posteingang")

    Set objOlApp.ActiveExplorer.CurrentFolder = objFolder
    Set objOlApp.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderInbox)

    Set objFolder = Nothing
    Set objOlApp = Nothing

End Sub