'  *****  BASIC  *****
 
Option Explicit
 
   ' Datos de la cuenta y servidor que envían el correo
   Const myAddress = "[email protected]"   ' la dirección de correo desde donde vas a enviar el correo
   Const smtpServer = "smtp.xxxx.xx"    ' tu servidor de correo smtp
   Const smtpPort = 25                  ' puerto del servidor de correo
   Const smtpSecure = False             ' true si es un servidor con protocolo seguro
   Const smtpUser = "[email protected]"     ' usuario de la cuenta
   Const attachmentMaxSize = 200        ' tamaño máximo del archivo adjunto en Kbytes
 
   ' Variables para las funciones de listener (detectores) , que no se pueden pasar como argumentos
   Private smtpPassword As String
   Private messageBody As String
   Private attachmentContents As Object
   Private attachmentType As String
   Private lExito As Boolean
 
Sub EnviarMailConAdjunto()
   Dim TOs As String, CCs As String, CCOs As String
   Dim Asunto As String, Mensaje As String, AdjuntoURL As String
 
   ' comentar la línea siguiente para que no pida confirmación
   If Aviso ("¿Confirma que desea enviar el correo?", 33) = 2 Then Exit Sub
 
   ' Direcciones a las que se envía el correo, separadas por ;
   TOs = "[email protected];[email protected]"
 
   ' Direcciones a las que se envía copia, separadas por ;
   CCs = "[email protected];[email protected]"
 
   ' Direcciones a las que se envía copia oculta, separadas por ;
   CCOs = "[email protected];[email protected]"
 
   ' Asunto del mensaje
   Asunto = "Prueba de correo con adjunto"
 
   ' Cuerpo del correo
   Mensaje = "Prueba de envío de correo desde OpenOffice, con adjunto un documento adjunto"
 
   ' Adjunto: dejar en blanco si no se envía adjunto
   AdjuntoURL  = ConvertToURL("C:\Mis Documentos\PDFs\Mi documento.pdf")
 
   lExito = False
 
   If TOs Like "*@*.*" Then
      smtpPassword = "xxxxxxxx"            ' contraseña de tu cuenta de correo
      attachmentType = "application/pdf"   ' tipo de archivo mime
      sendMail(TOs, CCs, CCOs, Asunto, Mensaje, AdjuntoURL )
   Else
      Aviso "Parece que la dirección del destinatario es incorrecta"
   End If
 
   If Not lExito Then
      Aviso "El correo no pudo ser enviado"
   Else
      Aviso "El correo se ha enviado con éxito"
   EndIf
 
End Sub
 
 
Function Aviso( cAviso As String, Optional nBoton As Integer, Optional cTitulo As String )
   If IsMissing(cTitulo) Then cTitulo = "Enviar correos desde OpenOffice"
   If IsMissing(nBoton) Then nBoton = 192
   Aviso = MsgBox (cAviso, nBoton, cTitulo)
End Function
 
 
Sub sendMail(TOs, CCs, CCOs, subject, Mensaje, Optional attachmentUrl)
   Dim bodyObject As Object, attachment As Object, message As Object, _
   serviceProvider As Object, service As Object, server As Object, mailUser As Object
 
   Dim aTOs() As String, aCCs()As String, aCCOs() As String, i As Integer
 
   'Se declaran servicios que son necesarios
   bodyObject = CreateUNOListener("body_", "com.sun.star.datatransfer.XTransferable")
   messageBody = Mensaje
 
   If Not IsMissing(attachmentUrl) Then
      lExito = attachmentFromUrl(attachment, attachmentUrl)
   End If
 
   If Not lExito Then Exit Sub
 
   aTOs = Split(TOs, ";")
   aCCs = Split(CCs, ";")
   aCCOs = Split(CCOs, ";")
 
   message = com.sun.star.mail.MailMessage.createWithAttachment(aTOs(0), myAddress, subject, bodyObject, attachment)
 
   serviceProvider = CreateUNOService("com.sun.star.mail.MailServiceProvider")
   service = serviceProvider.Create("com.sun.star.mail.SMTP")
   server = CreateUNOListener("smtp_", "com.sun.star.uno.XCurrentContext")
   mailUser = CreateUNOListener("user_", "com.sun.star.mail.XAuthenticator")
 
   ' Si hay varios destinatarios
   For i = 1 To UBound(aTOs)
      message.addRecipient(aTOs(i))
   Next i
 
   ' si hay destinatarios con copia
   For i = 0 To UBound(aCCs)
      message.addCcRecipient(aCCs(i))
   Next i
 
   ' si hay destinatarios con copia oculta
   For i = 0 To UBound(aCCOs)
      message.addBccRecipient(aCCOs(i))
   Next i
 
   'conectamos el servicio, enviamos el correo y nos desconectamos.
   service.Connect(server, mailUser)
   service.SendMailMessage(message)
   service.Disconnect()
