特定の連絡先から受信者のアドレスのエントリーを検索し、電子メール2のアドレスに置き換えて返信するマクロ

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


はじめまして、いつもこのサイトの内容に助けられております。

要望なのですが、メール返信時に特定の連絡先フォルダーを参照して、同じメールアドレスの連絡先の、電子メール2のアドレスに置き換えて返信ウィンドウを開くマクロを作成することは可能でしょうか。

よろしくお願いします。


以下のようなマクロで実現できます。
マクロ中の CONTACT_FOLDER_PATH には検索する連絡先フォルダーのパスを指定します。
例えば、user@example.com というアカウントの “連絡先” フォルダーの下の “取引先” というようなフォルダーの場合、通常は “user@example.com\連絡先\取引先” という文字列を指定します。
なお、場合によっては “個人用 Outlook データ ファイル\連絡先” のような場合もありますので、正確なパスはフォルダー一覧を表示して確認してください。

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

Public Sub ReplyWithSecondAddress()
     Dim curItem As MailItem
     Dim repItem As MailItem
     Dim i As Integer
     Dim oneRecip As Recipient
     Dim newAddress As String
     Dim newRecip As Recipient
     '
     If TypeName(ActiveWindow) = "Inspector" Then
         Set curItem = ActiveInspector.CurrentItem
     Else
         Set curItem = ActiveExplorer.Selection(1)
     End If
     Set repItem = curItem.ReplyAll
     '
     For i = repItem.Recipients.Count To 1 Step -1
         Set oneRecip = repItem.Recipients(i)
         ' 電子メール 2 を検索
         newAddress = FindSecondAddress(oneRecip.AddressEntry)
         ' 電子メール 2 が見つかったら置き換え
         If newAddress <> "" Then
             Set newRecip = repItem.Recipients.Add(newAddress)
             newRecip.Type = oneRecip.Type
             oneRecip.Delete
         End If
     Next
     '
     repItem.Recipients.ResolveAll
     repItem.Display
End Sub
'
' 特定のフォルダーから連絡先を検索し、電子メール 2 のアドレスを返す関数
'
Private Function FindSecondAddress(addrEntry As AddressEntry) As String
     ' 検索する連絡先フォルダーのパスを指定
     Const CONTACT_FOLDER_PATH = "メールアドレス\連絡先\テスト"
     Dim arrPath As Variant
     Dim i As Integer
     Dim fldContact As Folder
     Dim objContact As ContactItem
     Dim newAddress As String
     ' 連絡先フォルダーを検索
     arrPath = Split(CONTACT_FOLDER_PATH, "\")
     Set fldContact = Session.Folders(arrPath(0))
     For i = 1 To UBound(arrPath)
         Set fldContact = fldContact.Folders(arrPath(i))
     Next
     ' 電子メール 1 のアドレスを検索
     Set objContact = fldContact.Items.Find("[Email1Address] = '" & addrEntry.Address & "'")
     If Not objContact Is Nothing Then
         With objContact
             ' 連絡先が見つかったら電子メール 2 のアドレスを確認
             If .Email2Address <> "" Then
                 ' 電子メール 2 が設定されていたら戻り値として設定
                 If InStr(.Email2DisplayName, .Email2Address) > 0 Then
                     newAddress = .Email2DisplayName
                 Else
                     newAddress = .Email2DisplayName & " <" & .Email2Address & ">"
                 End If
             End If
         End With
     Else
         newAddress = ""
     End If
     FindSecondAddress = newAddress
End Function

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

年、月、日の階層構造のフォルダーを作成してアイテムを移動するマクロ

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


お世話になります。今回初めてコメントをさせていただきます。Outlook2010、Outlook2013の環境で、決まった差出人のメールを、受信トレイ配下に階層深くチェックした後に、移動させたいのですが、その時にフォルダが存在しない時は、作成してメールを移動させたいのですが、1回目は階層深くフォルダを作成し、移動することはできるようになったのですが、翌日、同じマクロを実行すると、最階層の下にフォルダをまた、階層深く作成してしまって、どうにかして、最階層だけ作成して、メールを移動するようにしたいのですが、よくわからないのです。ご教授いただけると助かります。
受信トレイから→チェック済→年度→月→日に移動させたいのです。翌日は新しい日のフォルダが月の下に作成されて、メールが移動される。月が変わったら、新しく月と日のフォルダを作成して、日のフォルダにメールが移動される。年度が変わったら、年度、月、日のフォルダが作成され、新しい日のフォルダにメールが移動されるようにしたいのです。マクロVBAを作成した経験がなく、非常に困っております。どなたかご教授いただけると助かります。よろしくお願いいたします。


フォルダーが存在するかどうかを確認し、存在しない場合だけ作成するようにすれば、ご要望の動作は満たせるでしょう。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub MoveByDate()
    Dim objItem As MailItem
    Dim dt As Date
    Dim fldInbox As Folder
    Dim fldChecked As Folder
    Dim fldYear As Folder
    Dim fldMonth As Folder
    Dim fldDay As Folder
    ' 現在開いているか選択しているアイテムを取得
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        Set objItem = ActiveInspector.CurrentItem
    Else
        Set objItem = ActiveExplorer.Selection(1)
    End If
    '
    Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
    Set fldChecked = GetOrCreateFolder(fldInbox, "チェック済み")
    dt = Now ' 今日の日付でフォルダーを作成
    ' フォルダをアイテムの受信日時により作成する場合は下記の記述を使用
    ' dt = objItem.ReceivedTime
    Set fldYear = GetOrCreateFolder(fldChecked, Year(dt))
    Set fldMonth = GetOrCreateFolder(fldYear, Month(dt))
    Set fldDay = GetOrCreateFolder(fldMonth, Day(dt))
    '
    objItem.Move fldDay
End Sub
'
Private Function GetOrCreateFolder(fldParent As Folder, strName As String)
    On Error Resume Next
    Dim fldSub As Folder
    For Each fldSub In fldParent.Folders
        If fldSub.Name = strName Then
            Set GetOrCreateFolder = fldSub
            Exit Function
        End If
    Next
    Set fldSub = fldParent.Folders.Add(strName)
    Set GetOrCreateFolder = fldSub
End Function

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

HTML 形式の本文に文字列を追加する方法

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


いつも参考にさせて戴いております。今回初めて質問致します。
HTML形式で図が含まれているメールに対して
mailItem の reply メソッドを行うと図が保持されますが、本文に何かを追記しようとすると図が失われます。
保持する方法はありますでしょうか。
(Outlook 2010 or 2013, VBA はExcel から起動)
ex) objReply.body = “test” + objReply.body –> 図がなくなる


