Макрос, который сохраняет все вложения Excel на электронную почту в папку на моем жестком диске

Question

Ниже приведен рабочий код, который будет сохранять любые вложения в электронных письмах Outlook в определенную папку на моем жестком диске. Чтобы это работало, мне нужно выбрать все электронные письма, в которых я хочу запустить макрос. Мне нужна помощь в изменении кода для запуска в определенной папке в моем Outlook без необходимости выбора электронных писем вручную, а затем он сохранит все вложения Excel в папке на моем жестком диске. Я пробовал несколько вещей, но в одном случае он конвертирует все вложения в файл Excel, а не просто извлекает файл Excel и игнорирует все остальное.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

strFolderpath = "F:\Test folder"
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection

strFolderpath = strFolderpath & "\Attachments\"


For Each objMsg In objSelection


    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then


        For i = lngCount To 1 Step -1


            strFile = objAttachments.Item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.Item(i).SaveAsFile strFile
            objAttachments.Item(i).Delete
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If


        Next i


        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
        Else
            objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
        End If
        objMsg.Save
    End If
Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Answer 1

Чтобы сохранить только вложения Excel, проверьте расширение.

Public Sub SaveAttachments()

'Dim objOL As Outlook.Application
'Dim objMsg As Outlook.mailitem
'Dim objAttachments As Outlook.Attachments
'Dim objSelection As Outlook.Selection

Dim objMsg As Object    ' Accepts anything in the selection
Dim objAttachments As Attachments
Dim objSelection As Selection

Dim i As Long
Dim lngCount As Long

Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

strFolderpath = "F:\Test folder"

'On Error Resume Next
' The On Error Resume Next means
'  if the "Attachments" folder does not exist
'  the attachments will be lost forever when deleted.

'Set objOL = CreateObject("Outlook.Application")
'Set objSelection = objOL.ActiveExplorer.Selection

Set objSelection = ActiveExplorer.Selection

strFolderpath = strFolderpath & "\Attachments\"

For Each objMsg In objSelection

    If objMsg.Class = olMail Then

        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.count
        strDeletedFiles = ""

        If lngCount > 0 Then

            For i = lngCount To 1 Step -1

                strFile = objAttachments.Item(i).fileName

                If strFile Like "*.xls*" Then

                    strFile = strFolderpath & strFile

                    objAttachments.Item(i).SaveAsFile strFile

                    objAttachments.Item(i).Delete

                    If objMsg.BodyFormat <> olFormatHTML Then
                        strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                    Else
                        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                        strFile & "'>" & strFile & "</a>"
                    End If

                End If

            Next i

            If objMsg.BodyFormat <> olFormatHTML Then
                objMsg.body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If

            ' Verify working then switch from Display to Save
            objMsg.Display
            'objMsg.Save

        End If

    End If

Next

ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    'Set objOL = Nothing

End Sub

Для запуска на папке, а не выбор, это отдельный вопрос.