Inicio Soporte Técnico VBScript – Guarda los archivos adjuntos dentro de la carpeta del Remitente...

VBScript – Guarda los archivos adjuntos dentro de la carpeta del Remitente catalogado con fecha

3123
0

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

 

Te recomendamos  Como desactivar las actualizaciones de windows 10