MailItem オブジェクトの Body プロパティはテキスト形式の本文を参照あるいは設定するためのプロパティです。
そのため、このプロパティに文字列を設定すると、メッセージ形式が自動的にテキスト形式に変換され、HTML の書式や図は失われてしまいます。

HTML 形式のメールの本文は HTMLBody プロパティを使って参照や設定を行います。
ただし、本文の先頭に文字列を追加する際に、以下のようにしてしまうと想定外の動作をする場合があります。

objReply.HTMLBody = "test" & objReply.HTMLBody

HTMLBody プロパティは HTML のタグを含んだ HTML 本文全体を取得するのですが、その先頭には <HEAD> タグで囲まれた CSS の定義などが存在します。
それらの定義の前に文字列を追加してしまうと、適切な処理ができなくなる可能性があるのです。

そのため、HTML 本文の先頭に文字列を追加する場合、本文の開始を意味する BODY タグを検出し、その後ろに文字列を追加する必要があります。
以下は、HTML 本文の先頭に文字列を追加するサブルーチンの例です。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub InsertStringToHTMLBody(objItem As MailItem, strText As String)
    Dim i As Long
    ' body タグの開始を検索
    i = InStr(LCase(objItem.HTMLBody), "<body")
    ' body タグの終了を検索
    i = InStr(i, objItem.HTMLBody, ">")
    ' body タグの終了位置に文字列を挿入
    objItem.HTMLBody = Left(objItem.HTMLBody, i) & strText & Mid(objItem.HTMLBody, i + 1)
    Debug.Print objItem.HTMLBody
End Sub

前の月に受信したメールのうち、特定のキーワードを含むメールをサブフォルダーも含めてカウントするマクロ

前の月に受信したメールのうち、特定のキーワードを含むメールをカウントするマクロのコメントにて以下のご要望をいただきました。


コメント失礼します。
このマクロを試させて頂き、動作を確認させて頂きました。
これは既定フォルダのみ検索したカウント数であると思います。
そうであれば1点機能を追加したいのですが、作り方がわからずご教示頂けましたら幸いです。
<内容>
受信トレイ内にあるすべてのサブフォルダにアクセスし、キーワードカウントをしたいです。
Outlook2013を使用しています。


すべてのサブフォルダーについて処理をする場合は、再帰という方法を使用します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub FindMailByKeywordLastMonthRecursive()
    On Error Resume Next
    ' 検索するキーワードを指定
    Const SEARCH_KEY = "test"
    ' レポートを作成するファイルのフルパスを指定
    Const REPORT_FILE = "c:\temp\report.txt"
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim strFilter As String
    Dim cntItems As Integer
    Dim strReport As String
    ' 前月を表す日付範囲を算出
    dtEnd = Year(Now) & "/" & Month(Now) & "/1"
    dtStart = DateAdd("m", -1, dtEnd)
    ' 日付範囲でフィルタリング
    strFilter = "[受信日時] >= #" & dtStart & "# AND [受信日時] <  #" & dtEnd & "#"
    cntItems = 0
    ' 検索実行
    strReport = FindMailRecursive(Session.GetDefaultFolder(olFolderInbox), strFilter, SEARCH_KEY, cntItems)
    ' レポート作成
    Open REPORT_FILE For Output As #1
    Print #1, SEARCH_KEY & "を含むメールの件数:", cntItems
    Print #1, strReport
    Close #1
    ' レポートをメモ帳で表示
    Shell "notepad.exe " & REPORT_FILE
