インターネット予定表の予定を既定の予定表にコピーするスクリプト


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


はじめまして。Outlookの予定表に関して質問させていただきます。
インターネット予定表にて外部スケジュールソフトと連携しているのですが、
連携した予定がTo Do バーのスケジュール表示箇所に表示されません。
どうやら、To Do バーのスケジュール表示はOutlookデフォルトの予定表
に登録されたものしか連携できないようです。

可能であれば、インターネット予定表のスケジュールをデフォルトの予定表に定期的にコピーするマクロを教えていただけないでしょうか?

お手数おかけしますが、よろしくお願い致します。



インターネット予定表の予定をコピーするマクロを作ることは可能です。
しかし、ただ単にコピーするだけでは、実行するたびに予定が重複してしまうので、最初に以前コピーしたものを削除する必要があります。
この時、既定の予定表に書き込んだ予定を削除しないようにするため、あらかじめインターネット予定表からの予定のコピーの際に「インターネット予定表」のような分類項目を予定に設定し、削除する際には「インターネット予定表」という分類項目の予定だけを削除するというようなロジックにします。

また、このような処理を定期的に実行するという場合、マクロでの実行はお勧めできません。
というのも、マクロで処理を実行する場合、そのマクロの処理が終わるまで Outlook が一時的に使用できなくなってしまうためです。
予定表のコピーというような比較的時間がかかる処理を定期的に実行するのであれば、マクロではなくスクリプトとして実装し、それを Windows のタスク スケジューラーで実行したほうが良いでしょう。

スクリプトは以下のようなものになります。

' ここをトリプルクリックでスクリプト全体を選択できます。
Option Explicit
Const CALENDAR_NAME = "Calendar" ' インターネット予定表のフォルダー名を指定
Const olFolderCalendar = 9
Const olFolderDeletedItems = 3
Const olCreateAppointment = 1
Const ICAL_CATEGORY = "インターネット予定表"
Dim objWMIService
Dim colProcesses
' Outlook が起動しているかどうかの確認 
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcesses = objWMIService.ExecQuery( "Select * from Win32_Process Where Name = 'outlook.exe'")
' Outlook が起動していなければ、コピーは実行しない
If colProcesses.Count > 0 Then
    CopyInternetCalendar
End If
'
Sub CopyInternetCalendar()
    On Error Resume Next
    Dim olkApp
    Dim objSession
    Dim fldICalRoot
    Dim fldICal
    Dim fldCalendar
    Dim colICalItems
    Dim i
    Dim apptItem
    Dim copyItem
    Dim fldDeleted
    '
    Set olkApp = CreateObject("Outlook.Application")
    Set objSession = olkApp.Session
    Set fldICalRoot = objSession.Folders("インターネット予定表")
    If fldICalRoot Is Nothing Then Exit Sub
    ' インターネット予定表の取得
    Set fldICal = fldICalRoot.Folders(CALENDAR_NAME)
    If fldICal Is Nothing Then Exit Sub
    ' コピー前に以前インターネット予定表からコピーしたアイテムを削除
    Set fldCalendar = objSession.GetDefaultFolder(olFolderCalendar)
    Set colICalItems = fldCalendar.Items.Restrict("[分類項目] = '" & ICAL_CATEGORY & "'")
    For i = colICalItems.Count To 1 Step -1
        colICalItems.Remove i
    Next
    ' インターネット予定表のアイテムをコピー
    For Each apptItem In fldICal.Items
        Set copyItem = apptItem.CopyTo(fldCalendar, olCreateAppointment)
        copyItem.Categories = ICAL_CATEGORY
        copyItem.Save
    Next
    ' 削除済みアイテムフォルダーからも削除
    Set fldDeleted = objSession.GetDefaultFolder(olFolderDeletedItems)
    Set colICalItems = fldDeleted.Items.Restrict("[分類項目] = '" & ICAL_CATEGORY & "'")
    For i = colICalItems.Count To 1 Step -1
        colICalItems.Remove i
    Next
End Sub

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中