複数の 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 の中に追加してください。

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

予定表の変更をメールで通知するマクロ

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


OutlookVBA初心者です。
お力添えを頂きたく初投稿させて頂きます。

予定表に関して以下イベントのハンドラを実装したいのですが、
どのようにしてイベントを検知すればよいかわかりません。

・予定表に新たにスケジュール登録された場合
・予定表に存在するスケジュールの件名や時間等のプロパティが変更された場合

上記タイミングを検知し、外部システムへ通知を送りたいと思っております。

コメント等頂けますと幸いです。

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


予定表フォルダーにアイテムが追加されたり、変更されたことを検出するには、フォルダーに含まれるアイテムの一覧である Items プロパティの ItemAdd イベントや ItemChange イベントが使用できます。
これらのイベントを受け取るには、マクロの先頭で Items プロパティのイベントを受け取るオブジェクトを WithEvents というキーワードをつけて宣言し、Application オブジェクトの Startup イベントで予定表の Items プロパティを格納しておく必要があります。
なお、ItemChange イベントには変更後のアイテムが引数として渡されますが、どのプロパティが変更されたかについては判断はできません。
マクロは以下のようになります。

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

Dim myCalendar As Folder
Dim WithEvents myCalendarItems As Items
' Outlook 起動時にイベント ハンドラーを設定する
Private Sub Application_Startup()
     Set myCalendar = Session.GetDefaultFolder(olFolderCalendar)
     Set myCalendarItems = myCalendar.Items
End Sub
' 予定表にアイテムが追加された時の処理
Private Sub myCalendarItems_ItemAdd(ByVal Item As Object)
     NotifyCalendarChange Item, "追加"
End Sub
' 予定表のアイテムが変更された時の処理
Private Sub myCalendarItems_ItemChange(ByVal Item As Object)
     NotifyCalendarChange Item, "変更"
End Sub
'
Private Sub NotifyCalendarChange(ByVal apptItem As AppointmentItem, strOp As String)
     ' 通知メールの送付先
     Const NOTIFY_TO = "notify@example.com"
     Dim mailNotify As MailItem
     ' 新規メールを作成
     Set mailNotify = CreateItem(olMailItem)
     With mailNotify
         ' メールの件名、本文、宛先を設定し、送信
         .Subject = "予定表アイテムの" & strOp & "通知"
         .Body = "以下の予定アイテムが" & strOp & "されました。" _
           & vbCrLf & "件名:" & apptItem.Subject _
           & vbCrLf & "開始日時:" & apptItem.Start _
           & vbCrLf & "終了日時:" & apptItem.End _
           & vbCrLf & "場所:" & apptItem.Location _
           & vbCrLf & "本文:" & vbCrLf & apptItem.Body
         .To = NOTIFY_TO
         .Send
     End With
End Sub

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

タスクを終了状態にし、Excel ファイルに件名と所有者を書き込むマクロ

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


いつも参考にさせていただいております。

現在outlook2010を使用しております。

特定の文字列から始まる件名のタスクを
実施済みにした際に
エクセルシートに①件名②タスク所有者の氏名
が転記されたいと考えております。

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


タスクを終了するタイミングでマクロを実行するのはちょっと難しいため、Excel に件名などを書き込み、タスクを終了状態とするマクロにしてみました。
以下のようなマクロで実現できます。

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

Public Sub CompleteWithLogtoExcel()
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\tasklist.xlsx"
     Dim tskItem As TaskItem
     Dim objBook
     Dim objSheet
     Dim r As Integer
     ' 現在表示されているアイテムを取得
     Set tskItem = ActiveInspector.CurrentItem
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.sheets(1)
     ' 1 行目はタイトルとして使用し、2 行目からデータ
     r = 2
     ' データがない行まで移動
     While objSheet.Cells(r, 1) <> ""
         r = r + 1
     Wend
     ' Excel にタスクの件名と所有者を転記
     objSheet.Cells(r, 1) = tskItem.Subject
     objSheet.Cells(r, 2) = tskItem.Owner
     ' タスクを完了状態にして保存
     tskItem.Complete = True
     tskItem.Save
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

