Views

Outlook: Enviando E-mail sem o aviso de segurança


Esta tem sido a necessidade e a reclamação de muitos. Como enviar mensagens diretamente do Word, Excel sem que o Outlook fique com aquela mensagem cuidando da nossa vida?

PASSOS:
  1. Abra o Outlook
  2. Vá até o Menu |Tools | Macro | Visual Basic Editor
  3. No ambiente de VBA expanda o projeto que estiver no nó (geralmente é 'Project1')
  4. Ache e abra o módulo "ThisOutLookSession" (Abre com um duplo clique)
  5. Copie e cole o código abaixo:
Option Explicit

' Code: Send E-mail without Security Warnings
' OUTLOOK 2003 VBA CODE FOR 'ThisOutlookSession' MODULE
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 07/05/2005
' Last updated v1.4 - 26/03/2008
'
' Please read the full tutorial here:
' http://www.everythingaccess.com/tutorials.asp?ID=Outlook-Send-E-mail-without-Security-Warning
'
' Please leave the copyright notices in place - Thank you.

Private Sub Application_Startup()

'IGNORE - This forces the VBA project to open and be accessible using automation
' at any point after startup

End Sub

' FnSendMailSafe
' --------------
' Simply sends an e-mail using Outlook/Simple MAPI.
' Calling this function by Automation will prevent the warnings
' 'A program is trying to send a mesage on your behalf...'
' Also features optional HTML message body and attachments by file path.
'
' The To/CC/BCC/Attachments function parameters can contain multiple items by seperating
' them by a semicolon. (e.g. for the strTo parameter, 'test@test.com; test2@test.com' is
' acceptable for sending to multiple recipients.
'
Public Function FnSendMailSafe(strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strMessageBody As String, _
Optional strAttachments As String) As Boolean

' (c) 2005 Wayne Phillips - Written 07/05/2005
' Last updated 26/03/2008 - Bugfix for empty recipient strings
' http://www.everythingaccess.com
'
' You are free to use this code within your application(s)
' as long as the copyright notice and this message remains intact.

On Error GoTo ErrorHandler:

Dim MAPISession As Outlook.NameSpace
Dim MAPIFolder As Outlook.MAPIFolder
Dim MAPIMailItem As Outlook.MailItem
Dim oRecipient As Outlook.Recipient

Dim TempArray() As String
Dim varArrayItem As Variant
Dim strEmailAddress As String
Dim strAttachmentPath As String

Dim blnSuccessful As Boolean

'Get the MAPI NameSpace object
Set MAPISession = Application.Session

If Not MAPISession Is Nothing Then

'Logon to the MAPI session
MAPISession.Logon , , True, False

'Create a pointer to the Outbox folder
Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
If Not MAPIFolder Is Nothing Then

'Create a new mail item in the "Outbox" folder
Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
If Not MAPIMailItem Is Nothing Then

With MAPIMailItem

'Create the recipients TO
TempArray = Split(strTo, ";")
For Each varArrayItem In TempArray

strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olTo
Set oRecipient = Nothing
End If

Next varArrayItem

'Create the recipients CC
TempArray = Split(strCC, ";")
For Each varArrayItem In TempArray

strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olCC
Set oRecipient = Nothing
End If

Next varArrayItem

'Create the recipients BCC
TempArray = Split(strBCC, ";")
For Each varArrayItem In TempArray

strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olBCC
Set oRecipient = Nothing
End If

Next varArrayItem

'Set the message SUBJECT
.Subject = strSubject

'Set the message BODY (HTML or plain text)
If StrComp(Left(strMessageBody, 6), "<HTML>", vbTextCompare) = 0 Then
.HTMLBody = strMessageBody
Else
.Body = strMessageBody
End If

'Add any specified attachments
TempArray = Split(strAttachments, ";")
For Each varArrayItem In TempArray

strAttachmentPath = Trim(varArrayItem)
If Len(strAttachmentPath) > 0 Then
.Attachments.Add strAttachmentPath
End If

Next varArrayItem

.Send 'No return value since the message will remain in the outbox if it fails to send

Set MAPIMailItem = Nothing

End With

End If

Set MAPIFolder = Nothing

End If

MAPISession.Logoff

End If

'If we got to here, then we shall assume everything went ok.
blnSuccessful = True

ExitRoutine:
Set MAPISession = Nothing
FnSendMailSafe = blnSuccessful

Exit Function

