teratail
回答率
85.48%
質問するログイン新規登録
トップVBAに関する質問エクセルで複数人へのアウトルック予定表反映方法について

編集履歴

質問編集履歴

1

内容修正

2022/04/16 08:59

投稿

gdngnd
gdngnd

スコア0

test CHANGED
File without changes
test CHANGED
@@ -2,8 +2,8 @@
2
2
  その際、自分以外の他人のアウトルック予定表にも同じものを反映させるためにはどのような処理が必要でしょうか。
3
3
 
4
4
 
5
- Sub 複数の他人のOutlook予定表へ予定を登録する()
5
+
6
-
6
+
7
7
  'Outlook用の定義
8
8
  Dim olApp As Outlook.Application
9
9
  Dim olNamespace As Outlook.Namespace
@@ -11,146 +11,94 @@
11
11
  Dim olConItems As Outlook.Items
12
12
  Dim olItem As AppointmentItem
13
13
  Dim checkFlg As Long
14
-
14
+
15
15
  '重複チェックフラグ初期値設定
16
16
  checkFlg = 0
17
-
18
- Dim strAddress As String
17
+
19
-
20
-
18
+
19
+
21
20
  'Excel用の定義
22
21
  Dim wbBook As Workbook
23
22
  Dim wsSheet As Worksheet
24
-
23
+
25
24
  Dim lnContactCount As Long
26
-
25
+
27
26
  'スクリーンの更新は行われません。
28
27
  Application.ScreenUpdating = False
29
-
28
+
30
29
  'Excelのブックとワークシートのオブジェクトを設定します。
31
30
  Set wbBook = ThisWorkbook
32
- Set wsSheet1 = wbBook.Worksheets(1)
31
+ Set wsSheet = wbBook.Worksheets(1)
33
-
34
-
35
- '操作対象の他人のアドレスを指定
32
+
33
+
36
- strAddress = wsSheet1.Cells(2, 11)
34
+ wsSheet.Activate
37
-
38
-
39
-
35
+
40
36
  'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
41
37
  Set olApp = New Outlook.Application
42
38
  Set olNamespace = olApp.GetNamespace("MAPI")
43
- Set recOther = olNamespace.CreateRecipient(strAddress)
44
- Set olFolder = olNamespace.GetSharedDefaultFolder(recOther, olFolderCalendar)
39
+ Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
45
40
  Set olConItems = olFolder.Items
46
-
47
-
41
+
48
42
  '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
49
43
  lnContactCount = 2
50
-
44
+
51
45
  Dim rc As Integer
52
46
  rc = MsgBox("予定表へ登録しますか？", vbYesNo + vbQuestion, "確認")
53
-
47
+
54
48
  If rc = vbYes Then
55
-
49
+
56
50
  '予定表一覧の件数分繰り返す。
57
51
  For i = lnContactCount To Cells(1, 1).End(xlDown).Row
58
- Set olItem = olConItems.Add()
52
+ Set olItem = olApp.CreateItem(olAppointmentItem)
59
-
60
- 'もし違うアドレスだったら再セットする。
53
+
61
- If strAddress <> wsSheet1.Cells(i, 11) Then
62
- '操作対象の他人のアドレスを再指定
54
+ With olItem
63
- strAddress = wsSheet1.Cells(i, 11)
55
+ .RequiredAttendees = Cells(i, 1)
64
- Set recOther = olNamespace.CreateRecipient(strAddress)
65
- Set olFolder = olNamespace.GetSharedDefaultFolder(recOther, olFolderCalendar)
66
- Set olConItems = olFolder.Items
56
+ .OptionalAttendees = Cells(i, 2)
57
+ .Subject = Cells(i, 3)
67
- End If
58
+ .Body = Cells(i, 4)
68
-
59
+ .Start = Cells(i, 5)
60
+ .End = Format(Cells(i, 6), "yyyy/mm/dd hh:mm:ss")
61
+ .Body = Format(Cells(i, 7), "yyyy/mm/dd hh:mm:ss")
62
+ .Body = Cells(i, 8)
63
+
64
+
69
- '更新処理
65
+ '重複チェック
70
66
  For Each olItemBefor In olConItems
