VBScript para guardar automáticamente archivos adjuntos Outlook

Desde que en las empresas y negocios se popularizo el envio de correos con archivos adjuntos surgió la necesidad de guardar o descargar los archivos adjuntos de estos correos; por ejemplo: en envío de las facturas electrónicas, en ocasiones recibimos cientos de facturas mensualmente, ¿te imaginas descargando y archivando una a una estas facturas?

Años atrás cuando trabajaba en el departamento de Sistemas de una compañía, desarrolle y adapte algunos scripts para automatizar esta tarea, bien ¿te gustaria descargar archivos adjuntos de Outlook automáticamente? a continuación te muestro como, así como varios escenarios posibles, Vas a ver muchos codigos, pero no te asustes busca el que mejor se ajuste a tus necesidades y ese es el que tendrás que utilizar.

Para descargar archivos adjuntos de Outlook automáticamente tienes dos opciones:

  1. Por medio de un VBScript para descargar archivos adjuntos Outlook el cual veremos en esta publicacion.
  2. Comprando una aplicación de terceros como Attachment Save Add-In de Sperry Software.

Te dejo un articulo sobre este software, para no extender mas esta mega publicación.

Leer:
Programa para guardar archivos adjuntos automáticamente Outlook (auto-guardar)

Configurando el VBScript para descargar archivos adjuntos en Outlook

Leer:
Outlook - Opción ejecutar un script (run a script) no aparece en las reglas
  • Es muy importante que tengamos la carpeta creada en el lugar que especificamos en el Script (Ejemplo en C:\XML o C:\Archivos [Que son los que se muestran en los ejemplos])create-folder
  • Ahora ya cada que nos llegue un correo que cumpla las condiciones especificadas en la configuración se ejecutara nuestro Script y descargara el archivo en la carpeta especifica.

Códigos VBScript para guardar automáticamente archivos adjuntos en Outlook

VBScript que guarda todos los archivos recibidos (Remplaza existentes del mismo nombre).

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Archivos\"
     For Each objAtt In itm.Attachments        
          objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName        
          Set objAtt = Nothing    
     Next
End Sub

VBScript que guarda todos los archivos recibidos (No remplaza existentes agrega la fecha al archivo).

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:\Archivos"
     For Each objAtt In itm.Attachments        
          objAtt.SaveAsFile saveFolder & "\" & dateFormat & " - "& objAtt.DisplayName       
          Set objAtt = Nothing    
     Next
End Sub

VBScript que guarda archivos de cierto peso (tamaño), por ejemplo para evitar que guarde las imágenes de las firmas de los remitentes.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Archivos"
     For Each objAtt In itm.Attachments
        If objAtt.Size > 5000 Then 'Ajustar el tamaño al peso para excluir los archivos en Bytes
              objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
          End If
     Next
End Sub

VBScript que guarda cierto tipo de archivo (Ejemplo: .xml y remplaza archivos del mismo nombre).

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\XML\"
     For Each objAtt In itm.Attachments        
    if InStr(objAtt.DisplayName, ".xml") Then
              objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
          end if
     Next
End Sub

VBScript que guarda varios tipos de archivos (Ejemplo: .xml y .pdf - remplaza archivos del mismo nombre).

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\XML\"
     For Each objAtt In itm.Attachments        
    if ((InStr(objAtt.DisplayName, ".xml") Or InStr(objAtt.DisplayName, ".pdf"))) Then
              objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
          end if
     Next
End Sub

VBScript que guarda cierto tipo de archivo (Ejemplo: .xml y No remplaza existentes agrega la fecha al archivo).

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:\XML\"
For Each objAtt In itm.Attachments        
              if InStr(objAtt.DisplayName, ".xml") Then
              objAtt.SaveAsFile saveFolder & "\" & dateFormat & " - "& objAtt.DisplayName
          end if    
     Next
End Sub

VBScript que guarda todos los archivos recibidos (No remplaza existentes agrega la fecha al archivo y Nombre de la persona quien lo envió "From / De").

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim getFrom
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
    getFrom = itm.senderName
saveFolder = "C:\Archivos\"
     For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "\" & dateFormat & " - " & getFrom & " - " & objAtt.DisplayName
          Set objAtt = Nothing
          Set itm = Nothing
     Next
End Sub