特定のフォルダーのメールの添付ファイルを日付と送信者のフォルダーに保存するマクロ

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


コメント

いつも大変参考にさせていただいております

受信したメールの添付ファイルを自動作成した日付フォルダ/送信者フォルダへ保存&添付ファイルリストをExcel形式で出力同じフォルダ内の保存格納 するスクリプトを書いているのですがなにぶん勉強不足でうまくいきません。

加筆修正お願いできませんでしょうか。。日付フォルダを自動作成まではネットで調べてできたのですが、、、

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

<コード省略>


コメントでいただいたコードでほとんど完成していたのですが、以下の処理を追加しました。

  • 日付のフォルダーの下に送信者名のフォルダーを作成する。この時、送信者名にフォルダー名では使えない文字 (/、: など) が含まれていたら _ に置換する。
  • 同名のファイルが既に保存されていたら、ファイル名に連番をつけて別名で保存する。
  • Excel ファイルを保存後にクローズする。

追加後のマクロは以下のようになります。

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

Public Sub SaveAttachments4()
     Const ROOT_PATH = "C:\Users\username\Documents\outlook_temp"
     Dim objInbox As Object
     Dim objFolder As Object
     Dim strPath As String
     Dim i As Long
     '日付用定義
     Dim strDay As String
     'フォルダ名をyyyymmdd形式で入力
     strDay = Format(Date, "yyyymmdd")
     strDay = strDay & "\"
     'Excel用定義
     Dim myExcel 'As Excel.Application
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.worksheet
     Dim n As Long
     'Excelオブジェクト生成、ブックの追加
     Set myExcel = CreateObject("Excel.Application")
     Set objBook = myExcel.Workbooks.Add()
     Set objSheet = objBook.sheets(1)
     '項目目を追加
     objSheet.Cells(1, 1) = "ID"
     objSheet.Cells(1, 2) = "件名"
     objSheet.Cells(1, 3) = "送信者"
     objSheet.Cells(1, 4) = "受信日時"
     objSheet.Cells(1, 5) = "添付ファイル"
     objSheet.Cells(1, 6) = "添付ファイルのパス"
     '添付ファイルリストを書き込む行の位置
     n = 2
     Set objInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
     '添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(<フォルダ名>)」を追加してください。
     Set objFolder = objInbox.Folders.Item("1.サブフォルダ").Folders.Item("1-1.サブフォルダ")
     '添付ファイルの保存先をパスで指定※日付フォルダ追加
     strPath = ROOT_PATH & "\" & strDay
     '日付フォルダがなければ作成
     If Dir(strPath, vbDirectory) = "" Then
         MkDir strPath
     End If
     For Each objItem In objFolder.Items
         Dim strSubPath As String
         Dim strFileName As String
         ' 送信者名をパスに追加 (フォルダに使用できない文字は _ に置換)
         strSubPath = strPath & ReplaceSpecialChar(objItem.SenderName) & "\"
         For i = 1 To objItem.Attachments.Count
             '添付ファイルに拡張子がある場合のみ処理
             If InStr(objItem.Attachments.Item(i), ".") > 0 Then
                 ' 差出人名のフォルダがなければ作成
                 If Dir(strSubPath, vbDirectory) = "" Then
                     MkDir strSubPath
                 End If
                 ' すでに同名のファイルが存在したら連番を付与
                 strFileName = MakeFileName(strSubPath, objItem.Attachments.Item(i).FileName)
                 ' 添付ファイルを保存
                 objItem.Attachments.Item(i).SaveAsFile strSubPath & strFileName
                 'Excelへ添付ファイル情報を追加
                 objSheet.Cells(n, 1) = n - 1
                 objSheet.Cells(n, 2) = objItem.ConversationTopic '件名
                 objSheet.Cells(n, 3) = objItem.SenderName '送信者
                 objSheet.Cells(n, 4) = objItem.ReceivedTime '受信日時
                 objSheet.Cells(n, 5) = objItem.Attachments.Item(i) '添付ファイル
                 objSheet.Cells(n, 6) = strSubPath & strFileName '添付ファイルのパス”
                 n = n + 1
             End If
         Next i
     Next objItem
     '添付ファイル保存場所へExcelを保存
     objBook.SaveAs strPath & "添付リスト.xlsx"
     objBook.Close
     Set objItem = Nothing
     Set objInbox = Nothing
     Set objFolder = Nothing
     Set objSheet = Nothing
