El siguiente VBScript es una variante de los publicados en el articulo “VBScript para guardar automáticamente archivos adjuntos Outlook.” Este VBScript crea una carpeta para cada remitente y va catalogando los archivos adjuntos dentro de carpetas por fecha.
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.- Guardamos y básicamente podria ser lo único requerido, pero podemos editar la ruta donde se crearan los directorios en la linea 11.
5.- Ahora debemos crear la regla que ejecute el Script cuando cumpla las condiciones.
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 saveAttachtoDisk(itm As Outlook.MailItem) Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim dateFormat Dim getFrom Dim oFSO Set oFSO = CreateObject("Scripting.FileSystemObject") Set objShell = CreateObject("Wscript.Shell") dateFormat = Format(Now, "yyyy-mm-dd H-mm") getFrom = itm.SenderName saveFolder = "C:Archivos" & getFrom & "" & dateFormat & "" If Not oFSO.FolderExists(saveFolder) Then CreateDirs saveFolder End If For Each objAtt In itm.Attachments objAtt.SaveAsFile saveFolder & objAtt.DisplayName Set objAtt = Nothing Set itm = Nothing Next End Sub Sub CreateDirs(MyDirName) Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild Set objFSO = CreateObject("Scripting.FileSystemObject") strDir = objFSO.GetAbsolutePathName(MyDirName) arrDirs = Split(strDir, "") If Left(strDir, 2) = "\" Then strDirBuild = "\" & arrDirs(2) & "" & arrDirs(3) & "" idxFirst = 4 Else strDirBuild = arrDirs(0) & "" idxFirst = 1 End If For i = idxFirst To UBound(arrDirs) strDirBuild = objFSO.BuildPath(strDirBuild, arrDirs(i)) If Not objFSO.FolderExists(strDirBuild) Then objFSO.CreateFolder strDirBuild End If Next Set objFSO = Nothing End Sub