選択したメールの添付ファイルを保存

Sub 添付ファイル一括保存()

Dim sl As Object, attachFile As Object

Dim app As New Outlook.Application

Dim exp As Outlook.Explorer

Dim sel As Outlook.Selection

Dim sh As Object, f As Object

Dim path As String

Dim checkExpath As String

Dim lVal As String

Dim fs As Object

Set fs = CreateObject("Scripting.FileSystemObject")

On Error GoTo ErrHandler

Set app = CreateObject("Outlook.Application")

Set exp = app.ActiveExplorer

Set sel = exp.Selection

''対象フォルダを指定する

Set sh = CreateObject("Shell.Application")

Set f = sh.BrowseForFolder(0, "保存先フォルダを選択", &H1, 0)

''フォルダ選択ダイアログでキャンセルされたら抜けます

If f Is Nothing Then GoTo NormalExit

''フォルダパスを指定

path = f.self.path

''添付ファイルを保存する

''試してみてわかったけど、画像なんかをOLE埋め込みしてるメールは

''画像ファイル名に「ファイルパスに使えない文字」入りで取得される

''だから画像埋め込みとかしてるものは保存時にエラーになります

'下記は、送信者名-添付ファイル名で保存する作業

For Each sl In sel

For Each attachFile In sl.Attachments

checkExpath = path & "" & sl.SenderName & "-" & attachFile.DisplayName

'すでに同名のファイルがないかをチェックします

If Not (fs.FileExists(checkExpath)) Then

attachFile.SaveAsFile checkExpath

'同名のファイルがあった場合"ファイル名-1""ファイル名-2"と合番をつけます

Else

cnt = 0

Do Until Not (fs.FileExists(checkExpath))

cnt = cnt + 1

lVal = Mid(attachFile.DisplayName, 1, InStrRev(attachFile.DisplayName, ".") - 1)

lVal = lVal & "_" & cnt & Mid(attachFile.DisplayName, InStrRev(attachFile.DisplayName, "."))

checkExpath = path & "" & sl.SenderName & "-" & lVal

Loop

attachFile.SaveAsFile checkExpath

End If

MsgBox "終了しました。", vbInfomation, "ファイル一括保存"

''おしまい

GoTo NormalExit

ErrHandler:

MsgBox "エラーが発生しました" & vbCrLf & Err.Description, vbExclamation, "ファイル一括保存"

NormalExit:

Set sl = Nothing

Set attachFile = Nothing

Set sel = Nothing

Set exp = Nothing

Set app = Nothing

End Sub