【Outlook VBA】 メールをカレンダーやタスクにコピーしたときに勝手に入る改行/空白行を削除するマクロ

メールをカレンダーやタスクにコピーしたときに勝手に入る改行/空白行を削除するマクロを作成した

はじめに

Outlookで受信したメールを「移動 > フォルダーへコピー > カレンダー」としてカレンダーにコピーすると、信じられないほどの改行/空白行が挿入されてしまう

これは、Outlookのタスクやカレンダーの本文はWordを用いて編集されているため、HTML形式のメールをタスクやカレンダーにコピーすることで強制的に全ての行間に空白行が挿入されてしまうことが原因らしい

メール一般

yytomy.sakura.ne.jp

普通のメールの送受信時にはオプションでこの空白行を削除できるが、タスクやカレンダーに追加するときはそのような設定はできないので、空白行を手動で削除するか、空白行を甘んじて受け入れるしかない

テキスト形式で作成された投稿では改行が削除される - Outlook

テキスト形式の投稿で改行が削除され、Outlook に何も表示されていない場合の動作について説明します。 この動作を回避するには、改行の自動削除機能を無効にします。 または、HTML または RTF を使用してメッセージを書式設定できます。

learn.microsoft.com

そこをサクッとやってしまうマクロを作成した

それではいってみよう

使い方

ソースコード全文はこれ

Sub AddEventToCalendar()
    
    Dim objMail As Outlook.MailItem
    Dim objAppt As Outlook.AppointmentItem
    Dim arrLines() As String
    Dim i As Integer
    
    Set objMail = Application.ActiveInspector.CurrentItem '開いているメールを取得
    Set objAppt = Outlook.Application.CreateItem(olAppointmentItem) '予定表にイベントを追加
    With objAppt
        .Subject = objMail.Subject
        .Location = ""
        .Start = DateAdd("n", 60, Now) ' 現在の時間から1時間後に設定
        .End = DateAdd("n", 90, Now) ' 現在の時間から1時間30分後に設定
        
        arrLines = Split(objMail.Body, vbCrLf) 'メールの本文を改行で分割
    
        '空白行を削除して改行で連結
        .Body = ""
        .BodyFormat = olFormatRichText
        For i = LBound(arrLines) To UBound(arrLines)
            If arrLines(i) <> "" Then '空白ではない行
                .Body = .Body & arrLines(i) & vbCrLf 'そのまま予定表へコピー
            End If
        Next i
    
        '添付ファイルを一時フォルダに保存してから予定表に添付
        For Each objAttachment In objMail.Attachments
            Dim tempPath As String
            tempPath = Environ("TEMP") & "\" & objAttachment.FileName '一時フォルダのパス
            objAttachment.SaveAsFile tempPath '添付ファイルを一時フォルダに保存
            .Attachments.Add tempPath ' 一時フォルダに保存したファイルを予定表に添付
        Next objAttachment
    
        .Display ' 予定表の編集画面を開く
        .GetInspector.Activate
        .Save '予定表の内容を保存
    End With
    
    'メモリの解放
    Set objMail = Nothing
    Set objAppt = Nothing
    
    ChangeFontInBody

