Epirus

Bem-Vindo, Visitante
Username: Password: Lembrar-me
  • Página:
  • 1
  • 2
  • 3

TÓPICO: Macro para Copiar Anexo e mover mensagem - Outlook

Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #114

Boa tarde,

Estou precisando de uma ajuda,

Tenho um codigo ( encontrei na web ) que salva os anexos (XML ) em uma determinada pasta "F:\NFE\ENTRADA\" , preciso que depois de salvar o anexo que mova a mensagem para a pasta "NFe" do Outlook. Segue codigo.


VBA CODE:

Sub Projeto2(Item As Outlook.MailItem)
Public Sub SalvarAnexo(Item As MailItem)

Dim Atmt As Attachment
Dim FileName As String

For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "xml" Then
FileName = "F:\NFE\ENTRADA\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt

End Sub

Desde já agradeço a atenção.

Romulo
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #119

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 279
  • Thank you received: 23
  • Karma: 4
Romulo,

Voce de definir o objeto de email conforme segue:
set objMailItem= objMailItem.Move(objPastaDeDestino)
objMailItem.Save
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #121

Robert,

Boa tarde, tentei definir o objeto abaixo conforme você orientou, porém não consegui, teria como você me passar como devo proceder ( a pasta de destino se chama NFe ), o anexo "XML" está salvando normalmente, preciso que quando executar esta macro que depois de salvar mova a mensagem para a pasta do outlook (NFe).

Mais uma vez obrigado pela atenção.


Objeto que você passou
set objMailItem= objMailItem.Move(objPastaDeDestino)
objMailItem.Save

Codigo que utilizo
Sub Projeto2(Item As Outlook.MailItem)

Public Sub SalvarAnexo(Item As MailItem)

Dim Atmt As Attachment
Dim FileName As String

For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "xml" Then
FileName = "F:\NFE\ENTRADA\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt

End Sub
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #122

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 279
  • Thank you received: 23
  • Karma: 4
Você pode fazer como segue (assumindo que está dentro da pasta de entrada). Voce deve selecionar os itens que deseja mover.
Sub MoverMensagensSelecionadas()
        On Error Resume Next
        
        Dim objPastaDeDestino                As Outlook.MAPIFolder
        Dim objItem                         As Outlook.MailItem
        
        If Application.ActiveExplorer.Selection.Count = 0 Then
           MsgBox ("Nenhum item selecionado")
           Exit Sub
        End If
               
        Set objPastaDeDestino = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("NFe")
         
        If objPastaDeDestino Is Nothing Then
           MsgBox "Pasta de destino nao encontrada!", vbOKOnly + vbExclamation
            Exit Sub
        End If
        
        For Each objItem In Application.ActiveExplorer.Selection
            objItem.Move objPastaDeDestino
        Next
        
        Set objItem = Nothing
        Set objPastaDeDestino = Nothing

End Sub
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #123

Robert,

Boa tarde,

Este codigo VBA que te passei está sendo executado através de uma regra da seguinte forma
"Aplicar esta regra depois que a mensagem chegar com um anexo" aí ele executa o PROJETO.SALVARANEXO, assim que a mensagem chega automaticamente o anexo que for XML e salvo em um local da rede.

Att.

Romulo
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #124

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 279
  • Thank you received: 23
  • Karma: 4
Romulo

Voce apenas precisa passar o item que chegou da mesma forma que você passou no seu código original. Passando o item de e-mail, você o processa direto sem fazer o loop pelos selecionados.
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #125

Robert,

Bom dia,

Obrigado pela atenção... Tentei fazer como você me passou mas não consegui..

De qualquer forma valeu..

Abraços.

Romulo
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #126

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 279
  • Thank you received: 23
  • Karma: 4
Romulo

Coloca o seu código adaptado bem como uma imagem de sua caixa do Outlook, de modo que eu possa visualizar onde está a tal pasta de NFs. Assim, ficará mais fácil ajudar.
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #127

Robert,

Boa noite,

Este é o codigo que utilizo e que é executado quando a mensagem chega ( Funciona normalmente ).

**** Codigo
Sub Projeto2(Item As Outlook.MailItem)

Public Sub SalvarAnexo(Item As MailItem)

Dim Atmt As Attachment
Dim FileName As String

For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "xml" Then
FileName = "F:\NFE\ENTRADA\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt

End Sub
***
Tela do Meu Outlook está em anexo.

Anexo TelaOutlook.JPG não encontrado




Mais uma vez obrigado pela atenção.

Att.


RomuloRDM
O administrador desabilitou o acesso público de escrita.

Re: Macro para Copiar Anexo e mover mensagem - Outlook 6 anos 8 mêses ago #128

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 279
  • Thank you received: 23
  • Karma: 4
Romulo

Por manda a imagem que aparece o todo da sua pasta, conforme exibo abaixo. Preciso saber qual o nome da pasta que contém as subpastas.


Anexo OUTOOK_RFM_INBOX.PNG não encontrado

O administrador desabilitou o acesso público de escrita.
  • Página:
  • 1
  • 2
  • 3
Time to create page: 0.231 seconds