End Sub
 
 
   ' ======= Extraer datos del adjunto desde el archivo ========
Function attachmentFromUrl(attachment, url) As Boolean
   Dim chunks() As String, fileName As String, fileService As Object, _
   attachmentFile As Object, fileContents() As Byte
 
   chunks() = Split(url, "/")
   fileName = ConvertFromURL(chunks(UBound(chunks()))
 
   fileService = CreateUNOService("com.sun.star.ucb.SimpleFileAccess")
   attachmentFile = fileService.OpenFileRead(url)
   attachmentFile.ReadBytes(fileContents(), (attachmentMaxSize*1024) + 1)
   attachmentFile.CloseInput
 
   If (UBound(fileContents()) + 1 > (attachmentMaxSize*1024)) Then
      Aviso "El archivo adjunto '" & fileName & "' supera el tamaño máximo"
      Exit Function
   ElseIf (UBound(fileContents()) < 0) Then
      Aviso "El archivo adjunto '" & fileName & "' está vacío"
      Exit Function
   End If
 
   attachmentContents = CreateUNOValue( "[]byte", fileContents())
   attachment = CreateObject("com.sun.star.mail.MailAttachment")
   attachment.Data = CreateUNOListener("attachment_", "com.sun.star.datatransfer.XTransferable")
   attachment.ReadableName = fileName
 
   attachmentFromUrl = True
End Function
 
 
   ' ===== Propiedades del servidor =====
Function smtp_GetValueByName(what)
   Select Case what
   Case "ServerName"
      smtp_GetValueByName = smtpServer
   Case "Port"
      smtp_GetValueByName = smtpPort
   Case "ConnectionType"
      If smtpSecure Then
         smtp_GetValueByName = "SSL"
      Else
         smtp_GetValueByName = "Insecure"
      EndIf
   End Select
End Function
 
 
   ' ====== Métodos del usuario =======
Function user_GetUserName()
   user_GetUserName = smtpUser
End Function
 
 
Function user_GetPassword()
   user_GetPassword = smtpPassword
End Function
 
 
   ' ====== Métodos del objeto cuerpo del mensaje ======
Function body_GetTransferDataFlavors()
   Dim flavor As New com.sun.star.datatransfer.DataFlavor
   flavor.MimeType = "text/plain;charset=utf-16"
   flavor.HumanPresentableName = "Unicode text"
   body_GetTransferDataFlavors = Array(flavor)
End Function
 
 
Function body_GetTransferData(flavor) As any
   If (flavor.MimeType = "text/plain;charset=utf-16") Then
      body_GetTransferData = messageBody
   End If
End Function
 
 
Function body_isDataFlavorSupported(x As Object)
   body_isDataFlavorSupported = (x.MimeType = "text/plain;charset=utf-16")
End Function
 
 
   ' ====== Métodos del objeto adjuntado ======
Function attachment_GetTransferDataFlavors()
   Dim flavor As New com.sun.star.datatransfer.DataFlavor
   flavor.MimeType = attachmentType
   flavor.HumanPresentableName = attachmentType
   attachment_GetTransferDataFlavors = Array(flavor)
End Function
 
 
Function attachment_GetTransferData(flavor) As any
   If (flavor.MimeType = attachmentType) Then
      attachment_GetTransferData = attachmentContents
   End If
End Function
 
 
Function attachment_isDataFlavorSupported(x As Object)
   attachment_isDataFlavorSupported = (x.MimeType = attachmentType)
End Function