Ejercicio práctico 8: Cómo enviar automáticamente un informe por email (Lotus) mediante macros.

Escrito por Administrador

25 de agosto de 2021

Ya estamos prácticamente al final del curso, y lejos quedan esos comienzos con macros de tan solo diez líneas de código.

Hoy vamos a darle una vuelta de tuerca al ejercicio práctico 5, donde veíamos cómo filtrar los registros de una tabla, repartiéndolos en varias hojas mediante macros. En él, repartíamos los registros de un listado en distintas hojas, en función de uno o más criterios.

total-operaciones-matematicas-macros

¿Cuál sería el siguiente paso? Es obvio que una vez tenemos la información clasificada, lo interesante es hacérsela llegar a cada responsable para que actué en consecuencia, y qué mejor manera que hacerlo a través de correo electrónico y mediante un procedimiento totalmente automático.

La idea es que, al pulsar un nuevo botón, se envíen tres correos electrónicos a tres grupos de destinatarios diferentes, uno por cada hoja clasificada. Cada correo contendrá la información de un solo grupo, por lo que será necesario que se generen automáticamente dichos archivos individuales previo al envío.

¿Complicado? ¡No! Lo vemos.

El código de las macros es el siguiente:

Macro 1. Generación de informes de materiales según grupo de trabajo.

Sub Informe()

'Desactivamos el refresco de pantalla para agilizar la macro

Application.ScreenUpdating = False

'Buscamos la última fila con datos de cada hoja

Sheets("Grupo 1").Select

filagrupo1 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

Sheets("Grupo 2").Select

filagrupo2 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

Sheets("Grupo 3").Select

filagrupo3 = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'Recorremos los registros de la tabla y repartiéndolos en el resto de hojas en función del grupo de trabajo

Sheets("Informe").Select

f = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

For i = 2 To f

Sheets("Informe").Select

'Si pertenece al GRUPO 1

If Cells(i, "K") = 1 Then

Range(Cells(i, "A"), Cells(i, "K")).Select

Selection.Copy

Sheets("Grupo 1").Select

Cells(filagrupo1, "A").Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks _
:=False, Transpose:=False

filagrupo1 = filagrupo1 + 1

goto salto

End If

'Si pertenece al GRUPO 2

If Cells(i, "K") = 2 Then

Range(Cells(i, "A"), Cells(i, "K")).Select

Selection.Copy

Sheets("Grupo 2").Select

Cells(filagrupo2, "A").Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks _
:=False, Transpose:=False

filagrupo2 = filagrupo2 + 1

goto salto

End If

'Si pertenece al GRUPO 3

If Cells(i, "K") = 3 Then

Range(Cells(i, "A"), Cells(i, "K")).Select

Selection.Copy

Sheets("Grupo 3").Select

Cells(filagrupo3, "A").Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks _
:=False, Transpose:=False

filagrupo3 = filagrupo3 + 1

End If

salto:

Next

'Calculamos el importe total de cada grupo, dos filas más abajo del último registro

'GRUPO 1

Sheets("Grupo 1").Select

totalizar = Application.WorksheetFunction.Sum(Range(Cells(2, "E"), Cells(filagrupo1, "E")))

Cells(filagrupo1, "E") = totalizar

Cells(filagrupo1, "E").Select

With Selection

.HorizontalAlignment = xlCenter

End With

Selection.Font.Bold = True

'GRUPO 2

Sheets("Grupo 2").Select

totalizar = Application.WorksheetFunction.Sum(Range(Cells(2, "E"), Cells(filagrupo2, "E")))

Cells(filagrupo2, "E") = totalizar

Cells(filagrupo2, "E").Select

With Selection

.HorizontalAlignment = xlCenter

End With

Selection.Font.Bold = True

'GRUPO 3

Sheets("Grupo 3").Select

totalizar = Application.WorksheetFunction.Sum(Range(Cells(2, "E"), Cells(filagrupo3, "E")))

Cells(filagrupo3, "E") = totalizar

Cells(filagrupo3, "E").Select

With Selection

.HorizontalAlignment = xlCenter

End With

Selection.Font.Bold = True

'Llamamos a la macro para ordenar el informe

Call Ordenfinal

