【VBA備忘録】受信したメールから添付ファイルを保存する（Outlook編）

Sub 添付ファイルを指定フォルダに保存する()

Dim path As String
Dim i As Integer
Dim objfld As Object, objbox As Object, mlitem As Object
Dim tdy As String, SaveDir As String, rctime As String, temp As String
Dim zumifld As Folder

'事前処理=============================================
'保存先フォルダがあるか確認
'今日の日付のフォルダーに保存します
tdy = Format(Date, "yyyymmdd") & "\"
SaveDir = "C:\Users\Shironeco" '←保存場所
path = SaveDir & "\" & tdy
'フォルダがなかったら作成
If Dir(path, vbDirectory) = "" Then
    MkDir path
End If

'各オブジェクトをセットする
'対象のメールが届くフォルダを指定します
Set objbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) '受信フォルダ
Set objfld = objbox.Folders.item("未処理フォルダ")
Set zumifld = objfld.Folders.item("処理済みフォルダ")
'======================================================


'未処理フォルダの中にあるメールをループして処理する
For i = objfld.Items.Count To 1 Step -1

    'メールを取得
    Set mlitem = objfld.Items(i)

    'メールの受信時間を取得
    '件名を取得したい場合はReceivedTime→Subject
    '受信時間を「yyyy-mm-dd-hhmmss」表示にする
    rctime = Format(mlitem.ReceivedTime, "yyyy-mm-dd-hhmmss")
    
    '添付ファイルの保存先（ファイル名はyyyy-mm-dd-hhmmss(元のファイル名))
    temp = path & rctime & mlitem.Attachments.item(1)
    
    '添付ファイルを保存する
    mlitem.Attachments.item(1).SaveAsFile temp
    
    '処理済みフォルダにメールを移動
    mlitem.Move zumifld

Next i

End Sub

MsgBox "処理が終わりました"
Shell "explorer " & temp, vbNormalFocus