End Sub
Sub ChangeFontInBody()
    Dim objInspector As Outlook.Inspector 'Outlook.Inspector
    Dim objItem As Object 'Object型の変数を宣言
    Dim objWord As Word.Application  'Word. Applicationオブジェクトを宣言
    Dim objDoc As Word.Document 'Word.Documentオブジェクトを宣言
    Dim objParagraphs As Word.Paragraphs
    Dim objParagraph As Word.Paragraph
    Dim i As Long 'Long型の変数を宣言
    
    Set objInspector = Outlook.ActiveInspector
    Set objItem = objInspector.CurrentItem
    
    Set objWord = objInspector.WordEditor.Application
    Set objDoc = objWord.ActiveDocument
    
    '本文の各行をスキャンして特定の行のフォントを変更
    Set objParagraphs = objDoc.Paragraphs
    For i = 1 To objParagraphs.Count
        Set objParagraph = objParagraphs(i)
        If Left(objParagraph.Range.Text, 5) = "From:" Or _
            Left(objParagraph.Range.Text, 5) = "Sent:" Or _
            Left(objParagraph.Range.Text, 3) = "To:" Or _
            Left(objParagraph.Range.Text, 3) = "Cc:" Or _
            Left(objParagraph.Range.Text, 8) = "Subject:" _
        Then
            objParagraph.Range.Font.Name = "Calibri" 'フォントを"calibri"に変更
            If Left(objParagraph.Range.Text, 5) = "From:" Then 'テキストの先頭が"From: "である場合
                objParagraph.Range.Borders(wdBorderTop).LineStyle = wdLineStyleSingle '上部に罫線を引く
            End If
        End If
    Next i
    
    'メモリの解放
    Set objInspector = Nothing
    Set objItem = Nothing
    Set objWord = Nothing
    Set objDoc = Nothing
    Set objParagraphs = Nothing
    Set objParagraph = Nothing
    
End Sub
Sub AddEmailToTask()
    
    Dim objMail As Outlook.MailItem
    Dim objTask As Outlook.TaskItem
    Dim arrLines() As String
    Dim i As Integer
        
    '開いているメールを取得
    Set objMail = Application.ActiveInspector.CurrentItem
    Set objTask = Application.CreateItem(olTaskItem)
    
    '新しいタスクを作成
    With objTask
        .Subject = objMail.Subject 'メールタイトルをコピーしてタスクに追加
        
        arrLines = Split(objMail.Body, vbCrLf) 'メールの本文を改行で分割
        
        '空白行を削除して改行で連結
        .Body = "" 'タスク本文を初期化
        For i = LBound(arrLines) To UBound(arrLines) - 1
            If arrLines(i) <> "" Then '空白ではない行
                .Body = .Body & arrLines(i) & vbCrLf 'そのままタスクへコピー
            End If
        Next i

        '添付ファイルを一時フォルダに保存してから予定表に添付
        For Each objAttachment In objMail.Attachments
            Dim tempPath As String
            tempPath = Environ("TEMP") & "\" & objAttachment.FileName '一時フォルダのパス
            objAttachment.SaveAsFile tempPath '添付ファイルを一時フォルダに保存
            .Attachments.Add tempPath ' 一時フォルダに保存したファイルを予定表に添付
        Next objAttachment
        
        'タスクの編集画面を開く
        .Display
        .GetInspector.Activate
        
        'タスクの内容を保存
        .Save
    End With
    
    'メモリの解放
    Set objMail = Nothing
    Set objTask = Nothing
    
    ChangeFontInBody
End Sub

準備

Outlook で Alt+F11キーを押してVBAエディタを開く

「挿入」メニューから「標準モジュール」を選択して新しいモジュールを追加する

上記の AddEmailToTask サブプロシージャとChangeFontinBody サブプロシージャのコードを新しいモジュールに貼り付ける

「ツール」メニューから 「参照設定」を選択する

「参照設定」ダイアログボックスで、「Microsoft Word 16.0 Object Library」を探し、チェックボックスをオンにする (バージョンはインストールされているWordによって異なる場合がある)

「OK」ボタンをクリックしてダイアログボックスを閉じる

「ファイル > オプション > トラストセンター > トラストセンターの設定」を開く

「すべてのマクロに対して警告を表示する」にチェックを入れる

実行

タスクに追加したいメールを選択した状態でエンターキーを押し、メールをウィンドウで開く

Alt+F8キーを押してマクロウィンドウを開こうとすると、警告が出てくるので「マクロを有効にする」をクリック

AddEmailToCalendar を選択して実行をクリックする

するとあら不思議、余計な改行/空白行のない予定の編集画面が開く

