サブの予定表やら共有の予定表やらから予定や会議開催通知を作る

現状のイメージ

月末のお仕事で社内共有の予定表に仮でスケジュールを入れて、中ボスに確認してもらう。リスケしたりなんだりして決定したら、それを自分の「メール用」って予定表にコピーして、参加者に会議開催通知を送っているのだ。だ。
f:id:elve:20190304192258p:plain
１，３，４あたりが楽になる・・・はず。

マクロ準備

環境：Windows10＋Office2010
まずエクセルでこんな感じの表を作るです。A1から詰めて書くのです。
f:id:elve:20190304192552p:plain
アウトルックの予定表に「メール用」を足しておきましょう。
f:id:elve:20190304192721p:plain

イベント追加のほうは共有の予定表がないので動作確認してません（＞＜）

マクロ

VBAの画面で「ツール」→「参照設定」でOutlookのobject library にチェック入れて。
selectしない処理にしたほうが早いんだけどねー

'#
'#
'#
Sub イベント追加()
Dim olkApp As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim r As Integer, i As Integer
'Outlook起動（といいつつあらかじめ起動しておかないと動かない）
Set olkApp = CreateObject("Outlook.Application")
'ネームスペース取得
Set myNamespace = olkApp.GetNamespace("MAPI")
'公開予定表を表示
Set olkApp.ActiveExplorer.CurrentFolder = _
    myNamespace.GetSharedDefaultFolder( _
    olkApp.Session.CreateRecipient("公開予定表"), olFolderCalendar)
'公開予定表取得
Set my_sub = olkApp.ActiveExplorer.CurrentFolder
'1行目から処理
Range("A1").Select
'A列が空の行までループ
Do
    r = ActiveCell.Row
    If r <> 1 Then
        '予定表にアイテム追加
        Set objAppt = my_sub.Items.Add
        '件名
        objAppt.Subject = Cells(r, 1)
        '開始時間
        objAppt.Start = CDate(Cells(r, 3) & " " & Format(Cells(r, 4), "h:mm"))
        '終了時間
        objAppt.End = CDate(Cells(r, 3) & " " & Format(Cells(r, 5), "h:mm"))
        '分類
        objAppt.Categories = Cells(r, 7)
        '保存
        objAppt.Save
    End If
    '次の行を選択
    ActiveCell.Offset(1, 0).Select
'空？
Loop Until ActiveCell = ""
'アプリ閉じないで解放
Set olkApp = Nothing
Range("A1").Select
MsgBox ("おわり")
End Sub

'#
'#
'#
Sub 開催通知作成()
Dim olkApp As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim r As Integer, i As Integer
'Outlook起動（といいつつあらかじめ起動しておかないと動かない）
Set olkApp = CreateObject("Outlook.Application")
'ネームスペース取得
Set myNamespace = olkApp.GetNamespace("MAPI")
'予定表を表示
Set olkApp.ActiveExplorer.CurrentFolder = _
    myNamespace.GetDefaultFolder(olFolderCalendar)
'「メール用」予定表取得
Set my_sub = olkApp.ActiveExplorer.CurrentFolder.Folders("メール用")
'1行目から処理
Range("A1").Select
'A列が空の行までループ
Do
    r = ActiveCell.Row
    If r <> 1 Then
        '予定表にアイテム追加
        Set objAppt = my_sub.Items.Add
        '会議開催通知
        objAppt.MeetingStatus = olMeeting
        
        
        '件名
        objAppt.Subject = Cells(r, 1)
        '開始時間
        objAppt.Start = CDate(Cells(r, 3) & " " & Format(Cells(r, 4), "h:mm"))
        '終了時間
        objAppt.End = CDate(Cells(r, 3) & " " & Format(Cells(r, 5), "h:mm"))
        '参加者
        objAppt.Recipients.Add Cells(r, 6)
        '分類
        objAppt.Categories = Cells(r, 7)
        '受信者の確認
        objAppt.Recipients.ResolveAll
        '表示
        objAppt.Display

    End If
    '次の行を選択
    ActiveCell.Offset(1, 0).Select
'空？
Loop Until ActiveCell = ""
'アプリ閉じないで解放
Set olkApp = Nothing
Range("A1").Select
MsgBox ("おわり")
End Sub