'Abrimos la hoja Grupo 1

Sheets("Informe").Select

'Activamos el refresco de pantalla

Application.ScreenUpdating = True

End Sub

Macro 2. Borrado de informes de materiales.

Sub Borrar()

'Desactivamos el refresco de pantalla para agilizar la macro

Application.ScreenUpdating = False

'Mostramos mensaje de aviso porque se borrarán datos

resultado = MsgBox("¿Seguro? Se perderán los cálculos", vbYesNo + vbExclamation, "Advertencia")

Select Case resultado

Case vbNo:

GoTo final

End Select

'Borramos los datos de las hojas de Grupos

Sheets("Grupo 1").Activate

Range("A2:K500").ClearContents

Sheets("Grupo 2").Activate

Range("A2:K500").ClearContents

Sheets("Grupo 3").Activate

Range("A2:K500").ClearContents

'Volvemos a la hoja Informe

Sheets("Informe").Activate

final:

'Desactivamos el refresco de pantalla para agilizar la macro

Application.ScreenUpdating = True

End Sub

Macro 3. Ordenación de informes según importe descendente.

Sub Ordenfinal()

'Ordenamos las hojas de los grupos por el campo importe, de mayor a menor

'GRUPO 1

Sheets("Grupo 1").Select

filagrupo1 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Range(Cells(2, "A"), Cells(filagrupo1, "K")).Sort Key1:=Range("E:E"), Order1:=xlDescending, Header:=xlNo

'GRUPO 2

Sheets("Grupo 2").Select

filagrupo2 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Range(Cells(2, "A"), Cells(filagrupo2, "K")).Sort Key1:=Range("E:E"), Order1:=xlDescending, Header:=xlNo

'GRUPO 3

Sheets("Grupo 3").Select

filagrupo3 = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Range(Cells(2, "A"), Cells(filagrupo3, "K")).Sort Key1:=Range("E:E"), Order1:=xlDescending, Header:=xlNo

'Abrimos la hoja Grupo 1

Sheets("Grupo 1").Select

End Sub

La macro 1, que elabora el informe, es exactamente la misma que usamos en el ejercicio práctico 5, solo que he cambiado la penúltima instrucción:

Sheets("Grupo 1").Select

Por

Sheets("Informe").Select

Para que, al finalizar, aterricemos en la hoja “Informe” y podamos seguir pulsando botones.

Las macros 2 y 3 son las mismas que usamos en el ejercicio práctico 5.

Las novedades son las macros 4 y 5, que aportan la creación automática de los archivos y el envío de correos.

Macro 4. Creación automática de archivos y llamada a función de envío de correos automáticos (Lotus).

Sub Enviar()

'Macro para la creación de archivos individuales por grupo y envío de la información

'Desactivamos el refresco de pantalla

Application.ScreenUpdating = False

Dim wrkNuevo As Workbook

Dim hojasActual As Long

'Creamos un libro nuevo GRUPO 1

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo1.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(2).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 1"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo1.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Creamos un libro nuevo GRUPO 2

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo2.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(3).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 2"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo2.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Creamos un libro nuevo GRUPO 3

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo3.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(4).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 3"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo3.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Envío automático de emails

email "Gasto de materiales. Grupo1.", "correo1@vbatotal.com", "C:\Grupo1.xls"

email "Gasto de materiales. Grupo2.", Array("correo1@vbatotal.com", "correo2@vbatotal.com"), "C:\Grupo2.xls"

email "Gasto de materiales. Grupo3.", Array("correo1@vbatotal.com", "correo3@vbatotal.com"), "C:\Grupo3.xls"

'Activamos el refresco de pantalla

Application.ScreenUpdating = True

End Sub

Macro 5. Función para el envío de correos automáticos (Lotus).

Sub email(Subject, Recipient, Attachment)

'Función para el envío automático de correos

Dim Maildb As Object

Dim mailDoc As Object

Dim body As Object

Dim session As Object

'Iniciamos la sesión en Lotus

Set session = CreateObject("Notes.NotesSession")

'Abrimos la base de datos de Lotus

Set Maildb = session.GetDatabase("", "names.nsf")

If Not Maildb.IsOpen = True Then

Call Maildb.Open

End If

'Creamos un nuevo correo

