Public Function FnSendMailSafe(strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strMessageBody As String, _
Optional strAttachments) As Boolean
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
'Obtendo o MAPI do objeto NameSpace
Set MAPISession = Application.Session
If Not MAPISession Is Nothing Then
'Logando-se na sessão MAPI
MAPISession.Logon , , True, False
'Criando um ponteiro na pasta Outbox
Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
If Not MAPIFolder Is Nothing Then
' Criando um novo item de e-mail item na pasta "Outbox"
Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
If Not MAPIMailItem Is Nothing Then
With MAPIMailItem
'Criando um novo recipiente para TO
Let TempArray = Split(strTo, ";")
For Each varArrayItem In TempArray
Let strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
Let oRecipient.Type = olTo
Set oRecipient = Nothing
End If
Next varArrayItem
'Criando um recipiente para CC
Let TempArray = Split(strCC, ";")
For Each varArrayItem In TempArray
Let strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
Let oRecipient.Type = olCC
Set oRecipient = Nothing
End If
Next varArrayItem
'Criando recipiente para BCC
Let TempArray = Split(strBCC, ";")
For Each varArrayItem In TempArray
Let strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
Let oRecipient.Type = olBCC
Set oRecipient = Nothing
End If
Next varArrayItem
'Configurado a mensagem do SUBJECT
Let .Subject = strSubject
'Configurando a mensagem do corpo od e-mail (em HTML ou texto)
If StrComp(Left(strMessageBody, 6), "<HTML>", vbTextCompare) = 0 Then
Let .HTMLBody = strMessageBody
Else
Let .Body = strMessageBody
End If
'Adicionando qualquer anexo especificado
'Let TempArray = strAttachments
For Each varArrayItem In strAttachments
Let strAttachmentPath = Trim(varArrayItem)
If Len(strAttachmentPath) > 0 Then
.Attachments.Add strAttachmentPath
End If
Next varArrayItem
.Send
Set MAPIMailItem = Nothing
End With
End If
Set MAPIFolder = Nothing
End If
MAPISession.Logoff
End If
Let blnSuccessful = True
ExitRoutine:
Set MAPISession = Nothing
Let FnSendMailSafe = blnSuccessful
Exit Function
ErrorHandler:
MsgBox "Occoreu um erro na função VBA FnSendMailSafe()" & vbCrLf & vbCrLf & _
"Nº do erro: " & CStr(Err.Number) & vbCrLf & _
"Descrição do erro: " & Err.Description, vbApplicationModal + vbCritical
Resume ExitRoutine
End Function
Function SendMail (para As String, cc As String, assunto As String, mensagem As String, Anexos) As Boolean
'enviar e-mail via Outlook
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
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
Let blnNewInstance = True
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
Let blnSuccessful = objOutlook.FnSendMailSafe (para, cc, "", assunto, mensagem, Anexos)
If blnNewInstance = True Then objOutlook.Quit
Set objOutlook = Nothing
Let EnviarEmail = blnSuccessful
End Function
