Excel のデータをもとに代理で会議出席依頼を送信するマクロ

Excel のデータをもと会議出席依頼を送信するマクロのコメントにて以下のご要望をいただきました。


会議案内の差出人を変更したいのですがどのようなマクロにすればよいでしょうか?
(秘書が上司に代わって会議を設定する場合に使用したいのです)
SentOnBehalfOfNameは普通のメールでは動くのですが会議アイテムではうまくいきませんでした。
SendUsingAccountはよくわかりませんでした。


Outlook の会議出席依頼は、予定表にある予定アイテムを基にして生成されるもので、会議出席依頼を単独で生成することはできません。
そして、会議出席依頼の差出人はその予定の開催者でもあり、元になる予定アイテムが格納されている予定表のメールボックスのユーザーが開催者となります。
(自分の予定表に自分で作成したアイテムの開催者を他人に変更することはできません。)
したがって、会議出席依頼を代理人が送信する場合、本人の予定表に予定アイテムを作成し、そのアイテムから会議出席依頼を生成する必要があります。

他のユーザーの予定表に予定アイテムを作成するには、その予定表への書き込み権限が必要となりますので、まずは上司の予定表への書き込み権限を秘書に与える必要があります。
そのうえで、秘書が実行するマクロでは Namespace オブジェクトの GetSharedDefaultFolder メソッドにより上司の予定表フォルダーを取得します。
そして、取得した Folder オブジェクトの Items プロパティの Add メソッドで予定アイテムを追加し、必要なプロパティを設定して MeetingStatus に 1 (olMeeting) を設定すると会議出席依頼として送信可能となります。

Excel のデータをもと会議出席依頼を送信するマクロの Excel ファイルの左端に 1 列追加し、そこに開催者を追加した場合に、選択した行の情報をもとに会議出席依頼を作成するマクロは以下のようになります。

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

Public Sub SendMeetingRequestAsOthers()
     Const MEMBER_MAX = 3 ' メンバーの数
     Dim olkApp 'As Outlook.Application
     Dim strOrganizer As String
     Dim recOrganizer 'As Outlook.Recipient
     Dim fldCalendar 'As Outlook.Folder
     Dim objAppt 'As Outlook.AppointmentItem
     Dim r As Integer
     Dim i As Integer
     ' 会議出席依頼のもとになる予定アイテムを作成
     Set olkApp = CreateObject("Outlook.Application")
     ' 選択されている行番号を取得
     r = Application.ActiveCell.Row
     ' 1 列目の開催者を取得
     strOrganizer = Cells(r, 1)
     ' 開催者の名前解決を実施
     Set recOrganizer = olkApp.Session.CreateRecipient(strOrganizer)
     recOrganizer.Resolve
     ' 開催者の予定表フォルダーを取得
     Set fldCalendar = olkApp.Session.GetSharedDefaultFolder(recOrganizer, 9) ' olFolderCalendar
     ' 取得した予定表フォルダーに予定アイテムを追加
     Set objAppt = fldCalendar.Items.Add
     ' 予定に必要なプロパティを設定
     objAppt.Start = CDate(Cells(r, 2) & " " & CDate(Cells(r, 3)))
     objAppt.End = CDate(Cells(r, 2) & " " & CDate(Cells(r, 4)))
     objAppt.Subject = Cells(r, 5)
     objAppt.Location = Cells(r, 6)
     ' 予定の日時や件名、場所を設定
     objAppt.MeetingStatus = 1 ' olMeeting
     ' セルの値が空白以外のユーザーを出席者に追加
     For i = 1 To MEMBER_MAX
         If Cells(r, 6 + i) <> "" Then
             objAppt.Recipients.Add Cells(2, 6 + i)
         End If
     Next
     ' 会議出席依頼を表示し、送信
     objAppt.Recipients.ResolveAll
     objAppt.Display
     objAppt.Send ' 環境によっては実行時エラーとなるため、その場合は削除して手動で送信
End Sub

表示中のメールの添付ファイルを件名のフォルダーに保存するマクロ

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


