VBScript – Guardar los Archivos Adjuntos en Carpetas Especificas Automáticamente Outlook

El siguiente VBScript crea una carpeta con el nombre del Asunto (Subject) y guarda los archivos adjuntos que contiene el correo automáticamente.

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.- En la linea 7 debemos especificar la ruta donde se guardaran los archivos.

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

Public Sub saveAttachToSpecificFolder(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim getSubject As String
Dim dDate As Date

destinationFolder = "C:1-Tests"
getSubject = itm.Subject
dDate = itm.ReceivedTime
ReplaceIllegalChars getSubject, "-"
saveFolder = destinationFolder & Format(dDate, "yyyy-mm-dd") & Format(dDate, "-hhnnss") & "-" & getSubject

'Objeto crear folder
Set fso = CreateObject("Scripting.FileSystemObject")
' Crear Folder
If Not fso.FolderExists(saveFolder) Then
Set objFolder = fso.Createfolder(saveFolder)
End If
 
     For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "" & objAtt.DisplayName
          Set objAtt = Nothing
     Next
End Sub
  
Private Sub ReplaceIllegalChars(getSubject As String, _
  sChr As String _
)
  getSubject = Replace(getSubject, "/", sChr)
  getSubject = Replace(getSubject, "", sChr)
  getSubject = Replace(getSubject, ":", sChr)
  getSubject = Replace(getSubject, "?", sChr)
  getSubject = Replace(getSubject, Chr(34), sChr)
  getSubject = Replace(getSubject, "<", sChr)
  getSubject = Replace(getSubject, ">", sChr)
  getSubject = Replace(getSubject, "|", sChr)
  getSubject = Replace(getSubject, "*", sChr)
End Sub