マクロで書式設定した文字列を予定アイテムの本文に書き込む方法

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


お世話になります。OUTLOOKの予定表の本文中の書式設定(フォント、色、サイズ)を変更したいのですが、

どのようにしたらできるでしょうか?ご教示ください。

現状、objITEM.Body= ” xxxxxxxx ” にて本文を設定しています。

メールの場合には .HTMLBody= “” & “” などで、変更できたのですが。

お手数ですがよろしくお願いいたします。


Outlook 2013 まで、予定アイテムや仕事アイテムは常にリッチテキスト形式でした。
Outlook 2016 からは予定アイテムでもリッチテキスト以外の形式が選択できるようになりましたが、以前の動作を引き継いでいるためか、AppointmentItem には HTMLBody プロパティがありません。

リッチテキスト形式の本文を格納する RTFBody プロパティもあるのですが、リッチテキスト形式のデータは HTML に比較するとかなり複雑なものとなっており、これを使って書式設定を行うというのはちょっと現実的ではありません。

そこで、予定表の本文で書式設定を行いたい場合は、本文の編集に使用されている Word コンポーネントを利用します。

InspectorWordEditor プロパティで取得できる Word の Document オブジェクトを使用すると、本文に書式設定を行った文字列を書き込むことができます。

以下のマクロは、本文に様々な書式設定の文字列を書き込むサンプルです。

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

Public Sub WriteRichTextToBody()
     Dim wrdEditor As Object ' Word.Document
    ' Word のコンポーネントを取得
     Set wrdEditor = ActiveInspector.WordEditor
     ' Selection オブジェクトで書き込みを行う
     With wrdEditor.Application.Selection '
         ' フォント指定の例
         .Font.Name = "Meiryo"
        ' フォントサイズ指定の例
         .Font.Size = 10
         ' 太字の例
         .Font.Bold = True
         .TypeText "太字" & vbCrLf
         .Font.Bold = False
         ' 斜体の例
         .Font.Italic = True
         .TypeText "斜体" & vbCrLf
         .Font.Italic = False
         ' 下線の例
         .Font.Underline = True
         .TypeText "下線" & vbCrLf
         .Font.Underline = False
         ' 色指定: 赤
         .Font.ColorIndex = 6 ' wdRed
         .TypeText "red" & vbCrLf
         ' 色指定: 緑
         .Font.ColorIndex = 11 ' wdGreen
         .TypeText "green" & vbCrLf
         ' 色指定: 青
         .Font.ColorIndex = 2 ' wdBlue
         .TypeText "blue" & vbCrLf
     End With
End Sub

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

転送の際に元の差出人を返信先として設定するマクロ

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


こんにちは。

実は初めましてではありません。以前も助けていただいたことがあります。
そのときは、ありがとうございました。

私、とある任務を持っています。それは、会社の代表メールに着信したメールを振り分けるという、それなりに大事なこと。

しかしOutlook(2013/2016)で普通に転送をすると、「送信者」は当然”私”となります。よって、転送メールを受け取った人は、それほど深く考えずメールに対し返信をすることで、すべて私に戻ってくるわけです。

これの解決策として、世の中には「リダイレクト」という仕組みが用意されています。Outlookでも「仕分けルール」を使うことで(自動的に)行えるようですが、自動的ではダメなのです。

受信したメールを確認し、”このメールは人事課”,”このメールは総務課”とひとつひとつ大事に転送を掛けていきたいのですが、Outlook(手動)でなんとか出来るようになりませんか?

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

風のピエロ


残念ながら、Outlook ではリダイレクトを実現することはできません。
仕分けルールでリダイレクトが使用できるのは、Exchange サーバーにリダイレクト機能が実装されており、サーバー上でルールが実行されるためです。

ただ、Outlook ではメールの返信先を指定できるので、転送の際に元のメールの差出人を返信先に指定すれば、転送メールの返信が元のメールの差出人に返されるようになります。

