予定表を定期的に ics ファイルに保存し、自動で特定のアドレスに送信するマクロ


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


ご質問】予定表を定期的にicsファイルに落とし、自動で特定のアドレスに送信する

いつも参考にさせていただいております。
当方、マクロは全くの素人のため、当サイトのマクロ
をそっくり使わせていただいており、非常に助かっております。

今回、どうしても欲しいマクロで、どこのサイトを探しても
それらしい物が無かったため、要望させていただきます。

outlook2007使用

・他の人と共有している予定表を、icsファイルに変換し、それを特定のアドレスに
送信する

・上記メールを決まった時間 or outlook起動時など定期的に自動で送信する

そんな都合の良いマクロは作成可能でしょうか?

素人の為どの位ムチャな要望なのかも分かっておりません。

大変申し訳ありません、何卒ご教示ねがいます。


Outlook のオブジェクト モデルには、予定アイテム単体を iCal ファイルに保存するメソッドは用意されていますが、予定表全体を保存するメソッドはありません。
そのため、一つ一つのアイテムを iCal で保存し、それをまとめた iCal ファイルを作成するというような処理が必要となります。
また、定期的にマクロを実行する方法としては、マクロ実行用の仕事アイテムを用意し、そのアイテムのアラームが表示されるタイミングで処理を実行する、というようなものがあります。

以下のマクロは、起動時に iCal ファイルを送信し、さらに仕事アイテムを使って 1 日おきに iCal ファイルを送信するマクロです。
件名や宛先などを適宜変更して使用してください。
なお、予定表に大量のアイテムがある場合にはマクロの実行に時間がかかったり、iCal ファイルのサイズが非常に大きくなったりする可能性があるのでご注意ください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 定期実行のためのタスクの件名
Const CALSEND_ITEM = "予定表自動送信タスク"
' iCal を送信するメールの件名
Const MSG_SUBJECT = "予定表送信"
' iCal を送信するメールの本文
Const MSG_BODY = "予定表を送信します"
' iCal を送信するメールの宛先
Const MSG_TO = "user1@example.com"
' iCal のローカル保存用ファイル名
Const ATT_FILE = "c:\temp\予定表.ics"
' iCal 作成の作業ファイル名
Const TEMP_FILE = "c:\temp\~temp~.ics"
'
' 起動時に自動実行されるルーチン
Private Sub Application_Startup()
    Dim fldTask As Folder
    Dim objTask As TaskItem
    Set fldTask = Session.GetDefaultFolder(olFolderTasks)
    ' 自動送信タスクの検索
    Set objTask = fldTask.Items.Find("[件名]='" & CALSEND_ITEM & "'")
    If objTask Is Nothing Then
        ' 自動送信タスクが存在しなければ作成
        Set objTask = fldTask.Items.Add
        objTask.Subject = CALSEND_ITEM
    End If
    ' 自動送信タスクのアラームを 1 日後に設定
    objTask.ReminderTime = DateAdd("d", 1, Now)
    objTask.ReminderSet = True
    objTask.Save
    ' iCal 送信
    SendMyCalendar
End Sub
'
' アラーム表示で実行されるルーチン
Private Sub Application_Reminder(ByVal Item As Object)
    ' 自動送信タスクだったら
    If Item.Subject = CALSEND_ITEM Then
        ' 一時的にアラームをオフ
        Item.ReminderSet = False
        Item.Save
        ' 自動送信タスクのアラームを 1 日後に設定
        Item.ReminderTime = DateAdd("d", 1, Now)
        Item.ReminderSet = True
        Item.Save
        ' iCal 送信
        SendMyCalendar
    End If
End Sub
'
' 予定表を iCal で送信するルーチン
Public Sub SendMyCalendar()
    On Error Resume Next
    ' ADO の定数設定
    Const adTypeText = 2
    Const adTypeBinary = 1
    Const adSaveCreateOverWrite = 2
    '
    Dim fldCalendar As Folder
    Dim oneAppt As AppointmentItem
    Dim stmWrite 'As ADODB.Stream
    Dim stmRead 'As ADODB.Stream
    Dim strText As String
    Dim binIcs As Variant
    Dim msgSend As MailItem
    ' UTF-8 で iCal ファイルを作成するためのストリーム作成
    Set stmWrite = CreateObject("ADODB.Stream")
    With stmWrite
        .Type = adTypeText
        .Charset = "UTF-8"
        .Open
        ' iCal のヘッダーを書き込み
        .WriteText "BEGIN:VCALENDAR" & vbCrLf
        .WriteText "PRODID:-//Microsoft Corporation//Outlook 12.0 MIMEDIR//EN" & vbCrLf
        .WriteText "VERSION:2.0" & vbCrLf
        .WriteText "METHOD:PUBLISH" & vbCrLf
        .WriteText "X-WR-CALNAME:" & Session.CurrentUser & vbCrLf
    End With
    ' 既定の予定表を取得
    Set fldCalendar = Session.GetDefaultFolder(olFolderCalendar)
    ' すべての予定アイテムを処理
    For Each oneAppt In fldCalendar.Items
        Err.Clear
        ' 単一のアイテムを iCal として保存
        oneAppt.SaveAs TEMP_FILE, olICal
        If Err.Number = 0 Then
            ' iCal ファイルを UTF-8 として読み込む
            Set stmRead = CreateObject("ADODB.Stream")
            With stmRead
                .Type = adTypeText
                .Charset = "UTF-8"
                .Open
                .LoadFromFile TEMP_FILE
                strText = .ReadText
                .Close
            End With
            ' iCal データのうち VEVENT の部分だけ抜きとり
            strText = Mid(strText, InStr(strText, "BEGIN:VEVENT"))
            strText = Left(strText, InStr(strText, "END:VCALENDAR") - 1)
            ' 送信用 iCal ファイルへ書き込み
            stmWrite.WriteText strText ' adWriteChar
        End If
        DoEvents
    Next
    '
    With stmWrite
        ' iCal ファイルの終わりを書き込み
        .WriteText "END:VCALENDAR" & vbCrLf
        ' iCal ファイルの保存
        .SaveToFile ATT_FILE, adSaveCreateOverWrite
        .Close
    End With
    ' iCal ファイルを添付してメールを送信
    Set msgSend = CreateItem(olMailItem)
    msgSend.Subject = MSG_SUBJECT
    msgSend.Body = MSG_BODY
    msgSend.To = MSG_TO
    msgSend.Attachments.Add ATT_FILE
    msgSend.Send
End Sub

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中