ボタンを押すと、任意のメールについている添付ファイルを、フォルダ名がメールの件名のフォルダを新規作成して保存するマクロはどのようにすれば良いでしょうか。


ご要望のマクロは受信したメールの件名でフォルダーをデスクトップ上に作成し、添付ファイルを保存するマクロをベースにして作成できます。
変更点としては、以下のようなものがあります。

  • 受信メールではなく現在表示しているメールを取得する
  • 保存先フォルダーの親フォルダーをデスクトップ上ではなく任意のフォルダーとする

このマクロをリボンやクイックアクセスツールバーに登録すれば、ボタンを押すだけで添付ファイルの保存ができるようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub SaveAttachmentsInSubjectFolder()
     Const MAX_FOLDER_PATH = 130
     Const MAX_PATH = 260
     Const ROOT_PATH = "c:\attachments\"
     Dim strSaveRoot As String
     Dim strSaveFolder As String
     Dim objFSO As Object ' FileSystemObject
     Dim objMsg As Object
     Dim objAttach As Attachment
     Dim strFileBase As String
     Dim strExt As String
     Dim strFileName As String
     Dim c As Integer: c = 1
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     ' 表示中のアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objMsg = ActiveInspector.CurrentItem
     Else
         Set objMsg = ActiveExplorer.Selection(1)
     End If
     Set objMsg = Application.Session.GetItemFromID(strEntryID)
     ' 添付ファイルがなければ終了
     If objMsg.Attachments.Count = 0 Then
         Exit Sub
     End If
     ' 件名から保存するフォルダーのパスを生成
     strSaveFolder = ROOT_PATH & ReplaceSpecialChar(objMsg.Subject)
     strSaveFolder = Left(strSaveFolder, MAX_FOLDER_PATH)
     ' フォルダーが存在しなければ作成
     If Not objFSO.FolderExists(strSaveFolder) Then
         objFSO.CreateFolder strSaveFolder
     End If
     '
     For Each objAttach In objMsg.Attachments
         With objAttach
             If InStr(.FileName, ".") > 0 Then
                 ' ファイル名と拡張子を分離
                 strFileBase = strSaveFolder & "\" & Left(.FileName, InStrRev(.FileName, ".") - 1)
                 strExt = Mid(.FileName, InStrRev(.FileName, "."))
             Else
                 strFileBase = strSaveFolder & "\" & .FileName
                 strExt = ""
             End If
             strFileBase = Left(strFileBase, MAX_PATH - Len(strExt) - 4)
             '
             strFileName = strFileBase & strExt
             While objFSO.FileExists(strFileName)
                 strFileName = strFileBase & "-" & c & strExt
                 c = c + 1
             Wend
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub
' 件名から特殊文字を取り除く関数
Private Function ReplaceSpecialChar(strSubject As String) As String
     ReplaceSpecialChar = ""
     For i = 1 To Len(strSubject)
         ch = Mid(strSubject, i, 1)
         If InStr("\/:*?""|", ch) > 0 Then
             ch = "_"
         End If
         ReplaceSpecialChar = ReplaceSpecialChar & ch
     Next
End Function

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

Outlook のマクロから Excel のマクロを呼び出す方法

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


コメント

始めまして。こちらのサイトで勉強させていただいております。
VBA初心者で浅学で誠に申し訳ございませんが、お力添え頂けないでしょうか。
(環境:Win10/Outlook2013)

<実現したいこと>
・特定サブフォルダに見積メールが新規格納されたら、管理簿登録するExcelマクロを実行する。
・管理簿登録時の引数は、メール本文に記載の案件名とする。

<エラー箇所>
・Outlookマクロ→Excelマクロの呼び出し方法が分かりません。
※「特定サブフォルダに見積メールが新規格納されたら」の部分は過去質問を基に作成予定です。

===エラーになったマクロ===
Sub 呼び出し()
Dim BookName As String
BookName = “C:\test.xlsm”
Application.Run “‘” & BookName & “‘” & “!見積マクロ”
End Sub
================