あとは煮るなり焼くなり好きにすればいい

※ マクロの実行が完了した時点で新しい予定はすでにカレンダーに保存されてしまっているため、予定の作成をやり直したい場合はウィンドウを「×」で閉じるのではなく、予定の「削除」を行うこと

ソースコードの解説

AddEmailToCalendar サブプロシージャ

Sub AddEventToCalendar()
    
    Dim objMail As Outlook.MailItem
    Dim objAppt As Outlook.AppointmentItem
    Dim arrLines() As String
    Dim i As Integer
    
    Set objMail = Application.ActiveInspector.CurrentItem '開いているメールを取得
    Set objAppt = Outlook.Application.CreateItem(olAppointmentItem) '予定表にイベントを追加
    With objAppt
        .Subject = objMail.Subject
        .Location = ""
        .Start = DateAdd("n", 60, Now) ' 現在の時間から1時間後に設定
        .End = DateAdd("n", 90, Now) ' 現在の時間から1時間30分後に設定
        
        arrLines = Split(objMail.Body, vbCrLf) 'メールの本文を改行で分割
    
        '空白行を削除して改行で連結
        .Body = ""
        .BodyFormat = olFormatRichText
        For i = LBound(arrLines) To UBound(arrLines)
            If arrLines(i) <> "" Then '空白ではない行
                .Body = .Body & arrLines(i) & vbCrLf 'そのまま予定表へコピー
            End If
        Next i
    
        '添付ファイルを一時フォルダに保存してから予定表に添付
        For Each objAttachment In objMail.Attachments
            Dim tempPath As String
            tempPath = Environ("TEMP") & "\" & objAttachment.FileName '一時フォルダのパス
            objAttachment.SaveAsFile tempPath '添付ファイルを一時フォルダに保存
            .Attachments.Add tempPath ' 一時フォルダに保存したファイルを予定表に添付
        Next objAttachment
    
        .Display ' 予定表の編集画面を開く
        .GetInspector.Activate
        .Save '予定表の内容を保存
    End With
    
    'メモリの解放
    Set objMail = Nothing
    Set objAppt = Nothing
    
    ChangeFontInBody

End Sub

このサブプロシージャは、現在開いているメールアイテムをタスクアイテムに変換する

具体的な処理は以下の通り

• Application.Activeinspector.CurrentItem を使用して、現在開いているメールアイテムを取得する
• Application.CreateItem (ofTaskitem) を使用して、新しいタスクアイテムを作成する
• メールの件名を予定の件名として設定し、現在時刻から予定の開始/終了時間を仮設定する
• メールの本文を行ごとに分割し、空白行を除外した後、 タスクの本文として設定する
• メールに添付されているファイルを一時フォルダに保存し、その後タスクに添付する
• タスクの編集画面を表示し、内容を保存する
• 使用したオブジェクトを解放し、メモリをクリアする
• サブプロシージャの呼び出し: メール本文のフォントを変更するためのサブプロシージャを呼び出す

Change FontinBody サブプロシージャ

