Sub Mail_Workbook_Outlook()
'Es necesario añadir la refeerncia Microsoft Outlook Library (Herramientas/Referencias)
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim Rst As DAO.Recordset, Para As String
Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(olMailItem)
Set Rst = CurrentDb.OpenRecordset("Emails") Do While Not Rst.EOF
If EmailCorrecto(Rst!Email) Then 'Si el email cumple la sintaxis
Para = Para & IIf(Para = "", "", ";") & Rst!Email 'Se añade al para separado por ; del anterior
End If
Rst.MoveNext 'Vamos al siguiente registro
DoEvents
Loop
Rst.Close
With OutMail
'Esto es obvio :)
.To = Para
.CC = ""
.BCC = ""
.Subject = "Asunto del mensaje"
.Body = "Este es el texto del mensaje"
'Se pueden adjuntar ficheros
If Dir("D:\Documento.txt") <> "" Then 'Evitamos que se produzca un error si no existe el archivo
.Attachments.Add ("D:\Documento.txt") End If
.Send 'Tambien se puede usar .Save y lo situa en Borrador para enviarlo posteriormente
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set Rst = Nothing
End Sub
Private Function EmailCorrecto(Email As String) As Boolean
'Esta función verifica que la dirección de email sea correcta desde un _
punto de vista de sintaxis (tenga un buzón, una arroba y un dominio)
Dim iArroba As Integer, iPunto As Integer
iArroba = InStr(1, Email, "@") 'Averiguamos dónde está la primera arroba
If iArroba > 1 Then 'La @ no puede ser el primer carácter
If InStr(iArroba + 1, Email, "@") > 0 Then 'Si hay más arroba
iArroba = 0 'es como si no hubiese ninguna
Else
iPunto = InStrRev(Email, ".") 'Averigumos dónde está el último punto
End If
End If
EmailCorrecto = (iArroba > 0) And (iPunto - iArroba > 1) And (Len(Email) - iPunto > 0)
'El email es correcto si hay una sola arroba y el último punto está al menos a un caracter _
de la arroba y no es el último carácter
End Function
