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


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

宛先により差し込む署名を変えるとなると、宛先と署名を紐づけるものが必要となります。
今回のマクロでは、宛先のアドレスに該当する連絡先を検索し、見つかった連絡先の分類項目の文字列を名前とするクイックパーツで署名を置き換えるというものにしてみました。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ChangeSignatureByRecipients()
    Dim objRecip As Recipient
    Dim objContact As ContactItem
    '
    For Each objRecip In ActiveInspector.CurrentItem.Recipients
        ' 受信者のアドレスに該当する連絡先を検索
        Set objContact = FindContactByAddress(objRecip.Address)
        If Not objContact Is Nothing Then
            ' 連絡先の分類項目が設定されているか確認
            If objContact.Categories <> "" Then
                ' 分類項目の文字列を名前とするクイックパーツの埋め込み
                If ReplaceSignatureByQuickParts(objContact.Categories) Then
                    Exit For
                End If
            End If
        End If
    Next
End Sub
'   アドレスから連絡先を検索する関数
Private Function FindContactByAddress(strAddress As String)
     Dim objContacts 'As Folder
     Dim objContact As ContactItem
     '
     Set objContacts = Session.GetDefaultFolder(olFolderContacts)
     Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
         & "' or [Email2Address] = '" & strAddress _
         & "' or [Email3Address] = '" & strAddress & "'")
     Set FindContactByAddress = objContact
End Function
'   指定した名前のクイックパーツで署名を置き換える関数
Private Function ReplaceSignatureByQuickParts(strName As String)
    On Error Resume Next
    Dim oDoc As Object
    Dim oWord As Object
    Dim strTemp As String
    Dim oParts As Object
    Dim oSignature As Object
    ReplaceSignatureByQuickParts = False
    ' 現在表示しているメールの Word コンポーネントを取得
    Set oDoc = ActiveInspector.WordEditor
    Set oWord = oDoc.Parent
    ' メールの標準テンプレートからクイックパーツを取得
    strTemp = oWord.Options.DefaultFilePath(2) & "\NormalEmail.dotm"
    Set oParts = oWord.templates(strTemp).BuildingBlockEntries(strName)
    ' クイックパーツが見つからなければ中断
    If oParts Is Nothing Then Exit Function
    ' メールの署名をクイックパーツで置き換え
    Set oSignature = oDoc.Bookmarks("_MailAutoSig")
    oParts.Insert Where:=oSignature.Range, RichText:=True
    ReplaceSignatureByQuickParts = True
End Function


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

Outlook では Explorer で次のメールを選択するという方法が用意されていないため完全に自動化はできなかったのですが、マクロを使用して以下のような手順にはできます。

1. SearchStart マクロを実行し、検索文字列を入力すると Outlook で検索が行われる
2. 検索結果のメールのうち一つを選択すると、そのメールに含まれる文字列を自動的に検索する
3. SearchNext マクロを実行すると、同じメール本文の中をさらに検索する
4. メールの最後まで検索したら、手動で別のメールを選択すると 2. の状態になる
5. 検索を終了するときには SearchStop マクロを実行する

上記を実現するマクロは以下のようになります。 SearchStart、SearchNext、SearchStop をクイック アクセス ツールバーに登録しておけばより便利になると思います。

' ここをトリプルクリックでマクロ全体を選択できます。
Dim WithEvents myExplorer As Explorer
Dim mySearchWord As String
Dim myFind As Object
'
' 検索を開始するマクロ
Public Sub StartSearch()
    mySearchWord = InputBox("検索文字列:")
    Set myExplorer = ActiveExplorer
    myExplorer.Search mySearchWord, olSearchScopeCurrentFolder
End Sub
'
' 次の文字列を検索するマクロ
Public Sub NextSearch()
    If Not myFind Is Nothing Then
        myFind.Execute
    End If
End Sub
'
' 検索を終了するマクロ
Public Sub StopSearch()
    myExplorer.ClearSearch
    Set myExplorer = Nothing
    Set myFind = Nothing
End Sub
'
' 検索結果のアイテムをクリックした際に発生するイベントで本文検索開始
Private Sub myExplorer_SelectionChange()
    On Error Resume Next
    Dim objWord As Object
    If myExplorer.Selection.Count = 0 Then
        Exit Sub
    End If
    Set objWord = myExplorer.Selection(1).GetInspector().WordEditor
    DoEvents
    Set myFind = objWord.Parent.Selection.Find
    With myFind
        .ClearFormatting
        .Text = mySearchWord
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = True
        .Execute
    End With
End Sub
'
' フォルダーが切り替わったら検索を終了させるための記述
Private Sub myExplorer_FolderSwitch()
    StopSearch
End Sub


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