上記のコードでは Application.Run を使用されていますが、Application というのはそのマクロを実行しているプログラムを指します。
そのため、Excel 上でこのマクロを実行した場合は Excel の Application オブジェクトとなり Run メソッドが使用できますが、Outlook 上で実行すると Outlook の Application オブジェクトとなり、Outlook には Run メソッドが実装されていないのでエラーとなります。
Outlook のマクロで Excel のマクロを呼び出すには、CreateObject  で “Excel.Application” を引数として取得した Excel の Application オブジェクトの Run メソッドを実行します。
上記のコードを Outlook で実行するには以下のようなものとなります。

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

Sub 呼び出し()
     Dim BookName As String
     Dim appExcel As Object
     BookName = "C:\test.xlsm"
     '
     Set appExcel = CreateObject("Excel.Application")
     appExcel.Run "'" & BookName & "'" & "!見積マクロ"
End Sub

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

受信したメールのパスワードを Excel ファイルに書き出すマクロ

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


Outlookマクロについて質問です。
メール本文から特定文字以降を抽出したいです。
Outlook2016です。

★条件
・新規メールを受信後、件名に”パスワード”とあったら実行

★やりたいこと
  ・下記を指定Excel(C:\test\PW.xlsx)に書き出し
  ・件名をA2以降に書き出し(空白行の最終行)
・本文内の【パスワード】後に改行してあるパスワードをA3以降に書き出し(空白行の最終行)

★例
******* このようなメールを受信 *******
〈件名〉
パスワード送信
  〈メール本文〉
お疲れ様です。
  ~
  【パスワード】
ABC123

******* 指定Excel *******
  (A2)       (A3)
パスワード送信  ABC123

以上、お力を貸していただきたいです。
  少し急ぎ目だと助かります。
よろしくお願いいたします(@_@)


受信時に実行される処理は Application_NewMailEx イベントで処理します。
本文からパスワードの文字列を抽出するという処理は、Body プロパティで取得した本文の文字列に対して InStr 関数や Mid 関数など一般的な VBA の文字列関数を使用することで実現できます。
また、Excel ファイルへの書き込みは Excel のオブジェクト モデルを使用して実装できます。
マクロは以下のようになります。

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

' 受信時に実行されるイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem As Object
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    ' アイテムがメール アイテムかどうかをチェック
    If objItem.MessageClass = "IPM.Note" Then
        Dim objMail As MailItem
        Set objMail = objItem
        ' 件名に "パスワード" が含まれるかをチェック
        If InStr(objMail.Subject, "パスワード") > 0 Then
            ' パスワードを含む場合は Excel に保存する
            SavePassword objMail
        End If
    End If
End Sub
'
' Excel ファイルに本文から取得したパスワードを保存するプロシージャ
'
Public Sub SavePassword(ByRef objMail As MailItem)
    ' Excel ファイルのファイル名を指定
    Const EXCEL_FILE = "c:\test\PW.xlsx"
    Const KEYWORD = "【パスワード】"
    Dim strBody As String
    Dim iPtr As Integer
    Dim strPassword As String
    Dim objBook
    Dim objSheet
    Dim r As Integer
    ' 本文を取得
    strBody = objMail.Body
    ' 本文にパスワードを示すキーワードが含まれるか確認
    iPtr = InStr(strBody, KEYWORD)
    ' パスワードのキーワードがなかったら終了
    If iPtr = 0 Then Exit Sub
    ' キーワードに後の改行を検索
    iPtr = InStr(iPtr, strBody, vbCrLf)
    ' キーワードの後に改行がなかったら終了
    If iPtr = 0 Then Exit Sub
    ' パスワードの前の改行やスペースをスキップ
    iPtr = iPtr + 2
    While InStr(" " & vbCrLf, Mid(strBody, iPtr, 1)) > 0 _
        And iPtr < Len(strBody)
        iPtr = iPtr + 1
    Wend
    ' パスワード以降の文字列を取得
    strBody = Mid(strBody, iPtr)
    ' パスワードの後の改行を検索
    iPtr = InStr(strBody, vbCrLf)
    ' パスワードの後に改行がなかったら終了
    If iPtr = 0 Then Exit Sub
    ' パスワードを取得
    strPassword = Left(strBody, iPtr - 1)
    ' Excel ファイルを開く
    Set objBook = GetObject(EXCEL_FILE)
    objBook.Windows(1).Activate
    Set objSheet = objBook.sheets(1)
    ' 1 行目はタイトルとして使用し、2 行目からデータ
    r = 2
    ' データがない行まで移動
    While objSheet.cells(r, 2) <> ""
        r = r + 1
    Wend
    ' 件名とパスワードを Excel のシートに転記
    objSheet.cells(r, 2) = objMail.Subject
    objSheet.cells(r, 3) = strPassword
    ' Excel ファイルを保存して閉じる
    objBook.Close True