End Sub
'
Private Function FindMailRecursive(fldRoot As Folder, strFilter As String, strKeyword As String, ByRef cntItems As Integer) As String
    On Error Resume Next
    Dim strReport As String
    Dim colItems As Items
    Dim objItem As Object
    Dim fldSub As Folder
    Debug.Print fldRoot.FolderPath
    ' フィルタ文字列で検索
    Set colItems = fldRoot.Items
    colItems.Restrict strFilter
    strReport = ""
    ' フィルタリングしたメールを確認
    For Each objItem In colItems
        ' 件名にキーワードを含む場合はカウンタとレポート追加
        If objItem Is MailItem Then
            If InStr(1, objItem.Subject, strKeyword, vbTextCompare) > 0 Then
                cntItems = cntItems + 1
                strReport = strReport & objItem.ReceivedTime & vbTab & objItem.Subject & vbCrLf
            End If
        End If
    Next
    ' レポートが存在する場合は先頭にフォルダーパスを追加
    If strReport <> "" Then
        strReport = "フォルダー:" & fldRoot.FolderPath & vbCrLf & strReport
    End If
    ' サブフォルダーについて再帰的に実行
    For Each fldSub In fldRoot.Folders
        strReport = strReport & FindMailRecursive(fldSub, strFilter, strKeyword, cntItems)
    Next
    '
    FindMailRecursive = strReport
End Function

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

メールの宛先に指定したアドレスを連絡先の名前に置き換えるマクロ

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


はじめまして。
いつもサイトを拝見させていただき、大変お世話になっております。
Outlook2013で連絡先の閲覧ウインドウで、名前の下にある4つのアイコンの中から一番右のメールのアイコンからメールを作成しようとすると、宛先にはメールアドレスが表示されます。この時にメールアドレスでなく、連絡先に登録してある表示名を宛先に表示する設定とかあるのでしょうか。新しい電子メールから作成した時と、送信済みアイテムの宛先が異なる名前で残ってしまうのが困っています。
宜しくお願い致します。


残念ながら閲覧ウィンドウのボタンで宛先に表示名を付けて追加する設定はありませんが、宛先がアドレスとなっている状態で以下のマクロを実行することでアドレス帳の名前に置き換えることができます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ResolveWithContacts()
    Dim objMail As MailItem
    Dim objRecip As Recipient
    Dim objContact As ContactItem
    Dim objAddrList As AddressList
    Dim i As Integer
    Dim objAddrEntry As AddressEntry
    Dim bFound As Boolean
    Dim cRecips As Integer
    Dim colAddress() As String
    Dim colName() As String
    Dim colType() As Integer
    Dim strEntryID As String
    '
    Set objMail = ActiveInspector.CurrentItem
    objMail.Save
    objMail.Recipients.ResolveAll
    cRecips = objMail.Recipients.Count
    ReDim colAddress(cRecips) As String
    ReDim colName(cRecips) As String
    ReDim colType(cRecips) As Integer
    For i = cRecips To 1 Step -1
        Set objRecip = objMail.Recipients.Item(i)
        colAddress(i) = objRecip.Address
        colName(i) = objRecip.Name
        colType(i) = objRecip.Type
        objMail.Recipients.Remove i
    Next
    '
    For i = 1 To cRecips
        bFound = False
        For Each objAddrList In Session.AddressLists
            If objAddrList.AddressListType = olOutlookAddressList Then
                For Each objAddrEntry In objAddrList.AddressEntries
                    If objAddrEntry.Address = colAddress(i) Then
                        Set objRecip = objMail.Recipients.Add(colAddress(i))
                        Set objRecip.AddressEntry = objAddrEntry
                        objRecip.Type = colType(i)
                        Exit For
                    End If
                Next
                If Not objRecip Is Nothing Then
                    Exit For
                End If
            End If
        Next
        If objRecip Is Nothing Then
            If colName(i) <> colAddress(i) Then
                Set objRecip = objMail.Recipients.Add(colName(i) & " <" & colAddress(i) & ">")
            Else
                Set objRecip = objMail.Recipients.Add(colAddress(i))
            End If
            objRecip.Type = colType(i)
            objRecip.Resolve
        End If
    Next
    objMail.Close olSave
    objMail.Display
End Sub

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

本文から取得したデータを項目別に 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

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