Patricio:
Te paso un código que a mi me funciona bastante bien. Es para trabajr con Outlook.
Fijate y cualquier cosa, avisame. Te dejo mi mail:
[email protected]
Lo único que tienes que hacer es agregar un botón en la hoja de Excel que quieras y asignarle la "Macro_Inicio".
Espero te sirva. Saludos,
Gonzalo
Sub Macro_Inicio()
On Error GoTo Err_Macro_Inicio
Dim CUERPO_MENSAJE As String
Dim TITULO_MENSAJE As String
Dim ADJUNTO_MENSAJE As String
Dim EMAIL_LEGAJO As String
'PASO 0: No muestra las alertas
Application.DisplayAlerts = False
'PASO 1: POSICIONARME EN EL 1ER. LEGAJO
Range("A2").Select
'PASO 2: Mientras tenga algun legajo escrito que le envie email
While ActiveCell.Offset(0, 0).Value <> ""
'PASO 2.2: Guardo el nro de legajo
NOMBRE_LEGAJO = ActiveCell.Offset(0, 0).Value
EMAIL_LEGAJO = ActiveCell.Offset(0, 1).Value
'PASO 2.3: Me muevo a otro archivo
'GRABAR COMO DRAFT EN EMAIL OUTLOOK
CUERPO_MENSAJE = "Buenos días" & Chr(13) & _
"Le hago llegar el informe... " & Chr(13) & _
"Muchas gracias"
TITULO_MENSAJE = "Informe Mensual " & NOMBRE_LEGAJO
ADJUNTO_MENSAJE = "C:\Documents and Settings\gquintana\Escritorio\Excel y Macros.pdf"
Call Enviar_Email_Outlook(EMAIL_LEGAJO, TITULO_MENSAJE, CUERPO_MENSAJE, ADJUNTO_MENSAJE)
'PASO 2.4: Me muevo al siguiente legajo
ActiveCell.Offset(1, 0).Select
Wend
'PASO 3: Avisar que termino de ejecutar
Application.DisplayAlerts = True
MsgBox "La macro se ejecuto correctamente.", vbOKOnly + vbInformation, "Ejecucación Macros"
Exit Sub
Err_Macro_Inicio:
Resume Next
End Sub
Sub Enviar_Email_Outlook(EMAIL_PARA As String, EMAIL_TITULO As String, EMAIL_CUERPO As String, EMAIL_ADJUNTO As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = EMAIL_PARA
.CC = ""
.BCC = ""
.Subject = EMAIL_TITULO
.Body = EMAIL_CUERPO
'recorro el directorio del EMAIL_ADJUNTOmanager para agregar cada uno de los archivos excel
.Attachments.Add EMAIL_ADJUNTO
.Save 'Lo graba como draft (sino usar .Send para enviar el email directamente)
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub