本文から取得したデータを項目別に Excel のシートに書き出すマクロ

メールの内容を Excel ファイルにかき出すマクロ のコメントにて以下のご要望をいただきました。


はじめまして。
横からの質問で申し訳ありません。
どうしても自分では解決できずなんとかお力をお借りしたいと思います。

メールの本文中、

【 ご予定日 】 12月
【 日 】 31日
【 泊数 】 1泊
【 名前 】 山田 太郎
【 郵便番号 】 4562215
【 ご住所 】 愛知県豊明市西町5丁目111-111
【 マンション名等 】豊明マンション101
【 Email 】 taroyamada@yahoo.co.jp
【 tel1 】 0902200000
【 ご予約人数 】 2人
【 小学生以下人数 】 1人

のように項目ごとのフォーム送信がある場合、エクセルの2行目以降のセルに

(A1) (B1) …
ご予定日 日 泊数 名前 郵便番号 …
(A2) (B2) …
12 31 1 山田 太郎 4562215 …

のように①、メール本文内の項目の後の文字列を抽出し、エクセルの対象項目に対して個別にエクスポートすることは可能なのでしょうか?
またその折②、日にち、泊数などは数字のみ抽出できればうれしいです。
outlookのエクスポート機能はwordの差し込みフィールドのように使えて便利そうなのですが2003以降のバージョンには対応していないようですし、本文中の項目までは当然読み込めませんのでなんとかマクロで解決できればと思っております。
ただ、マクロはネットで引っ張りながらさわるぐらいしかできません。
こういった投稿、コメントに不慣れで甚だ不躾ではございますが是非ご教示頂ければ幸いです。
宜しくお願い申し上げます。

追記です。
出来れば既存のエクセルデータsheet内のセルに挿入できればと考えています。


本文から項目を取り出すというような便利な関数は Outlook には用意されていませんが、VBA の文字列検索関数を使って実現することはできます。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportBodyToExcel()
    ' エクスポートする Excel ファイルのファイル名を指定
    Const EXCEL_FILE = "c:\temp\book1.xlsx" 
    Dim objBook As Object
    Dim objSheet As Object
    Dim r As Integer
    Dim strBody As String
    ' Excel ファイルを開く
    Set objBook = GetObject(EXCEL_FILE)
    objBook.Windows(1).Activate
    Set objSheet = objBook.Worksheets(1)
    ' 空行を探す
    r = 1
    While objSheet.Cells(r, 1) <> ""
        r = r + 1
    Wend
    ' メールをどのように開いているか確認
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        strBody = ActiveInspector.CurrentItem.Body
    Else
        strBody = ActiveExplorer.Selection(1).Body
    End If
    ' セルに本文から取得したデータを格納
    objSheet.Cells(r, 1) = GetValueByToken(strBody, "ご予定日", True)
    objSheet.Cells(r, 2) = GetValueByToken(strBody, "日", True)
    objSheet.Cells(r, 3) = GetValueByToken(strBody, "泊数", True)
    objSheet.Cells(r, 4) = GetValueByToken(strBody, "名前", False)
    ' 郵便番号は文字列として保存
    objSheet.Cells(r, 5) = "'" & GetValueByToken(strBody, "郵便番号", False)
    objSheet.Cells(r, 6) = GetValueByToken(strBody, "ご住所", False)
    objSheet.Cells(r, 7) = GetValueByToken(strBody, "マンション名等", False)
    objSheet.Cells(r, 8) = GetValueByToken(strBody, "Email", False) 
    ' 電話番号は文字列として保存
    objSheet.Cells(r, 9) = "'" & GetValueByToken(strBody, "tel1", False)
    objSheet.Cells(r, 10) = GetValueByToken(strBody, "ご予約人数", True)
    objSheet.Cells(r, 11) = GetValueByToken(strBody, "小学生以下人数", True)
    ' 項目を追加したければ以下のフォーマットで追加 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", True) '数字のみ取り出す場合 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", False) '文字列として取り出す場合
    ' 変更したファイルを保存
    objBook.Save
    objBook.Close
    MsgBox "保存しました。"
