添付テスト
>||
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
Next
Next
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
<||