Epirus

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

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

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

Robert,

Bom dia,

Esta condição seria dentro do "Private Sub Application_NewMailEx(ByVal EntryIDCollection As String" ou "Sub ProcessarMensagens(ByVal objEmailItem As Outlook.MailItem)" ?


Obrigado.

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

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

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 274
  • Thank you received: 23
  • Karma: 4
Nesta, eu deixarei você pensar um pouco. :-)

Dá uma olhada lá no código original e ai você me dá a resposta. :-)
O administrador desabilitou o acesso público de escrita.

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

Robert,

Bom dia,

Agradeço por você estar me forçando a entender a logica, mas sinceramente tentei e não consegui, me retornar uma mensagem

"Erro em tempo de execução 424" - O objeto é obrigatorio.

Att.


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

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

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 274
  • Thank you received: 23
  • Karma: 4
O objeto não está sendo passado corretamente, daí o erro dizer que o objeto é obrigatório.
O administrador desabilitou o acesso público de escrita.

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

Robert,

Boa tarde,

Não consegui resolver o problema, voce me passou o codigo abaixo e eu estava precisando que fosse executado somente quando o email fosse para um determinado endereço, aí você solicitou que eu fizesse a inserção da condição

If objEmailItem.To = "O endereço de e-mail address está sendo protegido de spambots. Você precisa ativar o JavaScript enabled para vê-lo. " Then
fazer algo aqui.
End If


Nesta situação que eu não sei onde colocar e em várias tentativas ocorre aquel erro.

Att.


RomuloRDM

** CODIGO **
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim intInicial As Integer
Dim intFinal As Integer
Dim strEntryID As String
Dim intComp As Integer

'On Error GoTo Error_Handler

intInicial = 1
intComp = Len(EntryIDCollection)

strEntryID = Mid(EntryIDCollection, intInicial, (intComp - intInicial) + 1)

Set Email = Application.Session.GetItemFromID(strEntryID)

Call ProcessarMensagens(Email)

Limpar:
Set Email = Nothing
Exit Sub

Error_Handler:
MsgBox Err.Description, vbCritical + vbOKOnly, "NewMailEx"
GoTo Limpar
End Sub
=======================================================================================
Sub ProcessarMensagens(ByVal objEmailItem As Outlook.MailItem)
Const cstr_FolderDestino As String = "NFe"
Const cstr_FolderAnexo As String = "F:\NFE\ENTRADA\"

Dim objPastaDeDestino As Outlook.MAPIFolder
Dim objEmailItemAnexo As Outlook.Attachment
Dim blnMoverEsteEmail As Boolean

blnMoverEsteEmail = False

Set objPastaDeDestino = Application.GetNamespace("MAPI").Folders("Caixa de correio - Romulo").Folders(cstr_FolderDestino)
'Set objPastaDeDestino = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(cstr_FolderDestino)

If objPastaDeDestino Is Nothing Then
MsgBox "Pasta de destino nao encontrada!", vbOKOnly + vbExclamation
Exit Sub
End If


For Each objEmailItemAnexo In objEmailItem.Attachments
If UCase(Right(objEmailItemAnexo.FileName, 3)) = "XML" Then
objEmailItemAnexo.SaveAsFile cstr_FolderAnexo & objEmailItemAnexo.FileName
blnMoverEsteEmail = True
End If
Next

If blnMoverEsteEmail = True Then objEmailItem.Move objPastaDeDestino

Set objEmailItem = 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 2 mêses ago #171

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 274
  • Thank you received: 23
  • Karma: 4
Entao, veja abaixo (negrito) modifiquei para ficar em uma linha só, mas dá no mesmo:
Sub ProcessarMensagens(ByVal objEmailItem As Outlook.MailItem)
Const cstr_FolderDestino As String = "NFe"
Const cstr_FolderAnexo As String = "F:\NFE\ENTRADA\"

Dim objPastaDeDestino As Outlook.MAPIFolder
Dim objEmailItemAnexo As Outlook.Attachment
Dim blnMoverEsteEmail As Boolean

[b]If Not objEmailItem.To = "nfe@vulcapes.com.br" then Exit Sub[/b] 

blnMoverEsteEmail = False

Set objPastaDeDestino = Application.GetNamespace("MAPI").Folders("Caixa de correio - Romulo").Folders(cstr_FolderDestino)
'Set objPastaDeDestino = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(cstr_FolderDestino)

If objPastaDeDestino Is Nothing Then
MsgBox "Pasta de destino nao encontrada!", vbOKOnly + vbExclamation
Exit Sub
End If


For Each objEmailItemAnexo In objEmailItem.Attachments
If UCase(Right(objEmailItemAnexo.FileName, 3)) = "XML" Then
objEmailItemAnexo.SaveAsFile cstr_FolderAnexo & objEmailItemAnexo.FileName
blnMoverEsteEmail = True
End If
Next

If blnMoverEsteEmail = True Then objEmailItem.Move objPastaDeDestino

Set objEmailItem = 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 2 mêses ago #172

  • Robert Martim
  • Robert Martim's Avatar
  • OFFLINE
  • Administrator
  • Postagens: 274
  • Thank you received: 23
  • Karma: 4
A linha é esta:

If Not objEmailItem.To = "O endereço de e-mail address está sendo protegido de spambots. Você precisa ativar o JavaScript enabled para vê-lo. " then Exit Sub

Nao ficou em negrito, mas com o
O administrador desabilitou o acesso público de escrita.
  • Página:
  • 1
  • 2
  • 3
Time to create page: 0.579 seconds