ErrorHandler:
MsgBox "An error has occured in the user defined Outlook VBA function FnSendMailSafe()" & vbCrLf & vbCrLf & _
"Error Number: " & CStr(Err.Number) & vbCrLf & _
"Error Description: " & Err.Description, vbApplicationModal + vbCritical
Resume ExitRoutine

End Function

Teste o código do Outlook.

Envie um e-mail de teste a partir da janela imediata do OutLook (CTRL+G)

? ThisOutlookSession.FnSendMailSafe("","","bernardess@gmail.com","A and A – Teste do Outlook","TEST")

 Agora que já está certo de que o cóigo VBA foi instalado corretamente, partamos para o próximo passo:

NESTE EXEMPLO UTILIZAREMOS O MS ACCESS, MAS É APROPRIADO PARA QUALQUER PROGRAMA DA SUÍTE MS OFFICE COM VBA.

Chamando a função VBA do Outlook a partir do código VBA do Access
  1. Abra sua base de dados Access
  2. Crie um novo o módulo para testarmos o nosso propósito
  3. Copie e cole o código abaixo: 

Option Explicit


' ACCESS VBA MODULE: Send E-mail without Security Warning

' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)

' Written 07/05/2005

' Last updated v1.3 - 11/11/2005

'

' Please read the full tutorial & code here:

' http://www.everythingaccess.com/tutorials.asp?ID=Outlook-Send-E-mail-without-Security-Warning

'

' Please leave the copyright notices in place - Thank you.
      

'This is a test function - replace the e-mail addresses with your own before executing!!

'(CC/BCC can be blank strings, attachments string is optional)
      

Sub FnTestSafeSendEmail()

    Dim blnSuccessful As Boolean

    Dim strHTML As String


    strHTML = "<html>" & _

               "<body>" & _

               "My <b><i>HTML</i></b> message text!" & _

               "</body>" & _

               "</html>" 

    blnSuccessful = FnSafeSendEmail("myemailaddress@domain.com", _

                                    "My Message Subject", _

                                    strHTML)



      'A more complex example...    

    'blnSuccessful = FnSafeSendEmail("bernardess@gmail.com; secondrecipient@domain.com", _

                                         "My Message Subject", _     

                                         strHTML, _    

                                         "C:\MyAttachmentFile1.txt; C:\MyAttachmentFile2.txt", _ 

                                         "cc_recipient@domain.com", _  

                                         "bcc_recipient@domain.com")
      
    If blnSuccessful Then


        MsgBox ".: Mensagem de E-mail enviada com sucesso!"


    Else


        MsgBox ":. Falha ao enviar e-mail!"


    End If


End Sub



'This is the procedure that calls the exposed Outlook VBA function...
      
Public Function FnSafeSendEmail(strTo As String, _

                    strSubject As String, _

                    strMessageBody As String, _

                    Optional strAttachmentPaths As String, _

                    Optional strCC As String, _

                    Optional strBCC As String) As Boolean


    Dim objOutlook As Object ' Note: Must be late-binding.

    Dim objNameSpace As Object

    Dim objExplorer As Object

    Dim blnSuccessful As Boolean

    Dim blnNewInstance As Boolean



      'Is an instance of Outlook already open that we can bind to?
      
    On Error Resume Next

    Set objOutlook = GetObject(, "Outlook.Application")

    On Error GoTo 0


    If objOutlook Is Nothing Then



      'Outlook isn't already running - create a new instance...
      
        Set objOutlook = CreateObject("Outlook.Application")

        blnNewInstance = True    


      'We need to instantiate the Visual Basic environment... (messy)
      
        Set objNameSpace = objOutlook.GetNamespace("MAPI")

        Set objExplorer = objOutlook.Explorers.Add(objNameSpace.Folders(1), 0)

        objExplorer.CommandBars.FindControl(, 1695).Execute


        objExplorer.Close


        Set objNameSpace = Nothing

        Set objExplorer = Nothing


    End If


    blnSuccessful = objOutlook.FnSendMailSafe(strTo, strCC, strBCC, _

                                                strSubject, strMessageBody, _

                                                strAttachmentPaths)


    If blnNewInstance = True Then objOutlook.Quit

    Set objOutlook = Nothing


    FnSafeSendEmail = blnSuccessful


End Function

Pois é, divirtam-se…


Tags: VBA, Outlook, email, security, warning, aviso, Application, Automation

Tags: , , , , , , , ,

Nenhum comentário:

Postar um comentário

Assinar: Postar comentários (Atom)
diHITT - Notícias