End Sub
'
'  本文から指定された項目のデータを取得する関数
'
Private Function GetValueByToken(strBody As String, strToken As String, bNumOnly As Boolean)
    Dim i As Integer
    Dim strLine As String
    Dim strValue As String
    Dim c As String
    i = InStr(strBody, "【 " & strToken & " 】")
    If i > 0 Then
        strValue = ""
        strLine = Mid(strBody, i + Len(strToken) + 4)
        i = InStr(strLine & vbCrLf, vbCrLf)
        ' 余計な空白を削除
        strValue = Trim(Left(strLine, i - 1))
        If bNumOnly Then  ' 数字のみが指定された場合
            For i = 1 To Len(strValue)
                c = Mid(strValue, i, 1)
                If c < "0" Or "9" < c Then
                    strValue = Left(strValue, i - 1)
                    Exit For
                End If
            Next
        End If
        GetValueByToken = strValue
    Else
        GetValueByToken = ""
    End If
End Function

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

空き時間情報のみの権限を持つ予定表のアイテム数を取得する方法

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


はじめまして。Outlookマクロについて頼れるサイトとして、こちらのサイトで学んでいます。
Outlookのマクロで簡単にできそうなことで行き詰っています。
1 共有を得ていない方の予定表の一定期間のアイテム数を取得したいのですが、共有している場合は簡単に取得できるのに、うまくいきません。方法はあると思うのですが。
2 次善の手段として、予定表でステイタスバーに表示される「ビューのアイテム数」を取得したいのですが、これもわかりません。どのオブジェクトの何ていうプロパティか、教えてください。
1でも2でも、ご教示頂けると助かります。是非ともよろしくお願いします。



「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロの記事で説明している通り、Exchange 環境でフォルダーのアクセス権限が「空き時間情報、件名、場所」となっている場合、EWS でアクセスする必要があります。
引数として取得したいユーザーのアドレスと開始日、終了日を指定すると、予定の件数を取得する関数を作りました。
EWS_URL には Exchange サーバーの EWS の URL を指定します。
また、 GetFreeBusyCountTest は動作を説明するためのサンプルになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Private Function GetFreeBusyCount(strUser As String, dtStart As Date, dtEnd As Date) As Integer
    On Error Resume Next
    ' EWS の URL を指定します。
    Const EWS_URL = "https://casserver.example.com/ews/exchange.asmx"
    Dim xmlHttp
    Dim strXmlData As Variant
    Dim strStart As String
    Dim strEnd As String
    Dim xmlDoc
    Dim i As Integer
    ' EWS リクエスト生成
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    strXmlData = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
        "<soap:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance""" & _
        " xmlns:xsd=""http://www.w3.org/2001/XMLSchema""" & _
        " xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<soap:Body>" & _
        "<GetUserAvailabilityRequest xmlns=""http://schemas.microsoft.com/exchange/services/2006/messages""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<t:TimeZone xmlns=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<Bias>-540</Bias>" & _
        "<StandardTime><Bias>0</Bias><Time>00:00:00</Time><DayOrder>0</DayOrder><Month>0</Month><DayOfWeek>Sunday</DayOfWeek></StandardTime>" & _
        "<DaylightTime><Bias>-60</Bias><Time>00:00:00</Time><DayOrder>0</DayOrder><Month>0</Month><DayOfWeek>Sunday</DayOfWeek></DaylightTime>" & _
        "</t:TimeZone>" & _
        "<MailboxDataArray>"
    ' 取得するメールボックスを追加
    strXmlData = strXmlData & _
        "<t:MailboxData><t:Email><t:Address>" & strUser & "</t:Address></t:Email>" & _
        "<t:AttendeeType>Required</t:AttendeeType><t:ExcludeConflicts>false</t:ExcludeConflicts>" & _
        "</t:MailboxData>"
    ' 取得する期間を設定
    strStart = Format(dtStart, "yyyy-mm-ddThh:nn:ss")
    strEnd = Format(dtEnd, "yyyy-mm-ddThh:nn:ss")
    strXmlData = strXmlData & _
        "</MailboxDataArray>" & _
        "<t:FreeBusyViewOptions>" & _
        "<t:TimeWindow>" & _
        "<t:StartTime>" & strStart & "</t:StartTime>" & _
        "<t:EndTime>" & strEnd & "</t:EndTime>" & _
        "</t:TimeWindow>" & _
        "<t:MergedFreeBusyIntervalInMinutes>60</t:MergedFreeBusyIntervalInMinutes>" & _
        "<t:RequestedView>DetailedMerged</t:RequestedView>" & _
        "</t:FreeBusyViewOptions>" & _
        "</GetUserAvailabilityRequest>" & _
        "</soap:Body>" & _
        "</soap:Envelope>"
    ' リクエスト送信
    xmlHttp.Open "POST", EWS_URL, False ' , strDom & "\" & strUser, strPass
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.Send strXmlData
    If xmlHttp.Status = "200" Then
        Set xmlDoc = CreateObject("MSXML2.DOMDocument")
        If xmlDoc.LoadXML(xmlHttp.responseText) Then
            ' OK なら件数を取得
            Set arrFBResps = xmlDoc.DocumentElement.getElementsByTagName("FreeBusyResponse")
            GetFreeBusyCount = arrFBResps(0).getElementsByTagName("CalendarEvent").Length
            Exit Function
        End If
    End If
    ' エラーなら 0 件とする
    GetFreeBusyCount = 0