Set mailDoc = Maildb.CreateDocument

Call mailDoc.ReplaceItemValue("Form", "Memo")

'Los destinatarios del correo están definidos en la llamada de la función

Call mailDoc.ReplaceItemValue("SendTo", Recipient)

'El asunto del correo está definido en la llamada de la función

Call mailDoc.ReplaceItemValue("Subject", Subject)

'Contenido del correo

Set body = mailDoc.CreateRichTextItem("Body")

Call body.AppendText("Buenos días,")

Call body.AddNewLine(2)

Call body.AppendText("Adjunto archivo con los gastos de materiales.")

Call body.AddNewLine(2)

Call body.AppendText("Saludos.")

'Adjuntos del correo

Call body.AddNewLine(4)

Call body.EmbedObject(1454, "", Attachment)

Call body.AddNewLine(2)

'Pie del correo

Call body.AddNewLine(2)

Call body.AppendText("Este es un correo automático.")

'Envío del correo

Call mailDoc.ReplaceItemValue("PostedDate", Now())

Call mailDoc.send(False)

'Limpiamos

Set Maildb = Nothing

Set mailDoc = Nothing

Set body = Nothing

Set session = Nothing

End Sub

Empecemos analizando la macro 4.

Como siempre, en primer lugar, desactivamos el refresco de pantalla y dimensionamos las nuevas variables para el libro nuevo que vamos a crear.

Sub Enviar()

'Macro para la creación de archivos individuales por grupo y envío de la información

'Desactivamos el refresco de pantalla

Application.ScreenUpdating = False

Dim wrkNuevo As Workbook

A continuación, seleccionamos el número de hojas que queremos que tenga nuestro nuevo libro,

Dim hojasActual As Long

'Creamos un libro nuevo GRUPO 1

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

creamos el nuevo libro,

'Creamos el libro

Set wrkNuevo = Workbooks.Add

y lo guardamos con el nombre “Grupo1.xls”

ActiveWorkbook.SaveAs Filename:="C:\Grupo1.xls", FileFormat:= _
xlNormal, CreateBackup:=False

Ahora copiamos la hoja 2 (Grupo 1) del libro 1 (Ejercicio practico 8.xlsx) detrás de la hoja 1 del nuevo libro,

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(2).Copy After:=Workbooks(2).Worksheets(1)

le damos el nombre “Grupo 1”,

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 1"

y borramos la hoja que trae por defecto el libro creado. Hemos desactivado las alertas para no tener que validar el borrado de la misma.

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

Enfocamos la primera celda del nuevo libro, lo guardamos y lo cerramos.

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo1.xls").Close Savechanges:=True

Application.DisplayAlerts = True

Aunque no veamos nada, ahora mismo tenemos el archivo de la imagen guardado en C:\> como “Grupo1.xls”.

Mismas operaciones con los grupos 2 y 3.

'Creamos un libro nuevo GRUPO 2

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo2.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(3).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 2"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo2.xls").Close Savechanges:=True

Application.DisplayAlerts = True

'Creamos un libro nuevo GRUPO 3

'Elegimos una sola hoja

Application.SheetsInNewWorkbook = 1

'Creamos el libro

Set wrkNuevo = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Grupo3.xls", FileFormat:= _
xlNormal, CreateBackup:=False

'Copiamos la hoja del Grupo 1

Workbooks(1).Worksheets(4).Copy After:=Workbooks(2).Worksheets(1)

Set Nombre = Worksheets(2)

Nombre.Name = "Grupo 3"

Application.DisplayAlerts = False

Worksheets("Hoja1").Delete

Application.DisplayAlerts = True

'Vamos cerrando

Cells(1, 1).Select

ActiveWindow.ScrollRow = Cells(1, "A").Row

ActiveWindow.ScrollColumn = Cells(1, "A").Column

Application.DisplayAlerts = False

Workbooks("Grupo3.xls").Close Savechanges:=True

Application.DisplayAlerts = True

Una vez creados los tres libros, tenemos que enviarlos por correo a sus respectivos destinatarios.

He creado una función llamada “email” que se encuentra en la macro 5 y nos facilita dicha operación, pasándole como parámetros el asunto del email, la lista de destinatarios y la ruta del archivo adjunto.

