Saltar al contenido

VBScript – Adjuntar archivos automáticamente y enviar correo Outlook

La función del siguiente VBScript es adjuntar un archivo o archivos automáticamente en base a la búsqueda de una serie de dígitos en el nombre del archivo y enviarlos por correo electrónico.

Instrucciones de Uso

1.- Abrir el editor de Visual Basic (ALT+F11).

2.- Insertar un modulo nuevo (Insert > Module).

3.- Copiar el código VBScript.

4.- Realizamos las modificaciones necesarias tal como ruta donde se guardan los archivos, las lineas que modificaremos son las: 17, 35 a la 39.

5.- Ejecutamos con la tecla F5

6.- Cuando lo ejecutemos nos mostrara una ventana donde capturamos el dato a buscar (Detecta mayúsculas y minúsculas).VBScript - Adjuntar archivos automáticamente y enviar correo Outlook

6.- Una vez que demos OK para la búsqueda, nos abrirá un correo con los adjuntos encontrados y el cuerpo de correo que hayamos especificado.VBScript - Adjuntar archivos automáticamente y enviar correo Outlook

Otro ejemplo donde se adjuntan todos los archivos que contienen el numero 347.

VBScript - Adjuntar archivos automáticamente y enviar correo Outlook

7.- Podemos enviar después de revisar el correo, si deseamos que se envíe automáticamente se pusieron comentarios en las lineas 38 y 39 del código.

Para mas información de configuración ver: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript) y Outlook – Crear y configurar reglas

Código

Sub AttachFilesbyEmailAutomatically()

Dim fldName As String
Dim fName As String
Dim sAttName As String
Dim strName As String

Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments
 
Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0)
Set olAtt = olMsg.Attachments

'Ruta donde se guardan los archivos
fldName = "C:\1-Tests\"

fName = dir(fldName)

strName = InputBox("Digito contenido")

 Do While Len(fName) > 0
  
  If InStr(fName, strName) > 0 Then
    olAtt.Add fldName & fName
    sAttName = fName & "-" & sAttName
   End If
   fName = dir
Loop

 
' send message
With olMsg
  .Subject = "Se adjuntan archivos solicitados"
  .To = "[email protected]"
  .HTMLBody = "Buen dia! " & olMsg.To & ",  Se adjuntan los archivos: " & sAttName & " en base a lo solicitado."
  .Display ' Marcar como comentario para envio automatico
  '.Send ' Desmarcar para envio automatico
End With
 

End Sub

Código basado en codigo de Diane Poremsky y modificado a solicitud de morpvin.

Entradas relacionadas

Deja 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.

Comentarios (29)

Esta perfecto pero claro, si me pregunta la extension o los datos no es del todo automatico, me puedes indicar que puedo cambiar para que no pregunte e incluir directamente la seleccion en el script, es decir que seleccione la extension que necesito pero fija en el script, gracias y perdona tanta molestia. Un Saludo.

Responder

Buen dia morpvin

En la linea 21 puedes modificar la instrucción: strName = “Texto”

Saludos.

Responder

Das cursos??

Responder

Buen dia Any

No tengo cursos por el momento, lo que publico aquí son cosas que voy requiriendo para el trabajo.

Que tengas excelente dia.

Responder

Me fue muy útil tu artículo!!! Justo lo que andaba buscando, mil gracias!!!!!!

Responder

Buen dia Any

Me alegra que te haya funcionado. Gracias por el buen comentario

Excelente dia.

Responder

Buenas tardes

Muy buen artículo, aun soy nuevo en esto del VBSript y queria ver si existe la posibilidad de anexar la fecha en el nombre del archivo a adjuntar, por ejemplo

strName = “Archivo” & Date

Saludos!

Responder

Buen dia Ricardo

El cambio no se puede realizar implícitamente sobre el archivo que yo conozca, se debe renombrar antes de adjuntar o adjuntar los archivos, guardar y adjuntar nuevamente.
Si gustas te puedo apoyar mas adelante con el proceso, lo pongo en mis scripts pendientes.

Excelente dia

Responder

fernando muy bueno, pero tengo una duda!

si mi sistema genera diario a determinada hora una carpeta con archivos *.csv y quiero enviar esos archivos diario a una dirección de correo. las carpetas que genera llevan en siguiente nombre “2017-07-17 07_00_18” donde es la fecha y la hora que fue generada y dentro de esa carpeta están 4 archivos CVS.