End Function
'
Public Sub GetFreeBusyCountTest()
    On Error GoTo ErrorHandler
    Dim strUser As String
    Dim strStart As String
    Dim dtStart As Date
    Dim strEnd As String
    Dim dtEnd As Date
    Dim cFreeBusy As Integer
    '
    strUser = InputBox("取得するユーザーのアドレス:")
    strStart = InputBox("開始日")
    dtStart = CDate(strStart)
    strEnd = InputBox("終了日")
    dtEnd = DateAdd("d", 1, CDate(strEnd))
    cFreeBusy = GetFreeBusyCount(strUser, dtStart, dtEnd)
    MsgBox "予定の件数は " & cFreeBusy & " 件です。"
    Exit Sub
ErrorHandler:
    MsgBox Err.Description
End Sub

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

Excel のデータをもとに会議の変更通知やキャンセル通知を送信するマクロ

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


はじめまして。このサイトを活用させていただき、いろいろ勉強させていただいています。
このサイトを参考に、Outlook2007(Exchange環境)で会議出席依頼を発信するExcelマクロツールを作成しましたが、発信した会議出席依頼を、件名と開催時刻と終了時刻をキーに特定して、キャンセルの上、キャンセル通知を発信するマクロをご教示お願いいたします


はじめまして。「Excel のデータをもとに会議出席依頼を送信するマクロ」 を使用させていただいてますが以下の内容もできないでしょうか?
1.エクセル記載の日付、開始時間、終了時間、件名、場所が一致する会議予定を削除、又はキャンセル通知を送信する
2.エクセル記載の日付、開始時間、終了時間、件名、場所が一致する会議予定の日付、又は開始/終了時間を変更 する
ご教授頂けると助かります。よろしくお願い致します。



Outlook で変更通知を送信するには、元の会議アイテムに変更を加えて、改めて Send メソッドを実行します。
また、キャンセル通知を送信するには、元の会議アイテムの MeetingStatus を olMeetingCanceled (5) に変更し、Send メソッドを実行します。
以下のような Excel シートをもとに会議の変更およびキャンセルを行う Excel のマクロを作成しました。

  A B C D E F G H
1 日付 開始時刻 終了時刻 件名 場所 変更日付 変更開始 変更終了
2 2016/10/03 10:00 11:00 会議A 会議室1 2016/10/03 11:00 12:00
3 2016/10/04 11:00 12:00 会議B 会議室2      

変更日付が設定されている会議は変更通知を送信し、設定されていない会議はキャンセル通知を送信して削除します。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ModifyCancelMeetingRequest()
    Const olFolderCalendar = 9
    Const olMeetingCanceled = 5
    Dim olkApp 'As Outlook.Application
    Dim fldCalendar 'As Outlook.Folder
    Dim objAppt 'As Outlook.AppointmentItem
    Dim r As Integer
    Dim dtAppt As Date
    Dim strStart As String
    Dim strEnd As String
    Dim strSubject As String
    Dim strLocation As String
    '
    Set olkApp = CreateObject("Outlook.Application")
    Set fldCalendar = olkApp.Session.GetDefaultFolder(olFolderCalendar)
    r = 2
    With Sheet1
        ' 日付のセルに値がある間繰り返す
        While .Cells(r, 1) <> ""
            ' セルで指定された条件の予定を検索
            Set objAppt = fldCalendar.Items.Find( _
                "[開始日] = '" & .Cells(r, 1) & " " & FormatDateTime(.Cells(r, 2), vbShortTime) & "' AND " & _
                "[終了日] = '" & .Cells(r, 1) & " " & FormatDateTime(.Cells(r, 3), vbShortTime) & "' AND " & _
                "[件名] = '" & .Cells(r, 4) & "' AND " & _
                "[場所] = '" & .Cells(r, 5) & "'")
            If Not objAppt Is Nothing Then
                If .Cells(r, 6) = "" Then ' 変更日付がなければ削除
                    ' 会議をキャンセル状態とする
                    objAppt.MeetingStatus = olMeetingCanceled
                    ' キャンセル通知を送信
                    objAppt.Send
                    ' キャンセルした会議を削除
                    objAppt.Delete
                Else    ' 変更日付があれば変更
                    objAppt.Start = .Cells(r, 6) & " " & FormatDateTime(.Cells(r, 7), vbShortTime)
                    objAppt.End = .Cells(r, 6) & " " & FormatDateTime(.Cells(r, 8), vbShortTime)
                    ' 変更通知を送信
                    objAppt.Send
                End If
            End If
            r = r + 1
        Wend
    End With
