VB初心者です。メールから添付ファイルを取り出したいです。

Outlookメール（.msg）から添付ファイルのみ取り出すコーディングをサンプルなどで教えてほしいです。
Outlookから「：C￥メール」にmsgファイルを手動で移し、そこからVBにて「：C￥添付ファイル」に添付ファイルのみを取り出したいです。

No.7 ベストアンサー 回答者： WindFaller 回答日時： 2016/05/12 19:45

>できましたー！

>ありがとうございます。

それはよかったです。今回は、まさかの、そのまさかでした。
やっと来ましたね。ほっとしています。

>一点だけ、添付ファイルが画像データとPDFの二種類あるのですが、PDFのみ抜き出しとかできますか？

最後の行から遡って、'** でつけたように、If ～　End If で挟みます。
今は、pdf ファイルのみというスタイルになっています。
画像データとpdf 2つ以上がある時に、pdf ファイルのみという方法ですと、少し複雑になります。

Sub SaveEachItem()
・
・

　For Each att In AttachedItems
　　　　With att
　　　　　　If StrConv(.FileName, vbLowerCase) Like "*.pdf" Then　'**
　　　　　　.SaveAsFile strAttPath & "\" & .FileName
　　　　　　End If　　　　 '**
　　　　End With
　　Next
　　Beep
EndLine:
　　Set objFS = Nothing
　　Set AttachedItems = Nothing
End Sub

この回答へのお礼

すごいできました！
本当にありがとうございました！！！

お礼日時：2016/05/13 09:37

No.6 回答者： WindFaller 回答日時： 2016/05/12 10:05

>つぎはSet objItem = objOL.Selection(1)のところで

>「配列のインデックスが範囲にありません」とでてきました。
原因は、メールを一つも選択されていないということしか思い浮かびません。それは、想定されていませんでした。また反対に、複数のメールの切り出しも考えてはいませんが、それについては、変更は可能です。また、今のマクロを分割していくという形にはなります。

-> If objOL.Selection.

Set objOL = Outlook.ActiveExplorer

If objOL.Selection.Count < 1 Then MsgBox "メールを選択されていない模様です", vbExclamation: Exit Sub　　'一行挿入

Set objItem = objOL.Selection(1)　'エラーの出た箇所の手前の行↑
sTitle = Trim(objItem.ConversationTopic)
fName = Left(strMailPath & sTitle, 250) & ".msg" '254文字まで

これでどうでしょうか。

この回答へのお礼

できましたー！
ありがとうございます。
一点だけ、添付ファイルが画像データとPDFの二種類あるのですが、PDFのみ抜き出しとかできますか？

お礼日時：2016/05/12 18:39

No.5 回答者： WindFaller 回答日時： 2016/05/11 16:27

前回のコードの全面的に上書きをしてみてください。

確かに、SaveAs のエラーは、理にかなっています。そのまま件名(subject:)をファイル名にするのは無理がありました。
ファイル名の規則にしたがつて、チェックカー（ユーザー定義関数）をつけることにしました。


'//--
Sub SaveEachItem()
　　'OutLook メールを切り出すマクロ
　　Dim objFS As Object: Set objFS = CreateObject("Scripting.FileSystemObject")
　　'メール本体の格納フォルダ
　　Dim strMailPath: strMailPath = "C:\Temp\Mail"
　　If Right(strMailPath, 1) <> "\" Then strMailPath = strMailPath & "\"
　　'添付ファイルの格納フォルダ
　　Dim strAttPath: strAttPath = "C:\Temp\AttachedFiles"
　　If Right(strAttPath, 1) <> "\" Then strAttPath = strAttPath & "\"
　　'フォルダチェック
　　If objFS.FolderExists(strMailPath) = False Then
　　　　MsgBox strMailPath & "がありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　If objFS.FolderExists(strAttPath) = False Then
　　　　MsgBox strAttPath & "がありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　'/切り出しマクロ（選択ファイルのみ1つ）
　　Dim objItem As MailItem
　　Dim AttachedItems As Attachments
　　Dim att As Attachment
　　Dim objOL As Explorer
　　Dim fName As Variant '必ずVariant 型 '**
　　Dim sTitle As String '**
　　Set objOL = Outlook.ActiveExplorer
　　Set objItem = objOL.Selection(1)
　　sTitle = Trim(objItem.ConversationTopic)
　　fName = Left(strMailPath & sTitle, 250) & ".msg" '254文字まで
　　fName = fCheckFileName(fName)
　　If VarType(fName) <> vbString Then MsgBox fName, vbCritical: Exit Sub
　　objItem.SaveAs fName
　　Set AttachedItems = objItem.Attachments
　　If AttachedItems.Count = 0 Then
　　　　'添付ファイルがない場合のメッセージ、普段は不要なので、コメントアウト
　　　　'　　MsgBox "該当メールには、添付ファイルはありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　For Each att In AttachedItems
　　　　With att
　　　　　　.SaveAsFile strAttPath & "\" & .FileName
　　　　End With
　　Next
　　Beep
EndLine:
　　Set objFS = Nothing
　　Set AttachedItems = Nothing
End Sub
　　
Function fCheckFileName(ByVal strFn As String)
'保存ファイル名チェッカー
Dim IllChars As String
IllChars = "/:,;*?<>|"""""
Dim mPath As String
Dim i As Long, j As Long
Const ErrRef As Long = 2023
Const ErrName As Long = 2029

　　 If Len(strFn) > 254 Then
　　　　 fCheckFileName = CVErr(ErrName)
　　　　 Exit Function
　　 End If
　　 i = InStrRev(strFn, "\")
　　 If i > 0 Then
　　　　 mPath = Mid$(strFn, 1, i)
　　　　 If Dir(mPath, vbDirectory) = "" Then
　　　　　　　　fCheckFileName = CVErr(ErrRef)
　　　　　　　　Exit Function
　　　　 End If
　　　　 strFn = Mid$(strFn, i + 1)
　　 End If
Do Until Not strFn Like "*[" & IllChars & "]*"
　　 j = j + 1
　　 strFn = Replace(strFn, Mid$(IllChars, j, 1), "_")
　　 If j > Len(IllChars) Then Exit Do
Loop
fCheckFileName = mPath & strFn
End Function
'//--

この回答へのお礼

何回もありがとうございます。

つぎはSet objItem = objOL.Selection(1)のところで
「配列のインデックスが範囲にありません」とでてきました。

なんてコーディングはむずかしいんだ。。。

お礼日時：2016/05/12 08:33

No.4 回答者： WindFaller 回答日時： 2016/05/10 23:20

こんばんは。

#3のお礼欄の互換については、一応見てみましたが、特に引っかかるものはなさそうです。

>meが完了すると”.SaveAS”のところでもひっかかりました＞＜
違うエラーのメッセージが出るはずです。

objItem.SaveAs strMailPath & objItem & ".msg"

たぶん、その部分が通るメールとそうでないメールがあるはずです。

おそらく、それは、ファイル名に向いていない名前をつけようとしたからです。
メールのタイトル名が、255文字以上、「 \　/　,　;　:　*　?　"　<　>　| 」が含まれる、他、特別なシステムで使用する単語があれば、保存できなくなります。

それをどのように解決するか、決めていませんが、例えば、使っていけない記号を削除する方法があります。もう一つは、ファイル名を一律、何かまったく別な名前で、付ける方法です。最初のほうが楽かもしれません。

とりあえず、本日は、ここまでにしてください。

この回答へのお礼

こんにちは。
Saveasのところででるエラーは、
「オブジェクトは、このプロパティまたはメソッドをサポートしてません。」とでます。

送られてきたメールのタイトルに「/」が日付として入っております。
このフォーマットは変わらないので消さないといけないのですね！

毎回ありがとうございます。

お礼日時：2016/05/11 14:29

No.3 回答者： WindFaller 回答日時： 2016/05/10 15:32

こんにちは。

>Meの部分でひっかかりました！これを調べないといけないのですね！
早速の返事ありがとうございました。
それだけで十分です。ご迷惑を掛けました。

直しましたので、これを全部、上書きにしてみてください。
変更部分は、objOLという部分です。

後の条件は、#1と同じです。聞く所によると、Excel以外は、VBAは新たな局面に変わっているという話も聞いたことがあります。

大したマクロではないとは思いますが、これでダメだったら、私の方は、一旦、Outlook2007をアンインストールして、上位バージョンに変更しますので、もしダメでしたら、少しお時間をいただくことになりそうです。

'//-
Sub SaveEachItem()
　　'OutLook メールを切り出すマクロ
　　Dim objFS As Object: Set objFS = CreateObject("Scripting.FileSystemObject")
　　'メール本体の格納フォルダ
　　Dim strMailPath: strMailPath = "C:\Temp\Mail"
　　If Right(strMailPath, 1) <> "\" Then strMailPath = strMailPath & "\"
　　'添付ファイルの格納フォルダ
　　Dim strAttPath: strAttPath = "C:\Temp\AttachedFiles"
　　If Right(strAttPath, 1) <> "\" Then strAttPath = strAttPath & "\"
　　'フォルダチェック
　　If objFS.FolderExists(strMailPath) = False Then
　　　　MsgBox strMailPath & "がありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　If objFS.FolderExists(strAttPath) = False Then
　　　　MsgBox strAttPath & "がありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　'/切り出しマクロ（選択ファイルのみ1つ）
　　Dim objItem As MailItem
　　Dim AttachedItems As Attachments
　　Dim att As Attachment
　　Dim objOL As Explorer　　'**新たに書き換えました。
　　Set objOL = Outlook.ActiveExplorer
　　Set objItem = objOL.Selection(1)
　　objItem.SaveAs strMailPath & objItem & ".msg"
　　Set AttachedItems = objItem.Attachments
　　If AttachedItems.Count = 0 Then
　　 '添付ファイルがない場合のメッセージ、普段は不要なので、コメントアウト
　　'　　MsgBox "該当メールには、添付ファイルはありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　For Each att In AttachedItems
　　　　With att
　　　　　　.SaveAsFile strAttPath & "\" & .FileName
　　　　End With
　　Next
EndLine:
　　Set objFS = Nothing
　　Set AttachedItems = Nothing
End Sub

この回答へのお礼

何度も何度もありがとうございます。
が、すみません。
meが完了すると”.SaveAS”のところでもひっかかりました＞＜

https://msdn.microsoft.com/ja-jp/library/office/ …
互換性でだめなのか。。。
saveas2って言うものがあるみたいですが。
できないーーーｗ

お礼日時：2016/05/10 16:10

No.2 回答者： WindFaller 回答日時： 2016/05/09 22:50

>オブジェクトは、このプロパティまたはメソッドをサポートしていません。

とでました。

この部分は、どこになるか分かりますか？
短いコードですから、F8 でマクロを1コマずつステップしていけば、エラーの出る部分が分かります。

私は、基本的に、Office 2010 を使っているのですが、Outlook だけは、都合で、バージョンアップしていないのです。インストールしていないのに気がついたというべきだったかもしれません。

やはり、Meの部分でしょうか？この部分なら、直せますが、他は、旧Outlook と新Outlook のVBAの違う点を探さなくてはなりませんので、なるべく特定化できれば、解決は早いと思います。

私は、Office 2013もあるのですが、今のPCには入れていないのと、現在のOutlook をアンイストールして、新たに入れるということまでは、できればしたくないのです。なんとか、その原因の部分だけをご自身で突き止めていただくことはできませんかしら。

>また、このコーディングに関してはOutlookのVBAですが、VB.netではできないでしょうか？

VB.Net 自体よりも、現在のマクロそのものが、Outlookの閲覧に依存したものですから、Outlookにアドインにする以外では、通常のVBAマクロという方法しかないはずです。

ただ、もしかしたら、世界の中では、そうしたツールを作っている人がいるかもしれません。

この回答へのお礼

＞やはり、Meの部分でしょうか？この部分なら、直せますが、他は、旧Outlook と新Outlook のVBAの違う点
＞を探さなくてはなりませんので、なるべく特定化できれば、解決は早いと思います。
Meの部分でひっかかりました！これを調べないといけないのですね！
見つけれるかなー

お礼日時：2016/05/10 15:16

No.1 回答者： WindFaller 回答日時： 2016/05/09 15:05

最初に、私はOutlook のVBAなどはほとんど知らないにも同然ですが、Microsoft のページや他のサイトを見ながら作ってみました。

>Outlookから「：C￥メール」にmsgファイルを手動で移し、そこからVBにて「：>C￥添付ファイル」に添付ファイルのみを取り出したいです。

手動？、Outlook でメールを開いて、適当の受信メールを選択して取り出してしまいます。その時に、そのメールから、添付ファイルを別途抜き出すという仕組みです。

ただし、さすがに、ルートフォルダに、フォルダを設けるという大胆さがないので、今回は、C:\Tempフォルダの中に作りました。

strMailPath = "C:\Temp\Mail"
strAttPath = "C:\Temp\AttachedFiles"
*なるべく英語のほうが良いと思います。

これは、任意に時期責任で変更をお願いします。なお、開発は、Outlook 2007 で、

ThisOutlookSession モジュールです。標準モジュールですと、一部、変更しなくてはなりません。(Meと書いている部分です）

'//
Sub SaveEachItem()
　　'OutLook メールを切り出すマクロ
　　Dim objFS As Object: Set objFS = CreateObject("Scripting.FileSystemObject")
　　'メール本体の格納フォルダ
　　Dim strMailPath: strMailPath = "C:\Temp\Mail"
　　If Right(strMailPath, 1) <> "\" Then strMailPath = strMailPath & "\"
　　'添付ファイルの格納フォルダ
　　Dim strAttPath: strAttPath = "C:\Temp\AttachedFiles"
　　If Right(strAttPath, 1) <> "\" Then strAttPath = strAttPath & "\"
　　'フォルダチェック
　　If objFS.FolderExists(strMailPath) = False Then
　　　　MsgBox strMailPath & "がありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　If objFS.FolderExists(strAttPath) = False Then
　　　　MsgBox strAttPath & "がありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　'/切り出しマクロ（選択ファイルのみ1つ）
　　Dim objItem As MailItem
　　Dim AttachedItems As Attachments
　　Dim att As Attachment
　　Set objItem = Me.ActiveWindow.Selection(1)
　　objItem.SaveAs strMailPath & objItem & ".msg"
　　Set AttachedItems = objItem.Attachments
　　If AttachedItems.Count = 0 Then
　　 '添付ファイルがない場合のメッセージ、普段は不要なので、コメントアウト
　　'　　MsgBox "該当メールには、添付ファイルはありません。", vbExclamation
　　　　GoTo EndLine
　　End If
　　For Each att In AttachedItems
　　　　With att
　　　　　　.SaveAsFile strAttPath & "\" & .FileName
　　　　End With
　　Next
EndLine:
　　Set objFS = Nothing
　　Set AttachedItems = Nothing
End Sub

この回答へのお礼

回答ありがとうございます。
そのままフォルダを作成させて頂きOutlook2013にてThisOutlookSession(コード)にてコピーさせて頂きましたが、オブジェクトは、このプロパティまたはメソッドをサポートしていません。とでました。
申し訳ありません。。。

また、このコーディングに関してはOutlookのVBAですが、VB.netではできないでしょうか？

お礼日時：2016/05/09 18:07