部署のメンバーの予定表を追加する方法


コメントにて以下のご要望をいただきました。


いつも参考にさせて頂いております。
ありがとうございます。

この度、私(エクセルVBAであれば一通りできるレベル)が所属している会社(Win10 64bit outlook2013 exchange 環境)の部の上司より言われ、今後は各社員の外出先や戻る時間を記載するためのホワイトボードをやめ、各社員の行動はoutlookの共有予定表で把握したいということになりました。

予定表の共有(名前の横のチェックボックスにチェックを入れればその人の予定が表示される状態)のやり方は分かるのですが、なにぶん人数が多い部署のため、outlookのセットアップをエクセルのVBA(各位にエクセルファイルを配布してそのファイル上に用意されたボタンを押すとoutlookのセットアップを自動でやってくれるイメージ)でやりたいと考えております。

私が所属している部は1課と2課に分かれているのでその2つのグループに分け、各50人くらいずつの登録をVBAで行いたいです。

何卒知恵を頂きたくお願い申し上げます。


VBA で登録したいとのことですが、アクセス権限によっては VBA では実現できない可能性があります。
部署の全員の予定表を一括で登録する方法はいくつかあり、それぞれメリット、デメリットがありますので、どれが良いかご検討ください。

1. 階層型アドレス帳を構成し、[部署の予定表を表示] をオンにする

Exchange 環境では階層型アドレス帳という、部署をツリー形式で表示するアドレス帳が使用できます。
このアドレス帳が構成されている環境では、予定表のリボンの [予定表グループ]-[部署の予定表を表示] が既定でオンになり、階層型アドレス帳で自分自身が所属しているグループに含まれるメンバーの予定表が自動的にナビゲーション ウィンドウに表示される動作となります。

メリット:
階層型アドレス帳を構成するだけで自動的に追加される。

デメリット:
Exchange サーバーの管理者が階層型アドレス帳を構成し、適切にグループを作成する必要がある。

2. ユーザーに上司を設定し、[上司のチームの予定表を表示] をオンにする

Active Directory のユーザーの属性に [上司] というものがあり、ここに上司となるユーザーが登録されている場合、予定表のリボンの [予定表グループ]-[上司のチームの予定表を表示] が既定でオンになり、同じ上司であるユーザーの予定表が自動的にナビゲーション ウィンドウに表示される動作となります。

メリット:
Active Directory で上司を追加するだけで自動的に追加される。

デメリット:
Active Directory のユーザーの属性を変更する必要がある。
一人の上司が複数の部署の上司を兼任している場合、別の部署のメンバーも追加される。

3. 部署のメンバーで構成される配布グループを作成し、[予定表を開く]-[アドレス帳から] で配布グループを追加する

[予定表を開く]-[アドレス帳から] により、アドレス帳から配布グループを追加すると、そのグループの名前の予定表グループが生成され、その下に配布グループのメンバーの予定表が追加されます。

メリット:
組織によってはグループの生成がある程度自由なため、敷居が低い。

デメリット:
グループを作成する必要がある。
ユーザーが手動で配布グループを追加する必要がある。

4. VBA マクロで追加する

メンバーの予定表に参照権限以上がある場合は、マクロで追加することが可能です。
ただし、上記の 3 つにはない制限があります。

メリット:
Active Directory の設定変更の必要がない。

デメリット:
予定表に参照権限を与える必要がある (上記 1-3 は空き時間情報のみで追加可能)。
部署のメンバーの追加・削除があった場合は、改めてクライアントごとにマクロの実行が必要 (上記 1-3 は Active Directory 上のメンバーや上司の変更がクライアントに自動的に反映される)。
追加された予定表の名前がユーザー名だけでなく、「予定表 – ユーザー名」となる。(変更は不可能)

マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub AddMemberCalendars()
     On Error Resume Next
     Const GROUP_NAME = "group"
     Const olFolderCalendar = 9
     Const olModuleCalendar = 1
     Dim olkApp 'As Outlook.Application
     Dim nsSession 'As Namespace
     Dim actExp 'As Explorer
     Dim navModule 'As CalendarModule
     Dim navGroups 'As NavigationGroups
     Dim navGroupT 'As NavigationGroup
     Dim navGroup 'As NavigationGroup
     Dim i As Integer
     Dim j As Integer
     Dim r As Integer
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     '
     Set olkApp = CreateObject("Outlook.Application")
     Set nsSession = olkApp.Session
     '---- 予定表グループの作成
     ' 予定表グループを追加するための Explorer オブジェクトを取得
     If olkApp.ActiveExplorer Is Nothing Then
         Set fldCalendar = nsSession.GetDefaultFolder(olFolderCalendar)
         Set actExp = fldCalendar.GetExplorer()
     Else
         Set actExp = olkApp.ActiveExplorer
     End If
     ' 予定表モジュールを取得
     Set navModule = actExp.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
     ' 予定表グループのリストを取得
     Set navGroups = navModule.NavigationGroups
     Set navGroup = Nothing
     For i = 1 To navGroups.Count
         Set navGroupT = navGroups.Item(i)
         ' 追加しようとしているグループが既に存在していた場合
         If navGroupT.Name = GROUP_NAME Then
             ' 既存の予定表はすべて削除
             With navGroupT.NavigationFolders
                 For j = .Count To 1 Step -1
                     Dim navFolder 'As NavigationFolder
                     Set navFolder = .Item(j)
                     .Remove navFolder
                 Next
             End With
             ' 既存の予定表グループを設定
             Set navGroup = navGroupT
             Exit For
         End If
     Next
     '
     If navGroup Is Nothing Then
         ' 新規に予定表グループを作成
         Set navGroup = navGroups.Create(GROUP_NAME)
     End If
     '---- 予定表グループにメンバーの予定表を追加
     ' 1 行目から開始
     r = 1
     ' 1 列目にデータがある限り繰り返す
     While ThisWorkbook.Sheets(1).Cells(r, 1) <> ""
         ' 1 列目をメールアドレスとして取得
         strAddress = ThisWorkbook.Sheets(1).Cells(r, 1)
         ' メールアドレスから受信者オブジェクトを生成
         Set recOther = nsSession.CreateRecipient(strAddress)
         ' 名前解決を実行
         recOther.Resolve
         If recOther.Resolved Then
             ' 自分自身は予定表グループに追加しない
             ' Exchange 組織外のアドレスも追加しない
             If recOther.Address = nsSession.CurrentUser.Address _
                 Or recOther.AddressEntry.Type <> "EX" Then
                 Exit Sub
             End If
             ' 他のユーザーの予定表を取得
             Set fldCalendar = nsSession.GetSharedDefaultFolder(recOther, olFolderCalendar)
             If Not fldCalendar Is Nothing Then
                 ' 予定表が取得できたら予定表グループに追加
                 navGroup.NavigationFolders.Add fldCalendar
             End If
         End If
         r = r + 1
     Wend
End Sub

マクロの登録方法やメニューへの追加について

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中