End Sub

フォルダーに含まれるメールをすべてテキスト形式に変換するマクロ

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


初めまして、お世話になります。
日常的にoutlookを使用しており、メールフォルダが20GBを超える状態です。
添付ファイルはこちらのマクロで、一括削除を行う方法を知り、ずいぶん整理が進みました。
マクロ制作のお願いですが、授受しているメールが、HTMLか、リッチテキスト形式なのですが、
その受信メールをフォルダごと、テキストへ変換するマクロがあると、とても助かります。
よろしくご検討願います。



MailItem の BodyFormat プロパティには本文形式が格納されているのですが、このプロパティにテキスト形式を意味する olFormatPlain を設定して保存すると、本文形式をテキストに変換することができます。
表示中のフォルダーに含まれるメールをすべてテキスト形式にするマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ConvertToText()
    Dim fldCurrent As Folder
    Dim objItem As MailItem
    ' 現在表示中のフォルダーを取得
    Set fldCurrent = ActiveExplorer.CurrentFolder
    ' フォルダーのすべてのアイテムをチェック
    For Each objItem In fldCurrent.Items
        ' 本文形式を確認
        If objItem.BodyFormat <> olFormatPlain Then
            ' テキスト形式でなければ、テキスト形式にして保存
            objItem.BodyFormat = olFormatPlain
            objItem.Save
        End If
    Next
End Sub

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

転送時に分類項目を件名に付与するマクロ

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


分類項目を付けたメールを、転送する時にメールの件名に分類項目名を付加して送信するマクロをお願いいたします。
outlook2010です。



以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ForwardWithCategories()
    Dim objItem As MailItem
    Dim fwdItem As MailItem
    If TypeName(ActiveWindow) = "Inspector" Then
        Set objItem = ActiveInspector.CurrentItem
    Else
        Set objItem = ActiveExplorer.Selection(1)
    End If
    '
    Set fwdItem = objItem.Forward
    fwdItem.Subject = "FW: [" & objItem.Categories & "] " & fwdItem.ConversationTopic
    ' 分類項目を FW: より前に追加する場合は以下の記述を使用
    'fwdItem.Subject = "[" & objItem.Categories & "] " & fwdItem.Subject
    fwdItem.Display
End Sub

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

「空き時間情報、件名、場所」の権限がある他のユーザーの予定を CSV にエクスポートするマクロ

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


いつも参考にさせていただいております。
現在、こちらの[Exchange 環境の複数ユーザーの予定を CSV にエクスポートするマクロ]の記事を参考にExchange環境のスケジュールを取得しようと考えております。

こちらのExchange環境では、参照者のフォルダへのアクセス権限が「件名」「場所」「空き時間情報」のみとなっているためか、開始時間や終了時間をキーにFindしようとしても失敗してしまいます。

そこで、件名をキーにすべてのスケジュールを抽出したいのですがどのようにすればよろしいか教えていただいてもよろしいでしょうか。
Findではできないかと思い、Restrictを使用したりしたのですが出力形式が違うためうまく動作しません。

よろしくお願いいたします。



