VBA Excel - Enviando e-mail pelo Excel - Sending EMail With VBA

Consultancy in Excel, Access, VBA & PowerPoint projects

DESENVOLVO APLICAÇÕES

Perguntas, Questões e Esclarecimentos

Sim, confesso ter escrito inúmeras vezes sob este tópico e, se continuo fazendo isso, é porque observo uma procura constante pela utilização deste recurso tão simples,mas tão necessário.

Se tudo o que deseja fazer é enviar a planilha, pode usar ThisWorkbook.SendMail. No entanto, se deseja incluir um texto no corpo da mensagem ou incluir arquivos adicionais como anexos, precisará de algum código VBA.

Procurei disponibilizar a função SendEmail por ser bem amigável.

Esse código prescinde da referência ao Microsoft CDO for Windows 2000 Library. Normalmente o localizamos em C:\Windows\system32\cdosys.dll. O GUID para este componente é {CD000000-8B95-11D1-82DB-00C04FB1625D}, para Maior = 1 e Menor = 0.

Function SendEMail (Subject As String, _

        FromAddress As String, _

        ToAddress As String, _

        MailBody As String, _

        SMTP_Server As String, _

        BodyFileName As String, _

        Optional Attachments As Variant = Empty) As Boolean

Dim MailMessage As CDO.Message

Dim N As Long

Dim FNum As Integer

Dim S As String

Dim Body As String

Dim Recips() As String

Dim Recip As String

Dim NRecip As Long

' ensure required parameters are present and valid.

If Len(Trim(Subject)) = 0 Then

    SendEMail = False

    Exit Function

End If

If Len(Trim(FromAddress)) = 0 Then

    SendEMail = False

    Exit Function

End If

If Len(Trim(SMTP_Server)) = 0 Then

    SendEMail = False

    Exit Function

End If

' Clean up the addresses

Recip = Replace(ToAddress, Space(1), vbNullString)

If Right(Recip, 1) = ";" Then

    Recip = Left(Recip, Len(Recip) - 1)

End If

Recips = Split(Recip, ";")

For NRecip = LBound(Recips) To UBound(Recips)

    On Error Resume Next

    ' Create a CDO Message object.

    Set MailMessage = CreateObject("CDO.Message")

    If Err.Number <> 0 Then

        SendEMail = False

        Exit Function

    End If

    Err.Clear

    On Error GoTo 0

    With MailMessage

        .Subject = Subject

        .From = FromAddress

        .To = Recips(NRecip)

        If MailBody <> vbNullString Then

            .TextBody = MailBody

        Else

            If BodyFileName <> vbNullString Then

                If Dir(BodyFileName, vbNormal) <> vbNullString Then

                    ' import the text of the body from file BodyFileName

                    FNum = FreeFile

                    S = vbNullString

                    Body = vbNullString

                    Open BodyFileName For Input Access Read As #FNum

                    Do Until EOF(FNum)

                        Line Input #FNum, S

                        Body = Body & vbNewLine & S

                    Loop

                    Close #FNum

                    .TextBody = Body

                Else

                    ' BodyFileName not found.

                    SendEMail = False

                    Exit Function

                End If

            End If ' MailBody and BodyFileName are both vbNullString.

        End If

        

        If IsArray(Attachments) = True Then

            ' attach all the files in the array.

            For N = LBound(Attachments) To UBound(Attachments)

                ' ensure the attachment file exists and attach it.

                If Attachments(N) <> vbNullString Then

                    If Dir(Attachments(N), vbNormal) <> vbNullString Then

                        .AddAttachment Attachments(N)

                    End If

                End If

            Next N

        Else

            ' ensure the file exists and if so, attach it to the message.

            If Attachments <> vbNullString Then

                If Dir(CStr(Attachments), vbNormal) <> vbNullString Then

                    .AddAttachment Attachments

                End If

            End If

        End If

        With .Configuration.Fields

            ' set up the SMTP configuration

            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server

            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

            .Update

        End With

        

        On Error Resume Next

        Err.Clear

        ' Send the message

        .Send

        If Err.Number = 0 Then

            SendEMail = True

        Else

            SendEMail = False

            Exit Function

        End If

    End With

Next NRecip

SendEMail = True

End Function

Caso deseje anexar algum objeto, adicione:

ThisWorkbook.Save

ThisWorkbook.ChangeFileAccess xlReadOnly

B = SendEmail( _

    ... parameters ...

    Attachments:=ThisWorkbook.FullName)

ThisWorkbook.ChangeFileAccess xlReadWrite

Tags: VBA, excel, 

Sending, EMail, CDO, Attachments, Workbook, mail, e-mail, 

Reference: CPerson