none
Script para remover anexos de mensagens enviadas pelo outlook

    Question

  • Olá.

      Preciso criar um script que verifique se o destinatário e ,se ele não constar em uma lista pré-determinada, o outlook remova o anexo do email, independente de que formato for esse anexo.

      Essa lista de destinatário preciso colocar em um arquivo txt que será somente leitura para que o usuário não possa alterar.

       Temos o winconnection 6 aqui na empresa,mas infelizmente ele apenas filtra tipos de anexo e não destinatários, portanto se eu conseguir fazer essa filtragem será pelo outlook mesmo.

       Temos várias versões de outlook 2003, 2007 e 2010 na rede, todas originais e devidamente registradas.

    Alguem tem idéia de como implementar?

    Att

    Alex

    Thursday, June 14, 2012 5:59 PM

Answers

  • Cole o código abaixo na classe do objeto ThisOutlookSession do Outlook:

    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
        
        If TypeName(Item) <> "MailItem" Then Exit Sub
        
        Dim sLista As String
        Dim iFreeFile As Integer
        Dim att As Attachment
    
        'Altere o caminho abaixo:
        sLista = "C:\temp\Lista.txt"
        
        iFreeFile = FreeFile
        Open sLista For Binary Access Read As iFreeFile
        sLista = Space(LOF(iFreeFile))
        Get 1, , sLista
        Close #1
        
        If InStr(1, sLista, Item.SenderEmailAddress) > 0 Then Exit Sub
        
        For Each att In Item.Attachments
            att.Delete
        Next att
        Item.Save
        
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Thursday, June 21, 2012 10:11 PM
    Moderator

All replies

  • O primeiro passo é você criar uma regra no Outlook para executar uma macro ao receber um e-mail. Para o Outlook 2010: http://www.ambienteoffice.com.br/outlook/executar_macro_ao_receber_e-mail/

    Em seguida, use o seguinte código no Outlook:

    Sub MensagemRecebida(Item As MailItem)
        Dim sLista As String
        Dim iFreeFile As Integer
        Dim att As Attachment
    
        'Altere o caminho abaixo:
        sLista = "C:\temp\Lista.txt"
        
        iFreeFile = FreeFile
        Open sLista For Binary Access Read As iFreeFile
        sLista = Space(LOF(iFreeFile))
        Get 1, , sLista
        Close #1
        
        If InStr(1, sLista, Item.SenderEmailAddress) > 0 Then Exit Sub
        
        For Each att In Item.Attachments
            att.Delete
        Next att
        Item.Save
        
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Sunday, June 17, 2012 8:57 PM
    Moderator
  • Felipe, boa tarde

    Vou tentar isso quando voltar ao cliente, mas não é quando chegarem os emails e sim quando eles saírem. Não quero que os usuários da rede enviem arquivos para qualquer um pois trabalhamos com arquivos confidenciais.

    Vou testar na proxima semana e posto o resultado aqui.

    Thursday, June 21, 2012 8:59 PM
  • Cole o código abaixo na classe do objeto ThisOutlookSession do Outlook:

    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
        
        If TypeName(Item) <> "MailItem" Then Exit Sub
        
        Dim sLista As String
        Dim iFreeFile As Integer
        Dim att As Attachment
    
        'Altere o caminho abaixo:
        sLista = "C:\temp\Lista.txt"
        
        iFreeFile = FreeFile
        Open sLista For Binary Access Read As iFreeFile
        sLista = Space(LOF(iFreeFile))
        Get 1, , sLista
        Close #1
        
        If InStr(1, sLista, Item.SenderEmailAddress) > 0 Then Exit Sub
        
        For Each att In Item.Attachments
            att.Delete
        Next att
        Item.Save
        
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Thursday, June 21, 2012 10:11 PM
    Moderator
  • Benzadeus... muito obrigado pela sua resposta.

    ola, não foi 100% correta sua ajuda mas bateu na trave e só precisou de alguns ajustes.

    Esse script que voce colocaou verifica o remetente e não o destinatário, então fiz alguns ajustes e o código ficou assim, 100% funcional.

    Como só precisou de um peque ajuste, o Crédito é todo Seu..  muito obrigado amigão

    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     'Solução sugerida por Felipe Costa Gualberto

    'Adaptado por Alex Augusto Felicioni

    'podem usar mas mantenham os creditos por favor 

    If TypeName(Item) <> "MailItem" Then Exit Sub
           Dim sLista As String
           Dim iFreeDestino As Integer
           Dim att As Attachment
          
    'aqui fica o caminho para o arquivo de endereços
        sLista = "c:\temp\Destinos.txt"
        iFreeDestino = FreeFile
        Open sLista For Binary Access Read As iFreeDestino
        sLista = Space(LOF(iFreeDestino))
        Get 1, , sLista
        Close #1
        If InStr(sLista, Item.To) > 0 Then Exit Sub
        For Each att In Item.Attachments
            att.Delete
            MsgBox ("O Anexo foi removido pois infringe as regras de email da Empresa")
        Next att
        Item.Save
    End Sub



    Tuesday, July 17, 2012 5:38 PM