Outlook のオブジェクト モデルには Conversation というオブジェクトがあり、スレッドに含まれるアイテムを取得することが可能です。
これを利用すると、特定のスレッドのメールだけ 1 行に出力できます。
なお、Conversation が使えない状況も考えられるため、その場合はメッセージ ヘッダーに含まれる Message-ID と In-Reply-To を使用してスレッドを認識するようにしてみました。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportToExcelWithThread()
    Dim appExcel 'As Excel.Application
    Dim objBook 'As Excel.Workbook
    Dim objSheet 'As Excel.Worksheet
    Dim bConvOK As Boolean
    Dim colItems As Items
    Dim objItem 'As MailItem
    Dim c As Integer
    '
    Set appExcel = CreateObject("Excel.Application")
    Set objBook = appExcel.Workbooks.Add()
    Set objSheet = objBook.Sheets(1)
    With objSheet
        .Cells(1, 1) = "スレッド情報"
        .Cells(1, 2) = "日付"
        .Cells(1, 3) = "宛先"
        .Cells(1, 4) = "Cc"
        .Cells(1, 5) = "差出人"
        .Cells(1, 6) = "件名"
        .Cells(1, 7) = "本文"
    '
        Set colItems = ActiveExplorer.CurrentFolder.Items
        colItems.Sort "送信日時"
        bConvOK = ActiveExplorer.CurrentFolder.Store.IsConversationEnabled
        For Each objItem In colItems
            If bConvOK Then
                ExportThreadByConversation objItem, objSheet
            Else
                ExportThreadByMessageId objItem, objSheet
            End If
        Next
        For c = 2 To .UsedRange.Columns.Count Step 6
            .Cells(1, c) = "日付"
            .Cells(1, c + 1) = "宛先"
            .Cells(1, c + 2) = "Cc"
            .Cells(1, c + 3) = "差出人"
            .Cells(1, c + 4) = "件名"
            .Cells(1, c + 5) = "本文"
        Next
    End With
    '
    appExcel.Visible = True
    objBook.Windows(1).Visible = True
End Sub
'
Private Sub ExportThreadByConversation(objItem, objSheet)
    Const PR_CONVERSATION_ID = "http://schemas.microsoft.com/mapi/proptag/0x30130102"
    Dim strConvID As String
    Dim r As Integer
    Dim c As Integer
    '
    With objItem.PropertyAccessor
        strConvID = .BinaryToString(.GetProperty(PR_CONVERSATION_ID))
    End With
    r = 2
    While objSheet.Cells(r, 1) <> ""
        If objSheet.Cells(r, 1) = strConvID Then
            Exit Sub
        End If
        r = r + 1
    Wend
    objSheet.Cells(r, 1) = strConvID
    c = 2
    EnumConversation objItem.GetConversation().GetRootItems, objSheet, r, c
End Sub
'
Private Sub EnumConversation(colItems As SimpleItems, objSheet, r As Integer, c As Integer)
    Dim objItem 'As MailItem
    Dim conv As Conversation
    Dim colSubItems As SimpleItems
    For Each objItem In colItems
        WriteCell objItem, objSheet, r, c
        c = c + 6
        Set conv = objItem.GetConversation()
        Set colSubItems = conv.GetChildren(objItem)
        If colSubItems.Count > 0 Then
            EnumConversation colSubItems, objSheet, r, c
        End If
    Next
End Sub
'
Private Sub ExportThreadByMessageId(objItem As MailItem, objSheet)
    Const PR_INTERNET_MESSAGE_ID = "http://schemas.microsoft.com/mapi/proptag/0x1035001e"
    Const PR_IN_REPLY_TO_ID = "http://schemas.microsoft.com/mapi/proptag/0x1042001e"
    Dim strMsgID As String
    Dim strRepID As String
    Dim r As Integer
    Dim c As Integer
    Dim bFound As Boolean
    '
    With objItem.PropertyAccessor
        strMsgID = .GetProperty(PR_INTERNET_MESSAGE_ID)
        strRepID = .GetProperty(PR_IN_REPLY_TO_ID)
    End With
    '
    With objSheet
        c = 2
        If strRepID = "" Then
            r = .UsedRange.Rows.Count + 1
        Else
            bFound = False
            r = 2
            While (Not bFound) And .Cells(r, 1) <> ""
                If InStr(.Cells(r, 1), strRepID) > 0 Then
                    While .Cells(r, c) <> ""
                        c = c + 6
                    Wend
                    bFound = True
                Else
                    r = r + 1
                End If
            Wend
        End If
        .Cells(r, 1) = .Cells(r, 1) & strMsgID
        WriteCell objItem, objSheet, r, c
    End With
End Sub
'
Private Sub WriteCell(objItem, objSheet, r As Integer, c As Integer)
    With objSheet
        .Cells(r, c) = objItem.SentOn
        .Cells(r, c + 1) = objItem.To
        .Cells(r, c + 2) = objItem.CC
        .Cells(r, c + 3) = objItem.Sender
        .Cells(r, c + 4) = objItem.Subject
        .Cells(r, c + 5) = objItem.Body
    End With
End Sub


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