öffentliche Ordner per Skript in Outlook hinzufügen

Const olPublicFoldersAllPublicFolders = 18
Dim olkApp, olkSes, olkFolder, foldersArr

Set olkApp = CreateObject("Outlook.Application")  
Set olkSes = olkApp.GetNameSpace("MAPI")  

Set foldersArr = CreateObject("System.Collections.ArrayList")  

'Change the profile name on the next line'  
olkSes.Logon olkApp.DefaultProfileName
On Error Resume Next

' public folders  
foldersArr.Add "Gemeinsame Kontakte"  

For Each folderStr In foldersArr
	'Add Public Folder to Favorites  

	'Public Folders  
	Set olkFolder = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders)
	'SubFolders  
	arrFolders = Split(folderStr, "\")  
    For Each varFolder In arrFolders
		Set olkFolder = olkFolder.Folders(varFolder)
	Next
	
	olkFolder.AddToPFFavorites

Next

olkSes.Logoff
Set olkApp = Nothing
Set olkSes = Nothing
Set olkFolder = Nothing
WScript.Quit

Sub AddFavoriteFolder(olkFolder)
    ' Purpose: Add a folder to Favorite Folders.'  
    ' Written: 5/2/2009'  
    ' Author:  BlueDevilFan'  
    ' Outlook: 2007'  
    Const olModuleMail = 0
    Const olFavoriteFoldersGroup = 4
        Dim olkPane, olkModule, olkGroup
    Set olkPane = olkApp.ActiveExplorer.NavigationPane
    Set olkModule = olkPane.Modules.GetNavigationModule(olModuleMail)
    Set olkGroup = olkModule.NavigationGroups.GetDefaultNavigationGroup(olFavoriteFoldersGroup)
    olkGroup.NavigationFolders.Add olkFolder
    Set olkPane = Nothing
    Set olkModule = Nothing
    Set olkGroup = Nothing
End Sub