Outlookで選択中のメールと添付ファイルを日付順のファイル名で保存します。

選択中のメールをファイルにしたいとき,普通であればドラッグアンドドロップでエクスプローラーにぽいっとするわけですが,似たような件名のファイルがずらずらとできて,どれがどれだか…ってなることが嫌で作りました。

ついでに添付ファイルも個別のファイルとして保存します。

なお,このコードではステータスバーへ進捗状況を表示するためにコチラのコードを使用しています。

Option Explicit On
' 参照設定 '
' Microsoft Scriptiong Runtime '
' Microsoft Excel 15.0 Object Library ' 

Sub Macro_選択中のアイテムを受信時刻と件名のファイル名で保存する()

    Dim wnd As Window
    Dim exp As Explorer
    Set exp = ActiveExplorer
    Dim hwnd As Long
    hwnd = FindWindow("rctrl_renwnd32", exp.Caption)

    ' 保存先選択'
    Dim oExcel As New Excel.Application
    oExcel.Visible = False
    Dim DiagFol As Office.FileDialog
    Set DiagFol = oExcel.Application.FileDialog(msoFileDialogFolderPicker)
    DiagFol.Show
    Dim PathSaveAs As String
    PathSaveAs = DiagFol.SelectedItems(1) & "\" '"
    oExcel.Quit
    Set oExcel = Nothing
 
    ' 添付を保存するかどうか。'
    Dim diagRes As VbMsgBoxResult
    Dim AttachFileSaveAs As Boolean
    diagRes = MsgBox("選択したメールアイテムに添付ファイルがある場合," & vbCrLf & "それぞれの添付ファイルを個別のファイルとして保存" & vbCrLf & "しますか?(Yes/No)" & vbCrLf & "処理を中止する場合はキャンセル", vbYesNoCancel, "確認")
    If diagRes = vbCancel Then
        Exit Sub
    ElseIf diagRes = vbNo Then
        AttachFileSaveAs = False
    ElseIf diagRes = vbYes Then
        AttachFileSaveAs = True
    End If

    ' メール保存'
    Dim objItem As MailItem
    Dim numItem As Integer
    Dim countItem As Integer

    ' 現在選択中のアイテムすべてについて'
    countItem = ActiveExplorer.Selection.Count
    For numItem = 1 To countItem
        Call ChangeStatusBarText(hwnd, "メール保存中(" & numItem & "/" & countItem & ")")
        DoEvents
        If ActiveExplorer.Selection.Item(numItem).Class = OlObjectClass.olMail Then
            Set objItem = ActiveExplorer.Selection.Item(numItem)
        Else
            GoTo CNT
        End If
        Dim fnTimestamp As String
        Dim strFileName As String
        On Error Resume Next
        fnTimestamp = Format(objItem.ReceivedTime, "yyyy.mm.dd-hhnn_")
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする'
            fnTimestamp = Format(objItem.LastModificationTime, "yyyy.mm.dd-hhnn_")
            Err.Clear
        End If
        On Error GoTo 0
        ' ファイル名を受信日時と件名から作成'
        strFileName = fnTimestamp &amp; objItem.Subject
        ' ファイルをフォルダに保存'
        objItem.SaveAs FixFileName(PathSaveAs, strFileName, "msg"), olMSG
        ' 添付ファイルの処理'
        If AttachFileSaveAs Then
            Dim objAttach As Attachment
            Dim numAttach As Integer
            Dim countAttach As Integer
            countAttach = objItem.Attachments.Count
            If countAttach > 0 Then
                For numAttach = 1 To countAttach
                    Call ChangeStatusBarText(hwnd, "メール保存中(" &amp; numItem &amp; "/" &amp; countItem &amp; ") → 添付ファイルを保存中(" &amp; numAttach &amp; "/" &amp; countAttach &amp; ")")
                    Set objAttach = objItem.Attachments.Item(numAttach)
                    objAttach.SaveAsFile FixFileName(PathSaveAs, fnTimestamp &amp; objAttach.FileName)
                Next
            End If
        End If
CNT:
    Next
    Call ChangeStatusBarText(hwnd, "")
    Call DestroyStat(hwnd)

End Sub

Private Function FixFileName(path As String, name As String, Optional ext As String = "")
    Dim strFileName As String
    Dim arrErrChars
    Dim arrRepChars
    Dim objFSO As New FileSystemObject
    Dim I As Integer
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|") '"
    arrRepChars = Array("¥", "/", ":", "*", "?", "_", "<", ">", "|")
    Const MAX_PATH = 259
    ' Extなし'
    If ext = "" Then
        ext = objFSO.GetExtensionName(name)
        name = objFSO.GetBaseName(name)
    End If
    ' ファイル名として不適切な文字を置き換える'
    strFileName = name
    For I = 0 To UBound(arrErrChars)
        strFileName = Replace(strFileName, arrErrChars(I), arrRepChars(I))
    Next
    ' ファイル名が 260 文字以上とならないようにする。'
    strFileName = Left(path &amp; strFileName, MAX_PATH - Len(ext) - 1)
    Dim idx As String
    Dim tmpFileName As String
    tmpFileName = strFileName
    ' 同名のファイルがある場合の処理'
    If objFSO.FileExists(tmpFileName &amp; "." &amp; ext) Then
        I = 2 ' (2) から始める'
        idx = "(" &amp; I &amp; ")"
        tmpFileName = Left(strFileName, MAX_PATH - Len(ext) - 1 - Len(idx)) &amp; idx
        While objFSO.FileExists(tmpFileName &amp; "." &amp; ext)
            I = I + 1
            idx = "(" &amp; I &amp; ")"
            tmpFileName = Left(strFileName, MAX_PATH - Len(ext) - 1 - Len(idx)) &amp; idx
        Wend
    End If
    FixFileName = tmpFileName &amp; "." &amp; ext
End Function


0件のコメント

コメントする

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください