OutlookのVBAでメール受信時に指定の添付ファイル名であれば保存する。

タイトルのまんまです。よく見積書とか請求書をメールで送信してくる人いるじゃないですか、そういう時にメールの内容見てから、わざわざフォルダに保存しないといけないんですよねぇー、、これが面倒くさい。で、Outlookでメール受信したときに指定のアドレスからで指定のファイル名のやつの場合に保存ダイアログいきなり開いてくれるようにマクロ準備したっす。といっても丸々コピペですが、、、
で添付ファイル本体はなぜかZIPパスワードがかかっているので、本当はパスワード付ZIPを自動で解凍してくれるところまでやりたいんですが、そこまでは余力なかった。

パスワード付きファイル展開実装しました。エラーチェックとか盛り込んでいないのでとても危険です。あとMS非推奨の方法だけどDLLなしで対応したかったので仕方なくこの方法で対応しました。ほかにもこういう方法もあるそうです。

ウイルス仕込まれたら危険なので本来はメールファイル添付でやり取りするよりかは素性のはっきりしたRedmineとかプロジェクト管理ツールにファイル集約した方が安全な上に情報集約できていいと思うんですがねぇ、、ファイルサーバにデータ保存はルーチンには向いていますけど、そんなルーチンは自動化すべきと考えているのでやはりファイルはツールで集約管理すべきですね。

どうしてもファイルを送信したいんだぁという場合はオンラインストレージにファイルを保存してからパスワードは口頭で電話連絡するというのが本来のあるべき姿のような気がする。それか、SkypeとかSlackの様なチャットでやり取りのいずれかでしょう。

◆参考サイト
https://outlooklab.wordpress.com/2016/05/21/outlook-%E3%81%A7%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E9%81%B8%E6%8A%9E%E3%81%AE%E3%83%80%E3%82%A4%E3%82%A2%E3%83%AD%E3%82%B0%E3%82%92%E8%A1%A8%E7%A4%BA%E3%81%99%E3%82%8B%E3%83%9E%E3%82%AF%E3%83%AD/
http://vba-andmore.hatenablog.com/entry/2016/07/15/223543
http://kakeruroku.blog.fc2.com/blog-entry-54.html
http://q.hatena.ne.jp/1218725545
https://kazusa-pg.com/vba-open-folder-by-shell/
https://www.tetsuyanbo.net/tetsuyanblog/43217


◆ソースコード

'
' 受信したメールに特定のファイル名が含まれたら指定先に保存する
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
    Const olFolderInbox = 6
    Dim ns As NameSpace
    Set ns = GetNamespace("MAPI")
    
    Dim mf As MAPIFolder
    Dim oflg As Integer
    Set mf = ns.GetDefaultFolder(olFolderInbox)
    
    oflg = searchFile(mf, EntryIDCollection)
    Select Case oflg
        Case Is = 0
            MsgBox ("ファイルを処理しました。")
        
        Case Is = 1
            MsgBox ("ファイルは処理できていません。後で手動で処理してください。")
            Set mf = Nothing
            Exit Sub
        
        Case Else
            Set mf = Nothing
            Exit Sub
    End Select
    
    Set mf = Nothing

End Sub
'ファイルを検索する
Function searchFile(oFolder As Outlook.Folder, EntryIDCollection As String) As Integer

    Dim mis As Variant
    mis = Split(EntryIDCollection, ",")
    
    Dim mai As MailItem
    Dim mi As Variant
    Dim rtn As Integer
    Dim eAd As String
    Dim eNam As String
    Dim fNam As String
    
    For Each mi In mis
        Set mai = Application.Session.GetItemFromID(mi)
        eNam = "YourName"
        eAd = "sample@sample.com"
        fNam = "FileWord"
        rtn = checkFile(mai, eAd, eNam, fNam)
        Select Case rtn
            Case Is = 0
                searchFile = 0
                Exit Function
            Case Is = 1
                searchFile = 1
                Exit Function
            Case Is = 2
                searchFile = 2
                Exit Function
        End Select
    Next
    
    searchFile = 2
    
End Function
'ファイルを検索する
Function checkFile(mItem As MailItem, emailAddr As String, emailName As String, attchName As String) As Long
        
    Dim rtn As Integer
    Dim oFile As Object
    Dim trg1 As Boolean
    Dim trg2 As Boolean
        
    If mItem.SenderEmailAddress = emailAddr Then     'アドレスで確認する場合
        trg1 = True
    End If
    
    If mItem.SenderName = emailName Then             '名前で確認する場合
         trg2 = True
    End If
        
    If trg1 = True Or trg2 = True Then
        For Each oFile In mItem.Attachments
            If InStr(oFile.FileName, attchName) > 0 Then
                rtn = saveFile(oFile)
                If rtn = 0 Then
                    checkFile = 0
                    Exit Function
                Else
                    checkFile = 1
                    Exit Function
                End If
            End If
        Next
    End If
    
    checkFile = 2

End Function

'ファイルを保存する
Function saveFile(objFile As Object) As Integer

    Dim appWord As Object
    Dim dlgFile As FileDialog
    Dim wshShell As Object
    '
    Set appWord = CreateObject("Word.Application")
    Set dlgFile = appWord.FileDialog(Office.msoFileDialogFolderPicker)
    Set wshShell = CreateObject("WScript.Shell")
    Dim zipName As String
    Dim strPass As String
    
    dlgFile.Title = "保存先の指定"
    dlgFile.InitialFileName = wshShell.SpecialFolders("MyDocuments") & "\"
    If dlgFile.Show = -1 Then
        GetFolder = dlgFile.SelectedItems(1)
    Else
        GetFolder = ""
    End If
    If GetFolder <> "" Then
        zipName = GetFolder & "\" & objFile.DisplayName
        objFile.SaveAsFile zipName
        '*** 暗号化ZIPを解凍する。***
        strPass = ""
        Call unZipfile(GetFolder, zipName, strPass)
        saveFile = 0
    Else
        saveFile = 1
        Exit Function
    End If

End Function

'ZIP解凍する
Function unZipfile(CopyTo As Variant, CopyFrom As String, strPass As String)
    'ZIP
    Dim FSO As Object
    Dim shellObj As Object
    Set shellObj = CreateObject("Shell.Application")
    Dim ret As Long
    
    shellObj.NameSpace((CopyTo)).CopyHere shellObj.NameSpace((CopyFrom)).Items
        
    If strPass <> "" Then
        SendKeys strPass & "{Enter}"
    End If

    Shell "Explorer.exe " & CopyTo, vbNormalFocus

    Set FSO = Nothing
    Set shellObj = Nothing
    Set fileObj = Nothing
    Set zipObj = Nothing

End Function

まぁやりたいことはほぼできているからいいかなぁ。ただシンプルじゃないコードなのですごく汚い（泣）その上、エラーチェックがザルなので糞コードです。

今後の課題として
1.パスワード付ZIPの自動解凍機能
2.複数の送信先と複数の対象ファイルを登録できるようにする。
3.パスワードメールを確認してそこからパスワードを自動セットする。

※3は事前に決めておければ必要ない気もしますが大体、あとから送ってくるんで
仕方なし

マクロ有効にしないと動かないので要注意
お約束ですが使用に際しては自己責任でお願いします。

後、こう書き替えれば効率がいいよとかありましたら
ご連絡いただけると幸いです。