VBScript que guarda todos los archivos recibidos (No remplaza existentes agrega la fecha al archivo, Parte del Asunto (Subject))

En la linea 14 se utiliza Mid para extraer parte del subject este el primer numero indica a partir de que carácter comenzara a contar y el siguiente indica cuantos caracteres tomara.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim getSubject As String
dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:\Archivos\"
' get Subject
getSubject = itm.Subject
 
    For Each objAtt In itm.Attachments
      If InStr(UCase(objAtt.DisplayName), ".XML") Then
        ReplaceIllegalChars getSubject, "-"
        finalSubject = Mid(getSubject, 4, 12)
        objAtt.SaveAsFile saveFolder & dateFormat & " – " & finalSubject & " – " & objAtt.DisplayName
       End If
    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

VBScript guarda archivos adjuntos sin duplicar agregando un consecutivo (1), (2), etc. a los archivos repetidos.

Se debe especificar la ruta donde se guardaran los archivos en la linea 11.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim strFileName As String
Dim strNewName As String
Dim fso
Dim intExtlen As Integer
Dim strPre As String
Dim strExt As String
Set fso = CreateObject("Scripting.FileSystemObject")
saveFolder = "C:\1-Tests\"
	'Revisa los adjuntos
     For Each objAtt In itm.Attachments
        strFileName = objAtt.DisplayName
		'Revisa si existe el archivo en la carpeta destino
        If fso.fileexists(saveFolder & "\" & strFileName) = True Then
            strNewName = strFileName
            intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
			'Revisa la extension del archivo
            If InStrRev(strFileName, ".") > 0 Then
                    strExt = Right(strFileName, intExtlen)
                    strPre = Left(strFileName, Len(strFileName) - intExtlen)
                Else
                    strExt = ""
                    strPre = strFileName
                End If
			'Revisa que consecutivo asignar al nombre (1), (2), (3), etc.
            While fso.fileexists(saveFolder & "\" & strNewName) = True
                    w = w + 1
                    strNewName = strPre & Chr(40) & w & Chr(41) & strExt
                Wend
                ' Asignar el nuevo nombre
                strFileName = strNewName
                w = 0
            End If
          'Guardar archivo con nuevo nombre
          objAtt.SaveAsFile saveFolder & "\" & strFileName
          AttachmentCount = AttachmentCount + 1
          Set objAtt = Nothing
     Next
End Sub

 

VBScript Crea Carpeta con Nombre de Remitente y Guarda Adjuntos en la carpeta correspondiente.

En la linea 11 se especifica el folder raíz donde se guardaran las subcarpetas de cada remitente.

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

    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
    getFrom = itm.senderName
    saveFolder = "C:\Archivos\" & getFrom & "\"

If Not oFSO.FolderExists(saveFolder) Then
  oFSO.CreateFolder saveFolder
End If

     For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "\" & dateFormat & " - " & objAtt.DisplayName
          Set objAtt = Nothing
          Set itm = Nothing
     Next
End Sub

VBScript Crea Carpeta con Nombre del Dominio del Remitente (Sin Extencion .com, .es, .mx, etc) y Guarda Adjuntos en esta Carpeta

En linea 15 se especifica la ruta del folder raiz donde se almacenan los adjuntos.

Nota: Se debe ajustar domain = Left(sDomain, InStr(1, sDomain, ".", 1) - 1) cuando crea nombres incorrectos cuando el dominio cuenta con mas de un punto.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim getFrom As String
Dim sDomain As String
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")

    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
    getFrom = itm.SenderEmailAddress
    sDomain = Right(getFrom, (Len(getFrom) - InStr(1, getFrom, "@", 1)))
    domain = Left(sDomain, InStr(1, sDomain, ".", 1) - 1)
    
    saveFolder = "C:\1-Tests\" & domain & "\"

If Not oFSO.FolderExists(saveFolder) Then
  oFSO.CreateFolder saveFolder
End If

     For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "\" & dateFormat & " - " & objAtt.DisplayName
          Set objAtt = Nothing
          Set itm = Nothing
     Next
End Sub
Califica este Articulo

Artículos Recientes

PortalMasTips
Copyright © PortalMasTips - Mapa del Sitio
linkedin facebook pinterest youtube rss twitter instagram facebook-blank rss-blank linkedin-blank pinterest youtube twitter instagram