Sub ChangeFontInBody()
    Dim objInspector As Outlook.Inspector 'Outlook.Inspector
    Dim objItem As Object 'Object型の変数を宣言
    Dim objWord As Word.Application  'Word. Applicationオブジェクトを宣言
    Dim objDoc As Word.Document 'Word.Documentオブジェクトを宣言
    Dim objParagraphs As Word.Paragraphs
    Dim objParagraph As Word.Paragraph
    Dim i As Long 'Long型の変数を宣言
    
    Set objInspector = Outlook.ActiveInspector
    Set objItem = objInspector.CurrentItem
    
    Set objWord = objInspector.WordEditor.Application
    Set objDoc = objWord.ActiveDocument
    
    '本文の各行をスキャンして特定の行のフォントを変更
    Set objParagraphs = objDoc.Paragraphs
    For i = 1 To objParagraphs.Count
        Set objParagraph = objParagraphs(i)
        If Left(objParagraph.Range.Text, 5) = "From:" Or _
            Left(objParagraph.Range.Text, 5) = "Sent:" Or _
            Left(objParagraph.Range.Text, 3) = "To:" Or _
            Left(objParagraph.Range.Text, 3) = "Cc:" Or _
            Left(objParagraph.Range.Text, 8) = "Subject:" _
        Then
            objParagraph.Range.Font.Name = "Calibri" 'フォントを"calibri"に変更
            If Left(objParagraph.Range.Text, 5) = "From:" Then 'テキストの先頭が"From: "である場合
                objParagraph.Range.Borders(wdBorderTop).LineStyle = wdLineStyleSingle '上部に罫線を引く
            End If
        End If
    Next i
    
    'メモリの解放
    Set objInspector = Nothing
    Set objItem = Nothing
    Set objWord = Nothing
    Set objDoc = Nothing
    Set objParagraphs = Nothing
    Set objParagraph = Nothing
    
End Sub

このサブプロシージャは、 開いているアイテムの本文内の特定の文字列のフォントを変更し、過去の返信との境界を上罫線で明確にする

具体的な手順は以下の通り

• 現在表示中のインスペクターとアイテムを取得する
• Word エディターを介してWordアプリケーションとドキュメントオブジェクトを取得する
• 本文の各段落をスキャンし、特定のキーワード("From:", "Sent:", "To:", "Cc:", "Subject:")などで始まる行のフォントを「Calibri」に変更する
• "From:"で始まる行には、上部に罫線を追加する
• 使用したオブジェクトを解放し、メモリをクリアする

"From:", "Sent:", "To:", "Cc:", "Subject:"以外の文字から始まる行のフォントを変えたい場合は、適宜IF分の条件を追加する

            Left(objParagraph.Range.Text, 4) = "送信者:" Or _

おわりに

メールをカレンダーやタスクにコピーしたときに勝手に入る改行/空白行を削除するマクロを作成した

正直Outlook VBAについての情報がネットに少なすぎて、 Copilotの力を借りなければ絶対にこのプログラムは作れなかった

生成AI万歳

おまけ:タスクに追加する場合のサブプロシージャ

タスクに追加したい場合は以下のサブプロシージャを用いる

Sub AddEmailToTask()
    
    Dim objMail As Outlook.MailItem
    Dim objTask As Outlook.TaskItem
    Dim arrLines() As String
    Dim i As Integer
        
    '開いているメールを取得
    Set objMail = Application.ActiveInspector.CurrentItem
    Set objTask = Application.CreateItem(olTaskItem)
    
    '新しいタスクを作成
    With objTask
        .Subject = objMail.Subject 'メールタイトルをコピーしてタスクに追加
        
        arrLines = Split(objMail.Body, vbCrLf) 'メールの本文を改行で分割
        
        '空白行を削除して改行で連結
        .Body = "" 'タスク本文を初期化
        For i = LBound(arrLines) To UBound(arrLines) - 1
            If arrLines(i) <> "" Then '空白ではない行
                .Body = .Body & arrLines(i) & vbCrLf 'そのままタスクへコピー
            End If
        Next i

        '添付ファイルを一時フォルダに保存してから予定表に添付
        For Each objAttachment In objMail.Attachments
            Dim tempPath As String
            tempPath = Environ("TEMP") & "\" & objAttachment.FileName '一時フォルダのパス
            objAttachment.SaveAsFile tempPath '添付ファイルを一時フォルダに保存
            .Attachments.Add tempPath ' 一時フォルダに保存したファイルを予定表に添付
        Next objAttachment
        
        'タスクの編集画面を開く
        .Display
        .GetInspector.Activate
        
        'タスクの内容を保存
        .Save
    End With
    
    'メモリの解放
    Set objMail = Nothing
    Set objTask = Nothing
    
    ChangeFontInBody
End Sub

使い方は予定表のそれと全く同じ