none
Contatos Outlook em mensagem recebida. Como salvar ? RRS feed

  • Pergunta

  • Pessoal, só uma dúvida..

    Recebi em email que foi direcionado a diversas pessoas.

    Gostaria então de salvar na minha lista de contatos, todas as pessoas que foram direcionadas esta mensagem, mas salvar tudo de uma vez se possível.

    Existe a possibilidade de eu clicar sobre cada endereço de email e pedir pra adicionar aos contatos, mas isso individualmente, e na realidade eu queria salvar tudo nos meus contatos de uma só vez.

    Tem alguma forma de fazer isso ?

     

    Exemplo da situação:

    Remetente: xx

    Destinatários: zzz; aaa; nnn; eee

    Gostaria de salvar esses zzz, aaa, nnn, eee tudo de uma vez só.


    Gregorio
    sexta-feira, 17 de dezembro de 2010 10:25

Respostas

  • Você pode usar a rotina abaixo para salvar todos os contatos de um e-mail aberto no Outlook:

    Sub TesteAdicionarContatos()
      
      Dim ins As Outlook.Inspector
      Dim mi As Outlook.MailItem
      
      Set ins = Application.ActiveInspector
      
      If ins Is Nothing Then
        MsgBox Prompt:="Não há nenhum E-Mail aberto!" _
         , Buttons:=vbCritical _
         , Title:="Erro"
        Exit Sub
      End If
      
      Set mi = ins.CurrentItem
      
      Call AdicionarContatos(mi)
    
    End Sub
    
    Private Sub AdicionarContatos(oMail As Outlook.MailItem)
      
      Dim oNameSpace As Outlook.NameSpace
      Dim oItems As Outlook.Items
      Dim oContact As Outlook.ContactItem
      Dim oRecipient As Outlook.Recipient
      Dim sFind As String
      Dim n As Long
      
      Set oNameSpace = Application.GetNamespace("MAPI")
      Set oItems = oNameSpace.GetDefaultFolder(olFolderContacts).Items
      
      For Each oRecipient In oMail.Recipients
        For n = 1 To 3
          sFind = "[Email" & n & "Address] = " & _
               Chr(39) & oRecipient.Address & Chr(39)
          Set oContact = oItems.Find(sFind)
          If Not oContact Is Nothing Then
            Exit For
          End If
        Next n
    
        If oContact Is Nothing Then
          Set oContact = Application.CreateItem(olContactItem)
          With oContact
            .FullName = oRecipient.Name
            .Email1Address = oRecipient.Address
            .Save
          End With
        End If
        Set oContact = Nothing
      Next
    
    End Sub

     

    Para utilizar essa rotina, cole o código no VBA, abra uma mensagem qualquer, pressione ALT+F8 e execute a macro.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br
    • Marcado como Resposta Gregorio Venturim segunda-feira, 27 de dezembro de 2010 17:59
    sábado, 25 de dezembro de 2010 10:16

Todas as Respostas

  • Penso que só podes adicionar um a um.
    segunda-feira, 20 de dezembro de 2010 08:56
  • Você pode usar a rotina abaixo para salvar todos os contatos de um e-mail aberto no Outlook:

    Sub TesteAdicionarContatos()
      
      Dim ins As Outlook.Inspector
      Dim mi As Outlook.MailItem
      
      Set ins = Application.ActiveInspector
      
      If ins Is Nothing Then
        MsgBox Prompt:="Não há nenhum E-Mail aberto!" _
         , Buttons:=vbCritical _
         , Title:="Erro"
        Exit Sub
      End If
      
      Set mi = ins.CurrentItem
      
      Call AdicionarContatos(mi)
    
    End Sub
    
    Private Sub AdicionarContatos(oMail As Outlook.MailItem)
      
      Dim oNameSpace As Outlook.NameSpace
      Dim oItems As Outlook.Items
      Dim oContact As Outlook.ContactItem
      Dim oRecipient As Outlook.Recipient
      Dim sFind As String
      Dim n As Long
      
      Set oNameSpace = Application.GetNamespace("MAPI")
      Set oItems = oNameSpace.GetDefaultFolder(olFolderContacts).Items
      
      For Each oRecipient In oMail.Recipients
        For n = 1 To 3
          sFind = "[Email" & n & "Address] = " & _
               Chr(39) & oRecipient.Address & Chr(39)
          Set oContact = oItems.Find(sFind)
          If Not oContact Is Nothing Then
            Exit For
          End If
        Next n
    
        If oContact Is Nothing Then
          Set oContact = Application.CreateItem(olContactItem)
          With oContact
            .FullName = oRecipient.Name
            .Email1Address = oRecipient.Address
            .Save
          End With
        End If
        Set oContact = Nothing
      Next
    
    End Sub

     

    Para utilizar essa rotina, cole o código no VBA, abra uma mensagem qualquer, pressione ALT+F8 e execute a macro.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br
    • Marcado como Resposta Gregorio Venturim segunda-feira, 27 de dezembro de 2010 17:59
    sábado, 25 de dezembro de 2010 10:16
  • Excelente ! Parabéns ! 

    Testei o script e funcionou perfeitamente.

    Muito obrigado pela ajuda.


    Gregorio
    segunda-feira, 27 de dezembro de 2010 17:59