「空き時間情報、件名、場所」の権限がある他のユーザーの予定を一括で表示するマクロの記事で説明している通り、Exchange 環境でフォルダーのアクセス権限が「空き時間情報、件名、場所」となっている場合、EWS でアクセスする必要があります。
こちらの記事のマクロでは HTML 形式にして表示していますが、CSV 形式でファイルにエクスポートするよう編集しました。
マクロは以下の通りです。
EWS_URL には Exchange サーバーの EWS の URL を指定します。
なお、EWS では件名を検索条件とすることはできないため、開始日時と終了日時を検索条件に指定しています。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub ExportOthersCalendarFB()
    On Error Resume Next
    Const CSV_FILE_NAME = "c:\temp\thismonth.csv" ' エクスポートするファイル名を指定してください。
    Const EWS_URL = "http://casserver.example.com/ews/exchange.asmx&quot; ' EWS の URL を指定します。
    Dim aMailboxes
    ' エクスポートしたいユーザーのメールアドレスを指定します。
    aMailboxes = Array("user1@example.com", "user2@example.com", "user3@example.com")
    Dim dtExport As Date
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim xmlDoc As Variant
    Dim arrFBResps As Variant
    Dim i, j As Integer
    '
    dtExport = Now ' 来月の予定をエクスポートする場合は Now の代わりに DateAdd("m",1,Now) を使用します。
    ' 月単位ではなく任意の単位にする場合は以下の記述を変更します。
    dtStart = CDate(Year(dtExport) & "/" & Month(dtExport) & "/1 00:00")
    dtEnd = DateAdd("m", 1, dtStart)
    ' ヘッダー部分の出力
    Open CSV_FILE_NAME For Output As #1
    Print #1, """ユーザー"",""件名"",""場所"",""開始日時"",""終了日時"",""公開方法"""
    ' 空き時間情報を取得
    Set xmlDoc = Nothing
    GetUsersAvailability EWS_URL, aMailboxes, dtStart, dtEnd, xmlDoc
    If xmlDoc Is Nothing Then
        Close #1
        Exit Sub
    End If
    ' 取得した空き時間
    Set arrFBResps = xmlDoc.DocumentElement.getElementsByTagName("FreeBusyResponse")
    For i = 0 To arrFBResps.Length - 1
        ' 取得が成功したか確認
        If arrFBResps(i).getElementsByTagName("ResponseMessage").Item(0).Attributes.getNamedItem("ResponseClass").Text = "Success" Then
            Dim objRec As Recipient
            Dim strUserName As String
            Dim arrCalEvents As Variant
            Dim calEvent As Variant
            Dim strStatus As String
            Dim strSubject As String
            Dim strLocation As String
            Dim dtCalStart As Date
            Dim dtCalEnd As Date
            ' メールアドレスからユーザー名を取得
            Set objRec = Session.CreateRecipient(aMailboxes(i))
            objRec.Resolve
            strUserName = objRec.Name
            ' 予定を一つずつ処理
            Set arrCalEvents = arrFBResps(i).getElementsByTagName("CalendarEvent")
            For j = 0 To arrCalEvents.Length - 1
                Set calEvent = arrCalEvents(j)
                strStatus = GetValue(calEvent, "BusyType")
                strSubject = GetValue(calEvent, "Subject")
                strLocation = GetValue(calEvent, "Location")
                dtCalStart = GetDateValue(calEvent, "StartTime")
                dtCalEnd = GetDateValue(calEvent, "EndTime")
                Print #1, """" & strUserName & """,""" & strSubject & """,""" & strLocation & """,""" _
                    & dtCalStart & """,""" & dtCalEnd & """,""" & strStatus & """"
            Next
        End If
    Next
    Close #1
End Sub
'
Sub GetUsersAvailability(strUrl As String, aMailboxes As Variant, dtStart As Date, dtEnd As Date, xmlDoc As Variant)
    Dim xmlHttp
    Dim strXmlData As Variant
    Dim strStart As String
    Dim strEnd As String
    Dim i As Integer
    ' EWS リクエスト生成
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    strXmlData = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
        "<soap:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance""" & _
        " xmlns:xsd=""http://www.w3.org/2001/XMLSchema""" & _
        " xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<soap:Body>" & _
        "<GetUserAvailabilityRequest xmlns=""http://schemas.microsoft.com/exchange/services/2006/messages""" & _
        " xmlns:t=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<t:TimeZone xmlns=""http://schemas.microsoft.com/exchange/services/2006/types"">" & _
        "<Bias>-540</Bias>" & _
        "<StandardTime><Bias>0</Bias><Time>00:00:00</Time><DayOrder>0</DayOrder><Month>0</Month><DayOfWeek>Sunday</DayOfWeek></StandardTime>" & _
        "<DaylightTime><Bias>-60</Bias><Time>00:00:00</Time><DayOrder>0</DayOrder><Month>0</Month><DayOfWeek>Sunday</DayOfWeek></DaylightTime>" & _
        "</t:TimeZone>" & _
        "<MailboxDataArray>"
    ' 取得するメールボックスを追加
    For i = LBound(aMailboxes) To UBound(aMailboxes)
        strXmlData = strXmlData & _
            "<t:MailboxData><t:Email><t:Address>" & aMailboxes(i) & "</t:Address></t:Email>" & _
            "<t:AttendeeType>Required</t:AttendeeType><t:ExcludeConflicts>false</t:ExcludeConflicts>" & _
            "</t:MailboxData>"
    Next
    ' 取得する期間を設定
    strStart = Format(dtStart, "yyyy-mm-ddThh:nn:ss")
    strEnd = Format(dtEnd, "yyyy-mm-ddThh:nn:ss")
    strXmlData = strXmlData & _
        "</MailboxDataArray>" & _
        "<t:FreeBusyViewOptions>" & _
        "<t:TimeWindow>" & _
        "<t:StartTime>" & strStart & "</t:StartTime>" & _
        "<t:EndTime>" & strEnd & "</t:EndTime>" & _
        "</t:TimeWindow>" & _
        "<t:MergedFreeBusyIntervalInMinutes>60</t:MergedFreeBusyIntervalInMinutes>" & _
        "<t:RequestedView>DetailedMerged</t:RequestedView>" & _
        "</t:FreeBusyViewOptions>" & _
        "</GetUserAvailabilityRequest>" & _
        "</soap:Body>" & _
        "</soap:Envelope>"
    ' リクエスト送信
    xmlHttp.Open "POST", strUrl, False ' , strDom & "\" & strUser, strPass
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.Send strXmlData
    If xmlHttp.Status = "200" Then
        Set xmlDoc = CreateObject("MSXML2.DOMDocument")
        If xmlDoc.LoadXML(xmlHttp.responseText) Then
            ' OK ならここで終了
            Exit Sub
        End If
    End If
    ' エラーなら Nothing を設定
    Set xmlDoc = Nothing
