Sub Outlookの追加した予定表へ予定を登録する()
'Outlook用の定義
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Folder
Dim olConItems As Outlook.Items
Dim olItem As AppointmentItem
Dim checkFlg As Long
'追加した予定表の異動時に使用するオブジェクト
Dim olItemMove As Object
'重複チェックフラグ初期値設定
checkFlg = 0
'Excel用の定義
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnContactCount As Long
'抽出期間の定義
Dim strStart As String
Dim strEnd As String
Dim intKikan As Integer
'対象予定表の抽出期間を月単位で指定します。
'※抽出期間が短いと予定アイテムのチェックができず登録できない場合がありますので注意してください｡
intKikan = 12 '抽出期間を12か月にしています。
strStart = Format(DateAdd("m", -intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
strEnd = Format(DateAdd("m", intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの終了日を指定
'スクリーンの更新は行われません。
Application.ScreenUpdating = False
'Excelのブックとワークシートのオブジェクトを設定します。
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
wsSheet.Activate
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders("追加予定表1")
Set olConItems = olFolder.Items
'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込む
Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")
'取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
lnContactCount = 2
Dim rc As Integer
rc = MsgBox("予定表へ登録しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbYes Then
'予定表一覧の件数分繰り返す。
For i = lnContactCount To Cells(1, 1).End(xlDown).Row
Set olItem = olApp.CreateItem(olAppointmentItem)
'重複チェック＆更新処理
For Each olItemBefor In olConItems
If TypeName(olItemBefor) = "AppointmentItem" Then
'ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新
If olItemBefor.EntryID = Cells(i, 9) Then
'比較用に一時的に作成
With olItem
.Subject = Cells(i, 1)
.Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
.End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
End With
'重複フラグ1をセット
checkFlg = 1
'登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
'※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
Else
'定期アイテムは除外します。
If Cells(i, 10) <> "True" Then
With olItemBefor
.Subject = Cells(i, 1)
.Location = Cells(i, 2)
.Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
.End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
.Body = Cells(i, 5)
.RequiredAttendees = Cells(i, 7)
.OptionalAttendees = Cells(i, 8)
.Save
End With
End If
End If
'Null out the variables.
Set olItem = Nothing
End If
End If
Next
'EntryIDが空である場合のみ新規登録をすることにしました。
If checkFlg <> 1 And Cells(i, 9) = "" Then
With olItem
.Subject = Cells(i, 1)
.Location = Cells(i, 2)
.Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
.End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
.Body = Cells(i, 5)
.RequiredAttendees = Cells(i, 7)
.OptionalAttendees = Cells(i, 8)
End With
'追加した予定表へアイテムを移動します。
Set olItemMove = olItem.Move(olFolder)
'ExcelI列へ発行されたEntryIDを書き込み
Cells(i, 9) = olItemMove.EntryID
End If
'重複フラグリセット
checkFlg = 0
Next
Else
MsgBox "処理を中断します"
End If
'Null out the variables.
Set olItem = Nothing
Set olApp = Nothing
Set wbBook = Nothing
Set wsSheet = Nothing
Set olNamespace = Nothing
Set olFolder = Nothing
Set olConItems = Nothing
'Turn screen updating back on.
Application.ScreenUpdating = True
MsgBox "Outlook予定表の登録が完了しました！", vbInformation
End Sub
設定してもらいたい箇所は以下の＜追加予定表を指定＞の箇所です。
追加予定表の表示名を入れるようにしてください。
Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders(“＜追加予定表を指定＞“)
取得したOutlookオブジェクトを取得します。
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace(“MAPI”)
予定表のリストはolFolderCalendarというメンバーに格納されていますのでそれを指定しています。
追加した予定表はそのフォルダごとに分かれて格納されていますので、
追加した予定表の表示名をFoldersオブジェクトの引数に渡すことにより
追加した予定表のオブジェクトを取得することができます。
Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders(“追加予定表2”)
ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新します。
If olItemBefor.EntryID = Cells(i, 9) Then
登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新します。
※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
ご説明ありがとうございます。
説明の通り、規定の予定表の下に作成した予定表に入れようとしましたが、やはり規定の予定表に予定が入ってしまいます。何か考えられる原因はあるでしょうか。
また別ですが、規定の予定表の下ではないところにある予定表に予定を入れるのは難しいでしょうか。
ご連絡ありがとうございます。
追加した予定表を指定したものの、規定の予定表にはいってしまう事象につきまして、
エラー無くアイテム登録はできていますので、設定面では問題ないかと思われます。
ただ、指定フォルダにアイテムが登録されていないということで、
Foldersオブジェクトの指定がされていないか、フォルダへの振り分けがうまく機能していないことが要因として考えられます。
お手数ですが、実装しているコードをご教示いただけますでしょうか。
日頃お世話になっております。
追加予定表への予定登録をVBAで自動化したく、探していたところ、こちらのぺージを見つけました。
やりたいことがそのままだったので、まずはコピペして利用しようとしたのですが、
Set olConItems = olFolder.Items
の部分にエラーが出てしまいます。
内容は『メソッドまたはデータメンバーがみつかりません』との事です。設定の確認などもしたのですが、見当たらず。F1から開けるヘルプを見ても、分からない状態です。
原因と、解決策が有れば、ご教授いただければ幸いです。
よろしくお願いいたします。
いつもご利用ありがとうございます。
エラー内容から参照設定、追加予定表の設定は問題ないようですが、
olFolder.Itemsがうまく機能していないようです。
考えられる要因としましては、
①既定のアカウントの追加予定表を指定していない（共有の予定を指定している）
②スクリプトによる予定表へのアクセスが禁止されている
でしょうか。
まずは①あたりをご確認頂きたくお願いいたします。
よろしくお願いいたします。