返信先の指定を自動的に行うマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ForwardWithReplyTo()
     Dim orgMail As MailItem
     Dim fwdMail As MailItem
     Dim oneRecip As Recipient
     Dim newRecip As Recipient
     ' 現在表示中のメールを取得
     Set orgMail = ActiveInspector.CurrentItem
     ' 転送メールを作成
     Set fwdMail = orgMail.Forward
     ' 転送メールの返信先に元のメールの差出人を追加
     Set newRecip = fwdMail.ReplyRecipients.Add(orgMail.SenderEmailAddress)
     newRecip.Resolve
     ' 転送メールの返信先に元のメールの宛先、Cc を追加
     For Each oneRecip In orgMail.Recipients
         Set newRecip = fwdMail.ReplyRecipients.Add(oneRecip.Address)
         newRecip.Type = oneRecip.Type
         newRecip.Resolve
     Next
     ' 転送メールを表示
     fwdMail.Display
End Sub

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

会議室の一覧を取得するマクロ

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


はじめまして。

マクロを使用して、現在登録されている会議室名をすべて取得したいと考えています。

どのような関数を利用して、実現するのがよいのかお知恵を拝借できれば幸いです。


登録されている会議室名というのは、Exchange サーバーの会議室メールボックスとして登録されているアカウントの名前ということでよいでしょうか?
会議室の一覧を取得するというような関数はありませんので、以下のような手順で取得する必要があります。

  1. アドレス帳の一覧からグローバル アドレス一覧を取得する
  2. グローバル アドレス一覧のエントリーから PR_DISPLAY_TYPE_EX の値が DT_ROOM であるエントリーを抽出して取得する

マクロにすると以下のようになります。
取得した会議室名をどのように使うのかがわからなかったので、この関数では会議室名を文字列の配列に格納して返しています。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Function GetRooms() As String()
     On Error Resume Next
     Const PR_DISPLAY_TYPE_EX = "http://schemas.microsoft.com/mapi/proptag/0x39050003"
     Const DT_ROOM = 7
     Dim alGAL As AddressList
     Dim aeUser As AddressEntry
     Dim strRooms As String
     ' Exchange のグローバル アドレス一覧を取得
     For Each alGAL In Session.AddressLists
         If alGAL.AddressListType = olExchangeGlobalAddressList Then
             Exit For
         End If
     Next
     ' グローバル アドレス一覧から会議室メールボックスを検索
     strRooms = ""
     For Each aeUser In alGAL.AddressEntries
         If aeUser.AddressEntryUserType = olExchangeUserAddressEntry Then
             Dim lType As Long
             lType = aeUser.PropertyAccessor.GetProperty(PR_DISPLAY_TYPE_EX)
             ' PR_DISPLAY_TYPE_EX が DT_ROOM なら会議室
             If lType = DT_ROOM Then
                 strRooms = strRooms & aeUser.Name & vbTab
             End If
         End If
     Next
     ' 会議室一覧の文字列を配列に変換
     If Len(strRooms) > 0 Then
         strRooms = Left(strRooms, Len(strRooms) - 1)
         GetRooms = Split(strRooms, vbTab)
     End If
End Function

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

本文の内容から時間を取得してフラグの期限を設定するマクロ

本文の内容からフラグの期限を設定するマクロのコメントにて以下のご要望をいただきました。


このマクロの応用で、時間を本文から取得してフラグを設定するマクロを作りたいのですが、理解が足りず挫折してしまいました。
やりたいことは、
・期限の日付は、メール受信の当日でOK
・「予定終了時間:」の後に続く時間(例:19:00)を取得して、その時間を期限として
 アラームが立ち上がるようなフラグを立てたい。

どう書き換えればよいか、教えて頂けないでしょうか?


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

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddFlagWithAlarmByTime()
     Dim objMsg As MailItem
     Dim i As Integer
     Dim strTime As String
     Dim strDate As String
     '
     If Not ActiveInspector Is Nothing Then
         Set objMsg = ActiveInspector.CurrentItem
     ElseIf ActiveExplorer.Selection.Count = 1 Then
         Set objMsg = ActiveExplorer.Selection(1)
     Else
         MsgBox "メッセージを開くか、選択してください。", vbCritical, "フラグ追加"
         Exit Sub
     End If
     '
     i = InStr(objMsg.Body, "予定終了時間:")
     If i > 0 Then
         i = i + 7
         strTime = ""
         While InStr(" 0123456789:", Mid(objMsg.Body, i, 1)) > 0
             strTime = strTime & Mid(objMsg.Body, i, 1)
             i = i + 1
         Wend
         strDate = FormatDateTime(Now, vbShortDate) & " " & strTime
         '
         objMsg.MarkAsTask olMarkToday
         objMsg.FlagRequest = "ご確認ください"
         objMsg.TaskStartDate = Now
         objMsg.TaskDueDate = strDate
         objMsg.ReminderSet = True
         objMsg.ReminderTime = strDate
         objMsg.Save
     End If
