Views

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



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

Tags: , , , , , , , ,

Nenhum comentário:

Postar um comentário

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