✔ VBA Dashboards Specialist®: VBA Excel - Enviando e-mail pelo Excel

11 de outubro de 2013

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