End Sub

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

特定の連絡先から受信者のアドレスのエントリーを検索し、電子メール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

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

ビューをファイルにエクスポート・インポートするスクリプト

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


いつも大変お世話になっております。
可能であればマクロ作成をご検討頂きたいのです。
OS:Windows 7 Professional(64bit)
Outlook2013
【ビューの定義をエクスポート(インポート)するマクロ】
【印刷スタイルの定義をエクスポート(インポート)するマクロ】
ビューの定義や印刷スタイルの定義を社内で統一して利用したい。
私が現在設定しているビューを
PC内(Outlook2013)でコピーする事は出来ますが
別PC(Outlook2013)へビューや印刷スタイルの定義を
エクスポート(インポート)する事は出来ないでしょうか?
標準の機能として、これらの定義のエクスポート(インポート)はないようなので
マクロで作成可能であればお願いしたい次第です。
ビューについては
【現在のビューの設定をサブフォルダにコピーするマクロ】や
2014年2月22日 コメントでの要望を受けての
全てのストアのフォルダー階層にアクセス可能な
【現在のビューをすべてのフォルダーに適用するマクロ】
上記の2つのマクロをどうにかすれば可能なのでしょうか?
ご検討の程、よろしくお願い申し上げます。


まず、印刷スタイルの定義ですが、こちらは以下のファイルに保存されています。(ファイルに拡張子はありません)

    c:\users\ユーザー名\AppData\Roaming\Microsoft\Outlook\OutPrnt

このファイルを単にコピーすれば、他の環境に印刷スタイルの定義をコピーすることができます。

次に、ビューの設定ですが、こちらはご指摘のマクロでやっているように、View オブジェクトの XML プロパティの文字列をエクスポート・インポートすれば、他の環境にビューの定義をコピーすることができます。
ただし、自動書式についてはコピーすることはできません。

現在表示しているフォルダーの現在のビュー設定をファイルにエクスポートするスクリプトは以下のようになります。
複数の PC で実行することを想定したため、スクリプトとして実装しました。
この内容をメモ帳などのテキストエディタに貼り付け、拡張子を .vbs として保存し、ダブルクリックして実行してください。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const VIEW_XML = "C:\temp\current.view" ' エクスポート先のファイル名
Dim olkApp
Dim objFSO
Dim curView
Dim stmXml
Dim strXml
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set curView = olkApp.ActiveExplorer.CurrentFolder.CurrentView
strXml = curView.XML
Set stmXml = objFSO.CreateTextFile(VIEW_XML)
' 1 行目はビューの名前と種類
stmXml.WriteLine curView.Name & vbTab & curView.ViewType
stmXml.Write strXml
stmXml.Close

また、上記のスクリプトでエクスポートしたビュー設定を、現在表示しているフォルダーにインポートするスクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。
On Error Resume Next
Const VIEW_XML = "C:\temp\current.view" ' インポート先のファイル名
Dim olkApp
Dim objFSO
Dim stmXml
Dim strLine
Dim arrLine
Dim colViews
Dim curView
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set stmXml = objFSO.OpenTextFile(VIEW_XML, 1)
' 1 行目はビューの名前と種類
strLine = stmXml.ReadLine
arrLine = Split(strLine, vbTab)
Set colViews = olkApp.ActiveExplorer.CurrentFolder.Views
Set curView = colViews.Add(arrLine(0), arrLine(1), 0)
If Err.Number = 5 Then ' 同名のビューが存在した場合のエラー処理
    For Each curView In colViews
        ' 同名のビューを検索
        If curView.Name = arrLine(0) Then
            Exit For
        End If
    Next
End If
curView.XML = stmXml.ReadAll
curView.Save
curView.Apply
stmXml.Close

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

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


お世話になります。今回初めてコメントをさせていただきます。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

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