Sharing Multiple Calendars Outlook 2016

[cragos1984]

This will either be a really easy one or totally impossible I think but going to ask it anyway.

 

I have a calendar group within outlook that I want to share with multiple users, I can send an invite to each individual calendar no problem but not the group. Is it possible to do this?

 

I don't really want to spam people with 20 different calendar requests

 

Thanks

Craig

[MatthewL]

You don't need to send an invite, just right click on the calendar and add the distribution group on the permissions and set to reviewer or what ever permissions they need. Then said users can open it on their Outlook in their own time.

[cragos1984]

Yeah I get that. I am trying to make it as easy as possible for staff to do this though which is with an invite and a simple one click for them. The harder we make it the more problems it will cause me down the line

[Steve21]

If it's for desktops Outlook etc you can force add a calendar via script, that's what we do for the school calendar, so no-one needs to manually add it etc

 

Basically as soon as Outlook is open it'll add the calendar for them

 

Steve

[cragos1984]

That's just what im after ideally. Not got a copy of said script handy have you? Not a problem if not

[Steve21]

It's a bit messy as I never bothered cleaning it up as it works fine, but there's basically two parts. (you could merge it into one if you wanted, but just been lazy as it works as mentioned )

 

First script is the one that's set to run at logon, and basically loops around until they open Outlook.

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 "\\myschool.sch.uk\NETLOGON\PublishSchoolCalendarTest.vbs" 
Loop

 

 

Second one adds the calendars (just duplicate the two lines where it says you can add more if you wanted multiple):

'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

wscript.sleep(20000) '20 second

Const olPublicFoldersAllPublicFolders = 18
Const olFavoriteFoldersGroup = 4

On Error Resume Next

Dim olkApp, olkSes, olkFolder
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNameSpace("MAPI")
'Change the profile name on the next line'
olkSes.Logon "Outlook"

  On Error Resume Next
'Change the folder name on the next line.  Repeat the next two lines for each folder you want to add.'

Set olkFolder = OpenOutlookFolder("\Public Folders - " & GetAddress() & "\All Public Folders\School Public Folder\School School Calender")
olkFolder.AddToPFFavorites

'Change the folder name on the next line.  Repeat the next two lines for each folder you want to add.'

Set olkFolder = OpenOutlookFolder("\Public Folders - " & GetAddress() & "\Favorites\School School Calender")
AddFavoriteFolder olkFolder

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

Function OpenOutlookFolder(strFolderPath)
   ' Purpose: Opens an Outlook folder from a folder path.'
   ' Written: 4/24/2009'
   ' Author:  BlueDevilFan'
   ' Outlook: All versions'
   Dim arrFolders, varFolder, bolBeyondRoot
   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
           Select Case bolBeyondRoot
               Case False
                   Set OpenOutlookFolder = olkSes.Folders(varFolder)
                   bolBeyondRoot = True
               Case True
                   Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
           End Select
           If Err.Number <> 0 Then
               Set OpenOutlookFolder = Nothing
               Exit For
           End If
       Next
   End If
   On Error GoTo 0
End Function

 

Steve

[cragos1984]

Thanks very much I will try editing that for what I need. Much appreciated