End Sub
'
Function GetValue(xmlNode, strName)
    On Error Resume Next
    Dim arrNodes
    Set arrNodes = xmlNode.getElementsByTagName(strName)
    If arrNodes.Length = 0 Then
        GetValue = ""
    Else
        GetValue = arrNodes(0).Text
    End If
End Function
'
Function GetDateValue(xmlNode, strName)
    On Error Resume Next
    Dim arrNodes
    Dim strDate
    Set arrNodes = xmlNode.getElementsByTagName(strName)
    If arrNodes.Length = 0 Then
        GetDateValue = ""
    Else
        strDate = arrNodes(0).Text
        strDate = Replace(strDate, "-", "/")
        strDate = Replace(strDate, "T", " ")
        GetDateValue = CDate(strDate)
    End If
End Function

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

指定されたドメイン以外への送信を防ぐマクロ

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


Outlook2013を使用しています。

メールの誤送信を防ぐ為と内部セキュリティー強化に取引先数社のドメイン以外に送信できないように出来ないでしょうか。



Outlook で送信時に宛先をチェックするという場合、Application の ItemSend イベントを使用します。
たとえば、以下のようなマクロで実現できます。
Array で送信可能なドメインを指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim arrAllowedDomains
    ' 送信可能なドメイン名を指定
    arrAllowedDomains = Array("example.com", "contoso.com")
    Dim oRec As Recipient
    Dim i As Integer
    Dim strErr As String
    Dim bAllow As Boolean
    For Each oRec In Item.Recipients
        bAllow = False
        For i = 0 To UBound(arrAllowedDomains)
            If oRec.Address Like "*@" & arrAllowedDomains(i) Then
                bAllow = True
                Exit For
            End If
        Next
        ' 送信可能なドメインではない受信者が存在したら送信キャンセル
        If Not bAllow Then
            Cancel = True
            strErr = strErr & oRec.Address & ";"
        End If
    Next
    ' 送信がキャンセルされた場合にはエラー表示
    If Cancel Then
        MsgBox "以下のアドレスへの送信は許可されていません。" & vbCrLf & strErr
    End If
End Sub

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