VBScript – Adjuntar archivos automáticamente y enviar correo Outlook

Publicidad +
Publicidad +
Publicidad +
Publicidad +

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

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.

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

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.

Califica este articulo

Fernando O.

Soy analista de sistemas actualmente trabajo en una empresa con mas de 200 empleados que utilizan equipo de computo al cual se les da soporte en el departamento.
Uno de mis pasatiempos fuera de la empresa es escribir artículos para PortalMasTips donde documento los problemas, inquietudes y detalles interesantes que se presentan.

17 comentarios en “VBScript – Adjuntar archivos automáticamente y enviar correo Outlook

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

  2. 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!

    • 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

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

    • 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

  4. 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”

    • 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

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

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

Deja un comentario...

Compartir
Twittear
+1
Compartir
Pin
Stumble