VBScript – Imprimir adjunto automáticamente al momento de recibir un correo en Outlook

El siguiente VBScript imprime adjuntos automáticamente al momento de recibir un correo en Outlook, se puede especificar las extensiones del tipo de archivo que se desea imprimir, de quien o que tipo de correos se van a imprimir los adjuntos.

Instrucciones

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

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

3.- Copiar el codigo VBScript.

4.- Para hacer uso de este debemos crear 2 directorios (Carpetas) el cual especificaremos la ruta en las lineas 12, 25 y 30 del código; debemos prestar cuidado cuando la ruta se escribe con al final o no.

5.- En la linea 14 debemos especificar la extensión de los archivos en el actual se especificaron DOC, DOCX, PDF y TXT; Si realizas cambios es importante poner en mayúsculas las extensiones, tambien se pueden agregar o quitar, para eliminar debes eliminar Or InStr(UCase(objAtt.DisplayName), “.DOCX”)  

6.- Si deseamos que se eliminen (O se tiene problema con archivos repetidos) los archivos que se imprimen debemos quitar el apostrofe de la linea 30.

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

Proceso

El código realiza el siguiente proceso.

1. Al recibir correo revisa si contiene adjuntos.
2. Si contiene adjuntos revisa las extensiones de estos.
3. Si alguno de los especificados se encuentra se extrae ruta y nombre del archivo.
4. Lo guarda en el folder temporal C:Imprimir (Este se puede modificar).
5. Envia a imprimir el documento
6. Mueve el archivo a la carpeta C:ImprimirImpresos
7. Hasta finalizar con los archivos adjuntos.

Código

Public Sub ToPrintAttachments(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim FullFileName As String
Dim objFSO As Object
Dim WScript As Object
Dim dteWait
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WScript = CreateObject("WScript.Shell")
Set objShell = CreateObject("Shell.Application")
 
saveFolder = "C:Imprimir"
For Each objAtt In itm.Attachments
    If ((InStr(UCase(objAtt.DisplayName), ".DOC") Or InStr(UCase(objAtt.DisplayName), ".DOCX") Or InStr(UCase(objAtt.DisplayName), ".TXT") Or InStr(UCase(objAtt.DisplayName), ".PDF"))) Then
              FullFileName = saveFolder & "" & objAtt.DisplayName
              objAtt.SaveAsFile (FullFileName)
              'printAttachments saveFolder
              Set objFolder = objShell.NameSpace(0)
              Set printItem = objFolder.ParseName(FullFileName)
              printItem.InvokeVerbEx ("Print")
                ' delay before move and delete
              dteWait = DateAdd("s", 5, Now())
              Do Until (Now() > dteWait)
              Loop
                objFSO.MoveFile "C:Imprimir*", "C:Impresos"
                ' delay before move and delete
              dteWait = DateAdd("s", 5, Now())
              Do Until (Now() > dteWait)
              Loop
                'Desmarcar la linea siguiente para eliminar los archivos temporales (quitar apostrofe)
                objFSO.DeleteFile ("C:Impresos*")
                ' delay before finish
              dteWait = DateAdd("s", 5, Now())
              Do Until (Now() > dteWait)
              Loop
    End If
Next
End Sub