71
67
  If TypeName(olItemBefor) = "AppointmentItem" Then
72
-
73
- 'ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新
74
- If olItemBefor.EntryID = wsSheet1.Cells(i, 9) Then
75
-
76
- '比較用に一時的に作成
77
- With olItem
78
- .Subject = wsSheet1.Cells(i, 1)
79
- .Start = Format(wsSheet1.Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
80
- .End = Format(wsSheet1.Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
81
- End With
82
-
83
-
84
- '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
68
+ '登録されている予定表の件名と開始日時が一致していたらフラグを1にする
85
- '※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
86
- If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
69
+ If olItemBefor.Subject = .Subject And olItemBefor.Start = .Start Then
87
-
88
-
89
- Else
90
- '定期的な予定である場合は除外
91
- If wsSheet1.Cells(i, 10) <> "True" Then
92
- With olItemBefor
93
- .RequiredAttendees = wsSheet1.Cells(i, 1)
94
- .OptionalAttendees = wsSheet1.Cells(i, 2)
95
- .Subject = wsSheet1.Cells(i, 3)
96
- .Body = wsSheet1.Cells(i, 4)
97
- .Start = wsSheet1.Cells(i, 5)
98
- .End = Format(wsSheet1.Cells(i, 6), "yyyy/mm/dd hh:mm:ss")
99
- .End = Format(wsSheet1.Cells(i, 7), "yyyy/mm/dd hh:mm:ss")
100
- .Body = wsSheet1.Cells(i, 8)
101
- .Save
102
- End With
103
- End If
104
- End If
105
-
106
- 'Null out the variables.
107
- Set olItem = Nothing
70
+ checkFlg = 1
108
-
109
71
  End If
110
-
111
-
112
72
  End If
113
-
73
+
114
74
  Next
115
-
75
+
116
- If wsSheet1.Cells(i, 9) = "" Then
76
+ If checkFlg <> 1 Then
117
- 'ExcelI列のEntryIDが登録されていなかったら新規登録
118
- With olItem
77
+ 'ここで保存
119
-
120
- .Subject = wsSheet1.Cells(i, 1)
121
- .Location = wsSheet1.Cells(i, 2)
122
- .Start = Format(wsSheet1.Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
123
- .End = Format(wsSheet1.Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
124
- .Body = wsSheet1.Cells(i, 5)
125
- .RequiredAttendees = wsSheet1.Cells(i, 6)
126
- .OptionalAttendees = wsSheet1.Cells(i, 7)
127
- .Save
78
+ olItem.Save
128
- End With
79
+
129
-
130
- 'ExcelI列へ発行されたEntryIDを書き込み
131
- wsSheet1.Cells(i, 9) = olItem.EntryID
132
-
133
80
  End If
134
81
 
82
+ End With
83
+
84
+ '重複フラグリセット
85
+ checkFlg = 0
86
+
135
87
  Next
136
-
88
+
137
89
  Else
138
90
  MsgBox "処理を中断します"
139
91
  End If
140
-
92
+
141
93
  'Null out the variables.
142
94
  Set olItem = Nothing
143
95
  Set olApp = Nothing
144
- Set olConItems = Nothing
96
+
145
- Set olFolder = Nothing
97
+
146
- Set olNamespace = Nothing
147
- Set wbBook = Nothing
148
- Set wsSheet1 = Nothing
149
-
150
98
  'Turn screen updating back on.
151
99
  Application.ScreenUpdating = True
152
-
100
+
153
101
  MsgBox "Outlook予定表の登録が完了しました！", vbInformation
154
-
102
+
155
103
  End Sub
156
104
 
VBAOutlookExcel