End Sub
'
' フォルダ名に使用できない文字を _ に置き換える関数
Private Function ReplaceSpecialChar(strText As String) As String
     ReplaceSpecialChar = ""
     For i = 1 To Len(strText)
         ch = Mid(strSubject, i, 1)
         If InStr("\/:*?""|", ch) > 0 Then
             ch = "_"
         End If
         ReplaceSpecialChar = ReplaceSpecialChar & ch
     Next
End Function
'
' ファイル名が重複した場合に連番を付与する関数
Private Function MakeFileName(strFolder As String, strOrgFileName As String)
     Dim strFileName As String
     Dim strBase As String
     Dim strExt As String
     Dim c As Integer
     strBase = Left(strOrgFileName, InStr(strOrgFileName, ".") - 1)
     strExt = Mid(strOrgFileName, InStr(strOrgFileName, "."))
     strFileName = strOrgFileName
     c = 1
     '
     While Dir(strFolder & strFileName) <> ""
         strFileName = strBase & c & strExt
         c = c + 1
     Wend
     MakeFileName = strFileName
End Function

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

指定した日付の決まった時間で定型の会議出席依頼を作成するマクロ

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


失礼致します。
有休休暇の会議案内(日にち:任意、時間AM6:00~AM6:30、宛先メンバー:固定)
をVBAでやりたいのですがどのようなマクロになりますでしょうか。
ご教授お願い致します。


日にちが任意とのことなので、日付を指定するとその日の決まった時間で会議出席依頼を作成するというマクロを想定しました。
日付の指定方法としてはダイアログで入力するというものと、予定表で選択するものが考えられたので、両方を実装してみました。
ダイアログで入力するには InputBox 関数を使用します。
予定表で選択された日付を取得するには ActiveExplorer の CurrentView の SelectedStartTime を使用します。
作成した予定を確認してから送信できるように、最後は AppointmentItem オブジェクトの Display メソッドでアイテムの表示を行っていますが、確認せずにすぐに送信したいのであれば Display メソッドの代わりに Send メソッドで送信するよう変更が必要です。
マクロは以下のようになります。
ダイアログで日付を入力する場合は CreateFixedMeetingByInputBox を、予定表で選択した日付で作成する場合は CreateFixedMeetingBySelect を実行してください。

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

' ダイアログから入力した日付に会議を作成するマクロ
Public Sub CreateFixedMeetingByInputBox()
     Dim strDate As String
     ' ダイアログで日付を取得
     strDate = InputBox("日付:")
     ' 取得した日付を指定して会議を作成
     CreateFixedMeeting strDate
End Sub
' 予定表で指定した日に会議を作成するマクロ
Public Sub CreateFixedMeetingBySelect()
     Dim calView As CalendarView
     Dim strDate As String
     ' 表示中のビューの種類が [日/週/月] の場合のみ実行
     If TypeName(ActiveExplorer.CurrentView) = "CalendarView" Then
         Set calView = ActiveExplorer.CurrentView
         ' ビューで選択している開始範囲の日付のみ取得
         strDate = FormatDateTime(calView.SelectedStartTime, vbShortDate)
         ' 取得した日付を指定して会議を作成
         CreateFixedMeeting strDate
     End If