End Sub

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

返信や転送の際のインデント記号の挿入時に連続する改行のみの行を削除するマクロ

Outlook 2010 以降で返信や転送の際の自動折り返しを行わずにインデント記号を挿入するマクロのコメントにて以下のご要望をいただきました。


いつも大変お世話になっております。

こちらの、マクロを活用させていただいております。

こちらのマクロに、不要な空白行を削除したうえで、インデント記号を追加する機能を追加するにはどうすればよいでしょうか。

可能であれば、
空白行が複数連続する場合は、一行へまとめる。
前文の末尾がに、「、」「,」句点があるばあいは空白行を削除し、詰めてしまう。
ようにしたいです。

※当方は、本文にはリッチテキストを用いず、テキスト設定で使用しているのですが、最近の時流でリッチテキストを使うユーザが増え、テキスト化の時点で不要な空白行が生成され、見苦しい引用本文となり困っています。

ご対応、ご教示いただければ、幸甚です。


空白行が 2 行ある場合には Replace 関数で 3 連続の改行 (vbCrLf & VbCrLf & vbCrLf) を検索し、2 連続の改行 (vbCrLf & vbCrLf) に置き換えることで空白行を 1 行にできます。
ただ、3 行以上の連続する空白行を置き換えるとなると、上記の処理を 3 連続の改行がなくなるまで繰り返すという処理が必要になります。
また、文末に「、」や「,」がある場合に改行を削除する場合も同様です。
マクロは以下のようになります。

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

'
'   インデント記号を付けて返信するマクロ
Public Sub ReplyWithTickMark()
     Dim objMail As MailItem
     Dim objReply As MailItem
     ' アイテムを取得
     Set objMail = GetCurrentItem()
     ' 返信を作成
     Set objReply = objMail.ReplyAll
     ' インデント記号を本文に追加
     AddTickMark objReply
End Sub
'
'   インデント記号を付けて転送するマクロ
Public Sub ForwardWithTickMark()
     Dim objMail As MailItem
     Dim objForward As MailItem
     ' アイテムを取得
     Set objMail = GetCurrentItem()
     ' 転送を作成
     Set objForward = objMail.Forward
     ' インデント記号を本文に追加
     AddTickMark objForward
End Sub
'
'   アクティブなウィンドウに応じて選択しているアイテムを取得するマクロ
Private Function GetCurrentItem()
     If TypeName(ActiveWindow) = "Inspector" Then
         Set GetCurrentItem = ActiveInspector.CurrentItem
     Else
         Set GetCurrentItem = ActiveExplorer.Selection(1)
     End If
End Function
'
'   インデント記号を追加するマクロ
Private Sub AddTickMark(objMail As MailItem)
     ' インデント記号の指定
     Const TICK_MARK = "> "
     '
     Dim iStart As Integer
     Dim strNewBody As String
     Dim strBody As String
     ' 引用部分の先頭を取得
     iStart = InStr(objMail.Body, "-----Original Message-----")
     ' 引用部分が存在する場合
     If iStart > 3 Then
         strBody = objMail.Body
         ' 引用部分より前はそのままコピー
         strNewBody = Left(strBody, iStart - 2)
         ' 引用部分の置き換え
         strBody = Mid(strBody, iStart - 2)
         ' スペース 1 文字のみの行は空行に変換
         strBody = Replace(strBody, vbCrLf & " " & vbCrLf, vbCrLf & vbCrLf)
         ' 連続する空行は一つの空行に変換
         strBody = ReplaceLoop(strBody, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
         ' 行末が読点なら改行を削除
         strBody = ReplaceLoop(strBody, "、" & vbCrLf, "、")
         strBody = ReplaceLoop(strBody, "," & vbCrLf, ",")
         ' 引用部分は改行の後にインデント記号を追加
         strNewBody = strNewBody & Replace(strBody, vbCrLf, vbCrLf & TICK_MARK)
         ' インデント記号を追加した本文を設定
         objMail.Body = strNewBody
     End If
     ' アイテムを表示
     objMail.Display
End Sub
'
' 検索文字列がなくなるまで置換を繰り返す関数
Private Function ReplaceLoop(strText As String, strFind As String, strReplace As String)
     While InStr(strText, strFind) > 0
         strText = Replace(strText, strFind, strReplace)
     Wend
     ReplaceLoop = strText
End Function

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

複数の NewMailEx のマクロを統合する方法

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


つい先日よりOutlookを使用し始めて、こちらにお邪魔して勉強させて頂いております。
(環境:WIN10, Office365)
さて、「名前が適切ではありません」のコンパイルエラーで困っております。
マクロは例の「豆腐メール」受信後の削除、及びメール受信後の添付エクセルファイルを
デスクトップへ保存する の2種類のマクロを上下並べて記述させましたところ、
上述のエラーが出ております。
具体的には、Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
のところが、2種類のマクロ故に2重になっていることでのエラーだと思いますが、その回避方法を
ご教示お願いしたいと存じます。いろいろ試しましたが、初心者故に対応が不明です。
(豆腐メール用マクロは、サブプロシージャがなく、もう一方はそれがあることで、混乱しているのかも知れません) どうぞよろしくお願い致します。


メール受信時のマクロについては Application_NewMailEx というサブ プロシージャで記述しますが、VBA では同じ名前のサブ プロシージャを複数登録することはできません。
そのため、それぞれの Application_NewMailEx という名前を別のものに変更し、Application_NewMailEx では変更した名前のサブ プロシージャを呼び出す必要があります。

例えば、「件名、本文、差出人が空白のメールを受信時に削除するマクロ」の Application_NewMailEx を Application_NewMailExForBlankMail と変更する場合、以下のような記述をします。
元のサブ プロシージャでは Application_NewMailEx 自身を呼び出しているので、そちらの名前も変更する必要がある点に注意してください。

Private Sub Application_NewMailExForBlankMail(ByVal EntryIDCollection As String)
    Dim objMsg
    If Instr(EntryIDCollection,",") = 0 Then
        Set objMsg = Session.GetItemFromID(EntryIDCollection)
        If objMsg.Subject = "" And objMsg.Body = "" And objMsg.SenderName = "" Then
            objMsg.Unread = False ' 既読にする
            objMsg.Delete ' 削除する
        End If
    Else
        Dim strIDs
        Dim i
        strIDs = Split(EntryIDCollection, ",")
        For i = LBound(strIDs) To UBound(strIDs)
            Application_NewMailExForBlankMail strIDs(i)
        Next
    End If
End Sub

同様に、メール受信後の添付エクセルファイルをデスクトップへ保存するマクロの Application_NewMailEx  も Application_NewMailExForSaveToDesktop に変更した場合、Application_NewMailEx 自体は以下のように記述します。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Application_NewMailExForBlankMail EntryIDCollection
    Application_NewMailExForSaveToDesktop EntryIDCollection
End Sub

もしほかにも追加したい受信時のマクロがある場合は、そちらについても名前を変更して Application_NewMailEx の中に追加してください。

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