[[20150416170253]] 『EXCELからOUTLOOKの添付メールを保存して開きたい』(もあ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『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.