none
EAE GALERA ALGUEM PODE ME AJUDAR COM ESSE ERRO??? RRS feed

  • Pergunta


  • Quando executo o macro da aparede um erro falando que:

    O Outlook não pode executar esta ação neste tipo de anexo.

    Sub GetAttachments()

    On Error GoTo GetAttachments_err

     Dim ns As NameSpace
     Dim Inbox As MAPIFolder
     Dim Item As Object
     Dim Atmt As Attachment
     Dim FileName As String
     Dim i As Integer

     Set ns = GetNamespace("MAPI")
     Set Inbox = ns.GetDefaultFolder(olFolderInbox)
     i = 0

    If Inbox.Items.Count = 0 Then
        MsgBox "Nao ha mensagens na Caixa de entrada.", vbInformation, _
               "Nada encontrado"
        Exit Sub
     End If


    For Each Item In Inbox.Items
        For Each Atmt In Item.Attachments
           FileName = "C:\Email Attachments\" & Atmt.FileName
           Atmt.SaveAsFile FileName
           i = i + 1
        Next Atmt
     Next Item

    If i > 0 Then
        MsgBox "Os arquivos encontrados" & i & " foram anexados." _
           & vbCrLf & "Salvo em C:\Email Attachments folder." _
           & vbCrLf & vbCrLf & "Tenha um bom dia.", vbInformation, "Concluido!"
     Else
        MsgBox "Nao foi encontrador nenhum arquivo anexado em seu email.", vbInformation, _
        "Concluido!"
    End If

    GetAttachments_exit:
       Set Atmt = Nothing
       Set Item = Nothing
       Set ns = Nothing
       Exit Sub

    GetAttachments_err:
       MsgBox "An unexpected error has occurred." _
          & vbCrLf & "Observe e relate as informações." _
          & vbCrLf & "Macro Name: GetAttachments" _
          & vbCrLf & "Error Number: " & Err.Number _
          & vbCrLf & "Error Description: " & Err.Description _
          , vbCritical, "Error!"
       Resume GetAttachments_exit
    Exit Sub

    For Each Item In Inbox.Items
       For Each Atmt In Item.Attachments
          If Right(Atmt.FileName, 3) = "xls" Then
             FileName = "C:\Email Attachments\" & Atmt.FileName
             Atmt.SaveAsFile FileName
             i = i + 1
          End If
       Next Atmt
    Next Item

    Dim SubFolder As MAPIFolder
    Set SubFolder = Inbox.Folders("Arquivo.XML")

    If SubFolder.Items.Count = 0 Then
       MsgBox "Não há mensagens na pasta Arquivo.XML" _
       , vbInformation, "Nothing Found"
       Exit Sub
    End If
    If SubFolder.Items.Count > 0 Then
       For Each Item In SubFolder.Items
          For Each Atmt In Item.Attachments
             FileName = "C:\Email Attachments\" & Atmt.FileName
             Atmt.SaveAsFile FileName
             i = i + 1
          Next Atmt
       Next Item
    End If

    FileName = "C:\Email Attachments\" & Item.EntryID & Atmt.FileName
    FileName = "C:\Email Attachments\" & _
       Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName

    Dim varResponse As VbMsgBoxResult
    If i > 0 Then
       varResponse = MsgBox("I found " & i & " attached files." _
          & vbCrLf & "Salvo em C:\Email Attachments folder." _
          & vbCrLf & vbCrLf & "Gostaria de ver os arquivos agora?" _
          , vbQuestion + vbYesNo, "Concluido!")
       If varResponse = vbYes Then
          Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
       End If
    Else
       MsgBox "Nao foi encontrado nenhum arquivo anexado em seu e-mail.", vbInformation, _
          "Concluido!"
    End If

    End Sub

       
    quinta-feira, 30 de março de 2017 20:24