Macro que salva todos os anexos do Excel em um email para uma pasta no meu disco rígido

Question

Abaixo está um código de trabalho que salvará quaisquer anexos em emails do Outlook em uma pasta específica no meu disco rígido. Para fazer isso funcionar eu tenho que selecionar todos os e-mails que eu quero a macro para executar pol O que eu preciso de ajuda é modificar o código para ser executado em uma pasta específica no meu Outlook sem eu selecionar os e-mails manualmente e, em seguida, irá salvar todos os anexos do Excel em uma pasta no meu disco rígido. Eu tentei algumas coisas, mas em uma instância ele converte todos os anexos para um arquivo do Excel, em vez de apenas extrair o arquivo excel e ignorar qualquer outra coisa.

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

Para salvar somente anexos do Excel, verifique a extensão.

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

Para executar em uma pasta, em vez de uma seleção, é uma pergunta separada.