End Sub
' パラメータで指定した日の特定の時間に会議を作成するサブ プロシージャ
Private Sub CreateFixedMeeting(strDate As String)
     ' 開始時刻を指定
     Const START_TIME = "6:00"
     ' 終了時刻を指定
     Const END_TIME = "6:30"
     ' 出席者を指定
     Const MEET_ATTENDEES = "user1@example.com;user2@example.com"
     ' 会議開催通知の件名を指定
     Const MEET_SUBJECT = "有給休暇"
     ' 会議開催通知の本文を指定
     Const MEET_BODY = "有給休暇の会議を行います"
     Dim apptMeet As AppointmentItem
     ' 新規予定を作成
     Set apptMeet = CreateItem(olAppointmentItem)
     With apptMeet
         ' 件名を設定
         .Subject = MEET_SUBJECT
         ' 本文を設定
         .Body = MEET_BODY
         ' 出席者を設定
         .RequiredAttendees = MEET_ATTENDEES
         ' 開始日時を設定
         .Start = strDate & " " & START_TIME
         ' 終了日時を設定
         .End = strDate & " " & END_TIME
         ' 予定を会議に変更
         .MeetingStatus = olMeeting
         ' 作成した会議を確認して送信したい場合は以下を使用
         .Display
         ' 作成した会議を直ちに送信する場合は以下を使用
         '.Send
     End With
End Sub

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

指定した日付以降に更新された送受信メールや連絡先を PST にエクスポート/インポートするマクロ

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


いつも参考にさせて頂き、
要望にも対応頂きありがとうございます

Outlook365
Windows10(64bit)

2台の端末で1つのアカウントでログイン(設定)し
1週間の内、端末Aと端末Bを使用します。

例えば、月曜に端末Aで送受信等ををし、
残りの火曜~金曜は端末Bで送受信等とする場合

送受信メール、連絡先(追加などした場合)の
各データを同期させたいのです。
過去の相当古いデータも残しておきたいため
IMAP等では無理だと判断しています。

単純にデータ(pst)のエクスポートとインポートを
日時指定(作成日時、更新日時)で対応しようと考えています。
マクロ作成可能でしょうか?

日時指定(作成日時、更新日時)はダイアログで指定ができると有難いです。

メールの受信トレイ(階層1として)や送信トレイの下層に
サブフォルダを階層3迄で作成しています。
送受信後、返信や解答があったものは手動で移動しています。

サブフォルダを追加した場合もそのフォルダ等も
エクスポートとインポートの対象になりますよね?

よろしくお願いします。

—-

お返事ありがとうございます。

>Outlook のインポート、エクスポートの機能をマクロで呼び出すことはできないため、マクロ
>ですべて実装する必要があります。
≫≫
以前CSVのエクスポートするマクロを参考にさせて頂きましたが
単純にデータ(pst)のエクスポートとインポートを
日時指定(作成日時、更新日時)で対応はできないでしょうか?

>インポート先に同じアイテムがあった場合に単純な上書きとするのかや、
>そもそも同じアイテムと判断する基準はどうするかなどを考慮する必要があります。
≫≫
手動でデータ(pst)のエクスポートとインポートの時の
ダイアログの条件(下記3種)
・重複した場合、インポートするアイテムと置き換える(E)
・重複してもインポートする(A)
・重複したらインポートしない(D)

このうちの
・重複してもインポートする(A)で良いと考えています。

Outlook 365 を使われているというのは、Office 365 の Outlook を使われているということなのでしょうか?
≫≫
はいそうです。
MicrosoftR OutlookR for Office 365 MSO (16.0.12228.20100) 32 ビット  です。

その場合、サーバーは Exchange を使用しているはずで、連絡先などの情報もメールボックスに保存されているので、PST で同期する必要はないはずです。
≫≫
アプリ自体はOffice 365 の Outlookですが
エクスポートしたいアカウント(主にメール)の種類は
POP/SMTP(送信で使用する既定のアカウント)となっています。
もうひとつ 予定表の管理用として
利用している@outlook.comのアカウントは 種類はMicrosoft Exchangeとなっています。


アイテムのエクスポートやインポートの際に「重複してもインポートする」で構わないということであれば、単純にフォルダーのアイテムをコピーするというようなマクロとなります。
ただし、サブ フォルダーもコピーするとなると、エクスポート先にそのフォルダーがないという可能性もあるため、フォルダーがなければ作成するというロジックが必要になります。
また、日付の指定については InputBox で入力を行い、その日付でフィルターを作成して Items コレクションの Restrict メソッドにより日付の絞り込みを行います。
マクロは以下の通りになります。
なお、エクスポート、インポートする PST ファイルはあらかじめプロファイルに追加して置き、その名前を GetPSTRoot 内の PST_NAME で指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' PST にエクスポートするプロシージャ
Public Sub ExportToPST()
     Dim fldSrc As Folder
     Dim fldDst As Folder
     Dim strFilter As String
     ' コピー元はメールボックス
     Set fldSrc = Session.DefaultStore.GetRootFolder
     ' コピー先は PST
     Set fldDst = GetPSTRoot()
     If fldDst Is Nothing Then Exit Sub
     ' フィルターを初期化
     strFilter = ""
     ' コピー処理をフォルダーごとに呼び出し
     CopyItems fldSrc, fldDst, "受信トレイ", strFilter
     CopyItems fldSrc, fldDst, "送信トレイ", strFilter
     CopyItems fldSrc, fldDst, "送信済みアイテム", strFilter
     CopyItems fldSrc, fldDst, "下書き", strFilter
     CopyItems fldSrc, fldDst, "連絡先", strFilter
End Sub
'
' PST からインポートするプロシージャ
Public Sub ImportFromPST()
     Dim fldSrc As Folder
     Dim fldDst As Folder
     Dim strFilter As String
     ' コピー元は PST
     Set fldSrc = GetPSTRoot()
     ' コピー先はメールボックス
     Set fldDst = Session.DefaultStore.GetRootFolder
     If fldDst Is Nothing Then Exit Sub
     ' フィルターを初期化
     strFilter = ""
     ' コピー処理をフォルダーごとに呼び出し
     CopyItems fldSrc, fldDst, "受信トレイ", strFilter
     CopyItems fldSrc, fldDst, "送信トレイ", strFilter
     CopyItems fldSrc, fldDst, "送信済みアイテム", strFilter
     CopyItems fldSrc, fldDst, "下書き", strFilter
     CopyItems fldSrc, fldDst, "連絡先", strFilter
End Sub
'
' PST のルートフォルダーを取得する関数
Private Function GetPSTRoot() As Folder
     Const PST_NAME = "個人用 Outlook データ ファイル"
     Dim fldRoot As Folder
     ' プロファイル
     For Each fldRoot In Session.Folders
         If fldRoot.Name = PST_NAME Then
             Set GetPSTRoot = fldRoot
             Exit Function
         End If
     Next
     MsgBox PST_NAME & "が見つかりません。", vbCritical
     Set GetPSTRoot = Nothing
