###### tags: `その他` `VBA`

# メール保存

Sub save_mail()
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim item As Variant
    Dim saveDir As String
    Dim docPath As String
    Dim WSH As Variant
    Dim RE As Variant
    Dim strPattern As String
    Dim exeYM As String
    Dim wName As String

    wName = "作業者名"
    
    Set WSH = CreateObject("WScript.Shell")
    Set RE = CreateObject("VBScript.RegExp")
    
    ' ユーザのドキュメントのパスを取得
    docPath = WSH.SpecialFolders("MyDocuments") & "\"
    
    Set myNameSpace = Application.GetNamespace("MAPI")
    
    ' 送信済みアイテムを取得
    Set myFolder = myNameSpace.GetDefaultFolder(5)
    
    ' 処理対象の年月を入力
    exeYM = InputBox("処理対象の年月を4ケタデ入力しろ", "年月")
    
    ' 検索パターン
    strPattern = "^【業務..】フレキシブルワーク (" & exeYM & "\d\d).+$"
    
    
    ' 送信メール分ループ
    For Each item In myFolder.Items
        Debug.Print CStr(item)
        With RE
            .Pattern = strPattern
            .IgnoreCase = True
            .Global = True
            
            ' 正規表現によるマッチング
            Set reMatch = .Execute(CStr(item))
            If reMatch.Count > 0 Then
                ' ディレクトリの存在確認
                saveDir = docPath & "フレキシブルワーク\Mail\" & reMatch(0).SubMatches(0) & "_" & wName
                If Dir(saveDir, vbDirectory) = "" Then
                    ' なければ作成
                    MkDir saveDir
                End If
                
                ' ファイル保存
                item.SaveAs saveDir & "\" & CStr(item) & ".msg"
            End If
        End With
    Next
End Sub

## 参考

【Outlook VBA】Outlook VBAのオブジェクトについて
https://extan.jp/?p=1459

Outlook/VBA: メールをボタン１つで指定フォルダに保存するマクロ
http://pineplanter.moo.jp/non-it-salaryman/2018/04/05/outlook-saveto-folder/

【VBA入門】フォルダを作成する方法
https://programming-study.com/technology/vba-folda/

特殊フォルダを取得する
http://officetanaka.net/excel/vba/tips/tips107.htm

正規表現によるマッチング
http://officetanaka.net/excel/vba/tips/tips38.htm