1. como podría realizar que tome los archivos del día?
2 como realizar que esta macro la haga a determinada hora?

Gracias.

saludos

Responder

Buen dia GReynoso

Puedes jugar un poco con este script, agregue que te genere en la ruta la fecha y hora en el formato que indicas, mas puedes tener variación en los segundos

Sub AttachFilesbyEmailAutomatically()

Dim fldName As String
Dim fName As String
Dim sAttName As String
Dim strName As String

Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments

Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0)
Set olAtt = olMsg.Attachments
Dim dDate \'Agregado
dDate = timeStamp() \'Agregado

\'Ruta donde se guardan los archivos
fldName = \"C:1-Tests\" & dDate & \"\" \'Modificado

fName = Dir(fldName)

strName = \"csv\"\'InputBox(\"Digito contenido\") \'Modificado

Do While Len(fName) > 0

If InStr(fName, strName) > 0 Then
olAtt.Add fldName & fName
sAttName = fName & \"-\" & sAttName
End If
fName = Dir
Loop

\' send message
With olMsg
.Subject = \"Se adjuntan archivos solicitados\"
.To = \"[email protected]\"
.HtmlBody = \"Buen dia! \" & olMsg.To & \", Se adjuntan los archivos: \" & sAttName & \" en base a lo solicitado.\"
.Display \' Marcar como comentario para envio automatico
\'.Send \' Desmarcar para envio automatico
End With

End Sub

Function timeStamp() \'Agregado
timeStamp = Year(Now) & \"-\" & _
Right(\"0\" & Month(Now), 2) & \"-\" & _
Right(\"0\" & Day(Now), 2) & \" \" & _
Right(\"0\" & Hour(Now), 2) & \"_\" & _
Right(\"0\" & Minute(Now), 2) & \"_\" & _
Right(\"0\" & Second(Now), 2)
End Function

Outlook no cuenta con la función de ejecutar el script cuando se indique pero existe la forma de hacer lo mediante otro script desde ThisOutlookSession que se ejecuta por medio de los recordatorios de tareas.

Private Sub Application_Reminder(ByVal Item As Object)
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)

\'IPM.TaskItem para buscar recordatorio de tareas
If Item.MessageClass \"IPM.Appointment\" Then
Exit Sub
End If
\'Compara si el recordatorio es de la categoria ejecutar script, si no se asigna este el script se ejecutara en cualquier notificación.
If Item.Categories \"ejecutar script\" Then
Exit Sub
End If

\'AQUÍ VA TU CÓDIGO

End Sub

Excelente dia

Responder

Buenas tardes

Responder

muchas gracias fernando me es muy util, quiciera preguntarte que deberia hacer para que me adjunte archivos de distintas rutas, o con distintas “busquedas” por ejemplo que me agreara todos los “.pdf” pero tambien todos los “.txt”

Responder

Buen dia Siconomik

Agregue un arreglo para la busqueda en diferentes carpetas.

Sub AttachFilesbyEmailAutomatically()

Dim fldName()
Dim fName As String
Dim sAttName As String
Dim strName As String

Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments

Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0)
Set olAtt = olMsg.Attachments

strName = InputBox(\"Digito contenido\")
\'Ruta donde se guardan los archivos separar con comas
fldName = Array(\"C:1-Tests\", \"C:1-Tests2\")

For i = 0 To UBound(fldName)
fName = Dir(fldName(i))

Do While Len(fName) > 0

If InStr(fName, strName) > 0 Then
olAtt.Add fldName(i) & fName
sAttName = fName & \"\" & sAttName
End If
fName = Dir
Loop
Next

\' send message
With olMsg
.Subject = \"Se adjuntan archivos solicitados\"
.To = \"[email protected]\"
.HtmlBody = \"Buen dia! \" & olMsg.To & \", Se adjuntan los archivos: \" & sAttName & \" en base a lo solicitado.\"
.Display \' Marcar como comentario para envio automatico
\'.Send \' Desmarcar para envio automatico
End With

End Sub

Excelente dia

Responder

Buena tardes

Gracias por contestar a mi comentario.

Ya realice los cambios pero aun no puedo adjuntar los archivos “csv” ya que según entiendo en:

Function timeStamp() ‘Agregado
timeStamp = Year(Now) & “-” & _
Right(“0” & Month(Now), 2) & “-” & _
Right(“0″ & Day(Now), 2) & ” ” & _
Right(“0” & Hour(Now), 2) & “_” & _
Right(“0” & Minute(Now), 2) & “_” & _
Right(“0” & Second(Now), 2)
End Function

esta tomando Hour, minute, second, del momento en el que se ejecuta el VBScript.

Existe alguna manera de que solo reconozca las fecha y la hora la omita o que solo tome las archivos de las carpetas generadas ese día?

Gracias.

saludos

Responder

Buen dia GREYNOSO

Prueba el siguiente código.

Sub AttachFilesbyEmailAutomatically()

Dim fldName As String
Dim fName As String
Dim sAttName As String
Dim strName As String

Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments

Dim fs, f, f1, fc, s

Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0)
Set olAtt = olMsg.Attachments
Dim dDate \'Agregado
dDate = timeStamp() \'Agregado

\'Ruta donde se guardan los archivos
fldName = \"C:1-Tests\" \'& dDate & \"\" \'Modificado

\'Se busca el nombre de la subcarpeta que contenga la fecha del dia
Set fs = CreateObject(\"Scripting.FileSystemObject\")
Set f = fs.GetFolder(fldName)
Set fc = f.SubFolders
Set fc = f.SubFolders
For Each f1 In fc
If InStr(UCase(f1), UCase(dDate)) Then
fldName = f1 & \"\"
End If
Next

fName = Dir(fldName)

strName = \"xls\" \'InputBox(\"Digito contenido\") \'Modificado Se indica el tipo de archivo

\'Se buscan los archivos que cumplan con el formato indicado anteriormente
Do While Len(fName) > 0

If InStr(fName, strName) > 0 Then
olAtt.Add fldName & fName
sAttName = fName & \"-\" & sAttName
End If
fName = Dir
Loop

\'Se crea nuevo mensaje de correo con los archivos adjuntos seleccionados
With olMsg
.Subject = \"Se adjuntan archivos solicitados\"
.To = \"[email protected]\"
.HTMLBody = \"Buen dia! \" & olMsg.To & \", Se adjuntan los archivos: \" & sAttName & \" en base a lo solicitado.\"
.Display \' Marcar como comentario para envio automatico
\'.Send \' Desmarcar para envio automatico
End With

End Sub

\'Funcion para tomar la fecha y hora actual
Function timeStamp() \'Agregado
timeStamp = Year(Now) & \"-\" & _
Right(\"0\" & Month(Now), 2) & \"-\" & _
Right(\"0\" & Day(Now), 2) \'& \" \" & _
\'Right(\"0\" & Hour(Now), 2) & \"_\" & _
\'Right(\"0\" & Minute(Now), 2) & \"_\" & _
\'Right(\"0\" & Second(Now), 2)
End Function

Excelente dia, recuerda seguirnos en las redes sociales para que te mantengas al dia de nuestros artículos.

Responder

Amigo funciono perfecto!!!!

Muchas gracias.

Solo me resta que se ejecute automáticamente a determinada hora. aun no pruebo el otro código lo pruebo y te comento.

Muchas gracias!

Responder

Excelente.

Buen día GREYNOSO

Responder

Hola Fernando.
no consigo que me funcione tu script. le pongo mi ruta de acceso donde buscar y no adjunta nada.
lo que yo necesito es un script que busque en dos carpetas diferentes los pdf con un mismo numero y me los adjunte en un mensaje.
gracias de antemano por tu tiempo.

Responder

Buen dia Abel

Primero hay que asegurarnos que puedes ejecutar el script, puedes realizar una prueba con el siguiente

Public Sub Prueba()
msgbox (\"Hola\")
Next

Te debe mostrar un mensaje Hola cuando se ejecute

Si no revisa los siguientes artículos: Utilizar Macros y Crear y configurar reglas

Excelente dia

Responder

hola. si me funciona ese. gracias

Responder

Hola, el código inicial funciona perfecto, pero quiero que outlook corra esta tarea a diario a las 10 y media de la mañana automáticamente pero no lo consigo.. no entiendo la parte de ingresar el código en ThisOutlookSession no se donde configurar la hora de envío del correo, de antemano muchas gracias por la ayuda que me puedas brindar

Responder

Buen dia Luis

ThisOutlookSession se encuentra en el mismo editor (adjunto imagen)

Añades el código especificado y agregas el código que deseas ejecutar donde dice AQUI VA TU CODIGO

Private Sub Application_Reminder(ByVal Item As Object)
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)

\'IPM.TaskItem para buscar recordatorio de tareas
If Item.MessageClass \"IPM.Appointment\" Then
Exit Sub
End If
\'Compara si el recordatorio es de la categoria ejecutar script, si no se asigna este el script se ejecutara en cualquier notificación.
If Item.Categories \"ejecutar script\" Then
Exit Sub
End If

\'AQUÍ VA TU CÓDIGO

End Sub

Después creas en el calendario Evento con el horario deseado o puede ser tareas (para usar tareas remplaza IPM.Appointment por IPM.TaskItem) y en la linea If Item.Categories “ejecutar script” Then debes ingresar el nombre que le diste al evento o tarea en mi caso se llama ejecutar script.

Excelente dia.

Responder

Hola Fernando, muchas gracias
Aunque no lo logre con las propiedades MessageClass y Categories, si lo logre unicamente configurando la propiedad Item.Subject que es la que lee el asunto de la tarea o evento.. claro.. asegurandome de que el nombre que le ponga no se vaya a repetir para evitar ejecuciones adicionales. Mi códio finalmente quedo asi:

Private Sub Application_Reminder(ByVal Item As Object)

If Item.Subject “Ejecutar Script” Then
Exit Sub
End If

Call Enviar_Correo

MsgBox (“Se envio la base a la unidad correspondiente, por favor marcar la tarea como completada”)

End Sub

Enviar correo es la macro que anteriormete relacionas para enviar el mensaje con el adjunto la cual deje en un modulo aparte

Finalmente tengo una inquietud, quiero que la marca de esa tarea se marque como “Completada” para evitarme ese paso; he estado jugando con las propiedades, FlagRequest, Status y FlagStatus en donde despues de que el script determina que el asunto de la tarea es “Ejecutar Script” desecadene tambien el evento que la marque como completa despues de ejecutado el código que envia el correo. Aun no lo logro

Muchas gracias

Responder

Buen dia Luis

Tengo entendido que debe ser con FlagStatus = olFlagComplete.

Inténtalo en el código que ya tienes.

Excelente dia.

Responder

Hola Fernando
Probe el resultado con la opción “olFlagComplete” pero nada, me sale un mensaje que dice que “El objeto no admite esta propiedad o método”

Es lo unico que me falta para que mi macro sea totalmente automatica

Si me puedes ayudar con este problema te lo agradeceria mucho
Muchas gracias

Responder

Hola Fernando

Despues de intentar con la propiedad FlagStatus = olFlagComplete no me sirvio, estuve indagando y encontre la solución en estas 2 lineas

Item.Status = olTaskComplete
Item.Save

Mi macro ya quedo totalmente automática, muchas gracias por tu ayuda

Responder

Buen dia Luis

Excelente me alegra leerlo y gracias por la retroalimentación.

Responder

Muy bueno ejemplos Fernado, este ejemplo el bucle podría ir enviando automáticamente cada uno de los archivos de correo en correo y no con todos los de la carpeta. Gracias.

Responder

Buen dia Manuel

Mete esta parte del codigo al ciclo.

\' send message
With olMsg
.Subject = \"Se adjuntan archivos solicitados\"
.To = \"[email protected]\"
.HTMLBody = \"Buen dia! \" & olMsg.To & \", Se adjuntan los archivos: \" & sAttName & \" en base a lo solicitado.\"
.Display \' Marcar como comentario para envio automatico
\'.Send \' Desmarcar para envio automatico
End With

Adjuntara uno a uno y enviara por correo.

Excelente dia.

Responder
Leer entrada anterior
Windows 10 - El explorador de archivos carga lento los archivos de la carpeta
Windows 10 – El explorador de archivos carga lento los archivos de la carpeta

Windows 10 ha presentado algunos errores desde su lanzamiento el cual muchos de estos no se conoce el motivo por el...

Cerrar