End Function
'
' フォルダごとにアイテムをコピーするプロシージャ
Private Sub CopyItems(fldSrcRoot As Folder, fldDstRoot As Folder, strName As String, strFilter As String)
     On Error Resume Next
     Const PR_ATTR_HIDDEN = "http:" & "//schemas.microsoft.com/mapi/proptag/0x10F4000B"
     Dim fldSrc As Folder
     Dim dfType As OlDefaultFolders
     Dim fldDst As Folder
     Dim colItems As Items
     Dim objItem As Object
     Dim objCopy As Object
     Dim fldSub As Folder
     ' フィルターが設定されていなければ基準日を入力してフィルターを作成
     If strFilter = "" Then
         Dim strDate As String
         strDate = FormatDateTime(CDate(InputBox("基準日")), vbShortDate)
         ' 更新日時が基準日以降であるアイテムを取得するフィルター
         strFilter = "[更新日時] >= '" & strDate & "'"
         ' 作成日時が基準日以降であるアイテムを取得する場合は以下のフィルターを使用
         'strFilter = "[作成日時] >= '" & strDate & "'"
     End If
     ' コピー元フォルダーの取得
     Set fldSrc = fldSrcRoot.Folders(strName)
     ' コピー元フォルダーが隠しフォルダーならコピーせず終了
     If fldSrc.PropertyAccessor.GetProperty(PR_ATTR_HIDDEN) = True Then
         Exit Sub
     End If
     ' コピー先フォルダーの取得
     Set fldDst = fldDstRoot.Folders(strName)
     ' コピー先フォルダーが見つからなければ作成
     If fldDst Is Nothing Then
         ' フォルダーに格納されるアイテムの種別からフォルダー種別を設定
         dfType = GetFolderType(fldSrc)
         ' 新規にフォルダーを作成
         Set fldDst = fldDstRoot.Folders.Add(strName, dfType)
     End If
     ' フィルターによりアイテムを抽出
     Set colItems = fldSrc.Items.Restrict(strFilter)
     ' 抽出したアイテムのすべてについて処理
     For Each objItem In colItems
         ' アイテムのコピーを作成
         Set objCopy = objItem.Copy
         ' アイテムのコピーをコピー先フォルダーに移動
         objCopy.Move fldDst
     Next
     ' サブフォルダーについてもコピー処理
     For Each fldSub In fldSrc.Folders
         CopyItems fldSrc, fldDst, fldSub.Name, strFilter
     Next
End Sub
'
' フォルダーに保存するアイテム種別をもとにフォルダー種別を返す関数
Private Function GetFolderType(fldToCheck As Folder) As OlDefaultFolders
     Select Case fldToCheck.DefaultItemType
         Case olMailItem
             GetFolderType = olFolderInbox
         Case olAppointmentItem
             GetFolderType = olFolderCalendar
         Case olContactItem
             GetFolderType = olFolderContacts
         Case olTaskItem
             GetFolderType = olFolderTasks
         Case Else
             GetFolderType = olFolderInbox
     End Select
End Function

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

受信したメールの件名でフォルダーをデスクトップ上に作成し、添付ファイルを保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


お世話になっております。

自動保存マクロを利用させていただいており、たいへん助かっております。

質問なのですが、メールの件名のフォルダをデスクトップ上に作成し添付の保存をメール毎繰り返す。ということは可能でしょうか?
もし可能であればご教示頂けたらと思います。
よろしくお願い致します


デスクトップのフォルダー名を取得するには Environ 関数で取得した USERPROFILE という環境変数の値に \Desktop を追加します。
その下にメールの件名のフォルダーを作成する際に、件名には \ や :、* などファイル名に使用できない文字が含まれる場合があるため、それを別の文字に置き換える必要があります。
あとは受信したメールの添付ファイルの自動保存のマクロとほぼ同様ですが、件名は比較的長いものになる場合があるため、ファイルのパスの長さの制限を超えないようなロジックを加えてあります。
マクロは以下のようになります。

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

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim i As Integer
    Dim c As Integer
    Dim colID As Variant
    '
     SaveAttachments EntryIDCollection
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachments(ByVal strEntryID As String)
    Const MAX_FOLDER_PATH = 130
    Const MAX_PATH = 260
    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")
    Set objMsg = Application.Session.GetItemFromID(strEntryID)
    ' デスクトップの下にフォルダーを作成
    strSaveRoot = Environ("USERPROFILE") & "\Desktop\"
'
' ここで条件指定
'
    ' 添付ファイルがなければ終了
    If objMsg.Attachments.Count = 0 Then
        Exit Sub
    End If
    ' 件名から保存するフォルダーのパスを生成
    strSaveFolder = strSaveRoot & 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

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