Outlook Public Folder Favorites

I'm not aware of a group policy solution, but I'm not an expert on group policy.  Here's a macro-based solution I put together for another question: https://www.experts-exchange.com/questions/24429373/Is-there-a-way-to-create-a-shortut-to-a-public-folder-in-Outlook-2007.html

I'm not sure what the difference between VBA and VBS is, but you mention you can make this work in VBS. Can you provide a script that works using VBS?

There are a number of differences between VBA (Visual Basic for Applications) and VBS (VBScript).  In this context the biggest difference is that VBA code has to be added to Outlook.  VBS runs from outside of Outlook.  I'll modify the code in the article I linked to so it runs under VBScript.

Thank you so much. I will test this in a couple of days and let you know.

I tried using the script provided but I get an error on Line 26 character 1, so I put on Error Resume Next on line 24 and that resolved the error.  This works well on Outlook 2007, but in Outlook 2010 the path to the public folder is different.  

Ex.
Outlook 2007: ("\Public Folders\All Public Folders\Staff Contacts")
Outlook 2010: ("\Public Folders - user@domain.org\All Public Folders\Staff Contacts")

user@domain.org is different depending on the user's primary SMTP address.  I tried various things, as I was going to try to insert a variable SMTPAddress.  However, I am not confident enough with VBS scripts to create this variable. Also, I did some testing trying to put a variable in the folder path and it just calls the variables name due to the quotation marks.  I tried putting the quotation marks in various different places, but that doesn't appear to work either.
Ex. ("\Public Folders - user@domain.org"\"All Public Folders\Staff Contacts")

Can you share the line you used with the variable?

Sorry for the delay, I have been on vacation.

This is what I have to get the email address, I can get it to echo the users' email address, but I cannot seem to assign this to a variable so that I can call it later in the script.


On Error Resume Next
Dim objSysInfo, objUser, objEmailAddress
Set objSysInfo = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
Set objEmailAddress = objUser.EmailAddress
'the line below is for testing and doesn't display correctly with the above code
'WScript.Echo objEmailAddress

'if I use (below) it echos the user's email address correctly.
On Error Resume Next
Dim objSysInfo, objUser,
Set objSysInfo = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
WScript.Echo objUser.EmailAddress

Thank you so much BlueDevil, I would never have been able to get this accomplished without your help.  I did have to do some additional modifications as I needed it to work for Outlook 2007 and Outlook 2010.  Also, the script throws errors and does not work unless Outlook is open, so I had to create a script that runs at login and watches for Outlook.exe process to spawn and then runs the script to add the folder to public folder favorites.

I have posted my scripts below.
RUN @ LOGIN AND CALLS PUBLICFOLDERS.VBS ON OUTLOOK OPENING
Set objShell = CreateObject("Wscript.Shell")

strComputer = "."

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set colMonitoredProcesses = objWMIService. _        
    ExecNotificationQuery("Select * from __InstanceCreationEvent " _
        & " Within 1 Where TargetInstance ISA 'Win32_Process' AND " & _
            "TargetInstance.Name = 'Outlook.exe'")

Do While True
    Set objProcess = colMonitoredProcesses.NextEvent
    objShell.Run "C:\scripts\PublicFolders.vbs"
Loop
________________________________________________________________________________________
(PublicFolders.vbs) ADDS THE SAME PUBLIC FOLDER TO FAVORITES IN BOTH OUTLOOK 2007/2010
'Define some constants'
Const olMailModule = 158
Const olFavoriteFoldersGroup = 4

'Create some variables'
Dim olkApp, olkSes, olkPane, olkModule, olkGroup, olkFolder

'THIS SECTION IS FOR OUTLOOK 2010'
'Function to get email address"
Function GetAddress()
    On Error Resume Next
    Dim objSysInfo, objUser
    Set objSysInfo = CreateObject("ADSystemInfo")
    Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
    GetAddress = objUser.EmailAddress
End Function

'Connect to Outlook'
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon "Outlook"
 
'Get the Favorites group'
Set olkPane = olkApp.ActiveExplorer.NavigationPane
Set olkModule = olkPane.Modules.GetNavigationModule(olModuleMail)
Set olkGroup = olkModule.NavigationGroups.GetDefaultNavigationGroup(olFavoriteFoldersGroup)
 
'Get the folder(s) to add'
Set olkFolder = OpenOutlookFolder("\Public Folders - " & GetAddress() & "\All Public Folders\FolderName")    '<- change the folder path here'
'If this is a public folder, then add it to public folder favorites'
 On Error Resume Next
If InStr(1, olkFolder.FolderPath, "Public Folders") Then
    olkFolder.AddToPFFavorites
End If
 On Error Resume Next
'Add the folder to favorites'
olkGroup.NavigationFolders.Add olkFolder
 On Error Goto 0

'THIS SECTION IS FOR OUTLOOK 2007"
'Connect to Outlook'
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon "Outlook"
 
'Get the Favorites group'
Set olkPane = olkApp.ActiveExplorer.NavigationPane
Set olkModule = olkPane.Modules.GetNavigationModule(olModuleMail)
Set olkGroup = olkModule.NavigationGroups.GetDefaultNavigationGroup(olFavoriteFoldersGroup)
 
'Get the folder(s) to add'
Set olkFolder = OpenOutlookFolder("\Public Folders\All Public Folders\FolderName")    '<- change the folder path here'
'If this is a public folder, then add it to public folder favorites'
 on Error Resume Next
If InStr(1, olkFolder.FolderPath, "Public Folders") Then
    olkFolder.AddToPFFavorites
End If
 On Error Resume Next
'Add the folder to favorites'
olkGroup.NavigationFolders.Add olkFolder
 On Error Goto 0
'Clean-up'
Set olkPane = Nothing
Set olkModule = Nothing
Set olkGroup = Nothing
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
WScript.Quit
 
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
 
Function OpenOutlookFolder(strFolderPath)
    Dim arrFolders, varFolder, olkMyFolder
    Set OpenOutlookFolder = Nothing
    Set olkMyFolder = Nothing
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkMyFolder) Then
                Set olkMyFolder = olkSes.Folders(varFolder)
            Else
                Set olkMyFolder = olkMyFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkMyFolder
    End If
    On Error Goto 0
End Function