'Envío automático de emails

email "Gasto de materiales. Grupo1.", "correo1@vbatotal.com", "C:\Grupo1.xls"

email "Gasto de materiales. Grupo2.", Array("correo1@vbatotal.com", "correo2@vbatotal.com"), "C:\Grupo2.xls"

email "Gasto de materiales. Grupo3.", Array("correo1@vbatotal.com", "correo3@vbatotal.com"), "C:\Grupo3.xls"

'Activamos el refresco de pantalla

Application.ScreenUpdating = True

End Sub

Si miramos el cuadro de arriba, con el primer comando, por ejemplo, enviaremos un correo con el asunto “Gasto de materiales. Grupo 1” al destinatario “correo1@vbatotal.com” con el archivo adjunto ubicado en “C:\Grupo1.xls”.

Una vez dimensionamos las variables que vamos a utilizar, iniciamos sesión en Lotus,

Sub email(Subject, Recipient, Attachment)

'Función para el envío automático de correos

Dim Maildb As Object

Dim mailDoc As Object

Dim body As Object

Dim session As Object

'Iniciamos la sesión en Lotus

Set session = CreateObject("Notes.NotesSession")

y abrimos la base de datos si es que no lo está ya.

'Abrimos la base de datos de Lotus

Set Maildb = session.GetDatabase("", "names.nsf")

If Not Maildb.IsOpen = True Then

Call Maildb.Open

End If

A continuación, creamos un nuevo correo.

'Creamos un nuevo correo

Set mailDoc = Maildb.CreateDocument

Call mailDoc.ReplaceItemValue("Form", "Memo")

Los correos destinatarios han sido definidos a la hora de llamar a la función, y lo que hacemos es copiarlos en el apartado “sendTo” del nuevo correo creado.

'Los destinatarios del correo están definidos en la llamada de la función

Call mailDoc.ReplaceItemValue("SendTo", Recipient)

Con el asunto del correo pasa lo mismo. Ya está definido a la hora de llamar a la función y lo pasa al apartado correspondiente del nuevo correo.

'El asunto del correo está definido en la llamada de la función

Call mailDoc.ReplaceItemValue("Subject", Subject)

El cuerpo del correo si hay que introducirlo aquí, y no es más que el mensaje que queremos transmitir. En este caso “Buenos días, adjunto archivo con los gastos de materiales. Saludos”

'Contenido del correo

Set body = mailDoc.CreateRichTextItem("Body")

Call body.AppendText("Buenos días,")

Call body.AddNewLine(2)

Call body.AppendText("Adjunto archivo con los gastos de materiales.")

Call body.AddNewLine(2)

Call body.AppendText("Saludos.")

El comando Call body.AddNewLine(2) hace tantos saltos de renglón como número indicamos entre paréntesis. En este caso dos.

Llegamos al apartado de adjuntos. También los definimos al llamar a la función, así que simplemente los introduce en el apartado correspondiente del nuevo correo.

'Adjuntos del correo

Call body.AddNewLine(4)

Call body.EmbedObject(1454, "", Attachment)

Call body.AddNewLine(2)

Por último, introducimos en el pie de correo la frase “Este es un correo automático.” y ya lo tenemos listo.

'Pie del correo

Call body.AddNewLine(2)

Call body.AppendText("Este es un correo automático.")

Una vez cumplimentados todos los campos, realizamos el envío del mismo y limpiamos por si queremos enviar otro.

'Envío del correo

Call mailDoc.ReplaceItemValue("PostedDate", Now())

Call mailDoc.send(False)

'Limpiamos

Set Maildb = Nothing

Set mailDoc = Nothing

Set body = Nothing

Set session = Nothing

End Sub

Con esto llegamos al final de la vigésimo octava lección. Espero que te esté gustando el curso y que me plantees cualquier duda que te surja. También puedes proponerme macros que te interese desarrollar y las voy incluyendo en el temario, soy todo oídos. Nos vemos en el próximo capítulo.

Descarga el archivo del ejemplo

« EP7. Cómo usar Change e Intersect en macros.

EP9. Cómo imprimir informes con macros. »

0 comentarios

Enviar un comentario

Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.

Quizá te interese,

Contacto