[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『EXCELからOUTLOOKの添付メールを保存して開きたい』(もあ)
いつもお世話になっております 標題のとおりなのですが、整理できません。助けてください OUTLOOKのオブジェクトライブラリ参照設定済です
OUTLOOKの 日報関連 フォルダ(受信メールフォルダ下ではない)のメールより、 当日受信したメールの添付EXCELファイルをフォルダに保存したいです
本文内にpngファイルを貼付けてあったり、添付がメールであったりして うまく枝分かれを考えられません
条件 1.件名に"日報"が含まれること 2.添付ファイルがEXCELファイルであること 3.添付ファイルがメールの場合は、その添付メールに添付されているファイルについて4.6.を行う 4.添付EXCELファイル名に"構成"が含まれない場合はファイル名から"("以下を消す 5.添付EXCELファイル名に"構成"が含まれる場合はファイル名から"(2"以下を消す 6.ファイル名の末尾に本日のYYYYMMを足して保存
一応調べて以下でできたのですが、ゴチャゴチャしてて見にくいです これ以降見ることができないので、明日投稿すればよかったです。すみません よろしくお願いします
Option Explicit
Sub OL_SAVE_MAIL()
Dim OLApp As Object Dim myNameSpace As Object Dim myFolder As Object, objMAILITEM As Object Dim myFolName As String, myDate As Date Dim n As Long
Set OLApp = GetObject(, "Outlook.Application") Set myNameSpace = OLApp.GetNamespace("MAPI")
myFolName = myNameSpace.GetDefaultFolder(6).Parent myDate = Format(Now, "YYYY/MM/DD")
Set myFolder = myNameSpace.Folders(myFolName) Set myFolder = myFolder.Folders("日報関連")
myFolder.Display '新たに窓がたちあがってしまう
For n = myFolder.Items.Count To 1 Step -1 Set objMAILITEM = myFolder.Items(n) If objMAILITEM.CreationTime <= myDate Then '今日の日付か Exit Sub End If Call SaveAttachments(objMAILITEM) Next n
End Sub
Sub SaveAttachments(objMsg As MailItem) Const SAVE_PATH = "C:\ほにゃらら\" Dim objFSO As Object Dim objAttach As Attachment Dim fName As String Dim YM As Long Dim objEmbed As MailItem Dim objEmbedAttach As Attachment
Set objFSO = CreateObject("Scripting.FileSystemObject") YM = Format(Now, "YYYYMM") 'これを末尾に足す
For Each objAttach In objMsg.Attachments
With objAttach If objAttach.Filename Like "*.xl*" Then '日報が含まれるか If InStr(objAttach.Filename, "日報") = 0 Then: Exit Sub '構成が含まれるか If InStr(objAttach.Filename, "構成") = 0 Then fName = Left(objAttach.Filename, InStr(objAttach.Filename, "(") - 1) Else fName = Left(objAttach.Filename, InStr(objAttach.Filename, "(2") - 1) End If '添付ファイルがメールの場合 ElseIf objAttach.Type = olEmbeddeditem Then objAttach.SaveAsFile SAVE_PATH & "embedded.msg" DoEvents ' msg ファイルをアイテムとして開きなおす Set objEmbed = Session.OpenSharedItem(SAVE_PATH & "embedded.msg") For Each objEmbedAttach In objEmbed.Attachments '同じような記述が繰り返されます… If objEmbedAttach.Filename Like "*.xl*" Then fName = Left(objEmbedAttach.Filename, InStr(objEmbedAttach.Filename, "(") - 1) objEmbedAttach.SaveAsFile SAVE_PATH & "\" & fName & YM & ".xlsx" Exit Sub End If Next End If .SaveAsFile SAVE_PATH & "\" & fName & YM & ".xlsx"
End With Next Set objMsg = Nothing Set objFSO = Nothing End Sub
< 使用 Excel:Excel2010、使用 OS:Windows7 >
再帰処理を行うといいかもしれません。 テストしていませんが、ロジックを変えずに、再帰処理になるように手直ししました。 Sub SaveAttachments(objMsg As MailItem) Const SAVE_PATH = "C:\ほにゃらら\" Dim objFSO As Object Dim objAttach As Attachment Dim fName As String Dim YM As Long Dim objEmbed As MailItem Dim objEmbedAttach As Attachment Dim tmpFN As String '★FileNameなんども呼び出しているので、変数に入れたほうが見やすそうなので Set objFSO = CreateObject("Scripting.FileSystemObject") YM = Format(Now, "YYYYMM") 'これを末尾に足す For Each objAttach In objMsg.Attachments With objAttach tmpFN = .Filename If tmpFN Like "*.xl*" Then '日報が含まれるか If InStr(tmpFN, "日報") = 0 Then: Exit Sub '構成が含まれるか If InStr(tmpFN, "構成") = 0 Then fName = Left(tmpFN, InStr(tmpFN, "(") - 1) Else fName = Left(tmpFN, InStr(tmpFN, "(2") - 1) End If '★If〜End Ifの中に入れて、再帰処理向けに手直し .SaveAsFile SAVE_PATH & "\" & fName & YM & ".xlsx" '添付ファイルがメールの場合 ElseIf .Type = olEmbeddeditem Then .SaveAsFile SAVE_PATH & "embedded.msg" DoEvents ' msg ファイルをアイテムとして開きなおす '★再帰処理 自分自身に開きなおしたメールアイテムを渡して、同じ処理をさせる SaveAttachments Session.OpenSharedItem(SAVE_PATH & "embedded.msg") End If End With Next Set objMsg = Nothing Set objFSO = Nothing End Sub
(稲葉) 2015/04/17(金) 09:45
稲葉さん 再帰処理! まさにそれです! いつもいつもゴチャゴチャしたコードから汲み取っていただきありがとうございます 添付ファイルの名前、確かにめっちゃ登場してるので変数に入れた方がいいですね
毎日毎日定時に来ない6つのファイルをリネームして保存するのが手間で仕方がなかったんですが、これで短縮できます 音楽で言うダルセーニョとかダカーポとかの処理方法をどういうのかわからず、Google先生に長文できくこと数回、空振り続きで昨日はめげておりました 再帰処理について調べるとともに、他の小分けにしすぎてめいっぱいになっていたコードも整理しようと思います ありがとうございました!!
(もあ) 2015/04/17(金) 16:04
フィーネをどうするか、で結構再帰処理が永続することも考えられますので、気をつけてくださいね。
気になったのが >If InStr(tmpFN, "日報") = 0 Then: Exit Sub この部分 せっかく終盤でNothingしているのだから、Gotoで飛ぶか、出口まで案内してあげる必要がありますよね。 '日報が含まれるか If InStr(tmpFN, "日報") = 0 Then '何もしない '構成が含まれるか ElseIf InStr(tmpFN, "構成") = 0 Then fName = Left(tmpFN, InStr(tmpFN, "(") - 1) Else fName = Left(tmpFN, InStr(tmpFN, "(2") - 1) End If
(稲葉) 2015/04/17(金) 16:55
Σ(・д・ )ハッ!! うっかりしておりました 本日は空き時間に、再帰処理について調べるとともに、Gotoでジャンプさせたり、Display記述をなくしたり、embedded.msgファイルを削除したりしておりました
音楽ネタにつきあっていただきありがとうございます VBA ダルセーニョでググってもヒットしなかったのは言うまでもありません… 最後までありがとうございましたー!! (もあ) 2015/04/17(金) 17:42
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.