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:
- Por medio de un VBScript para descargar archivos adjuntos Outlook el cual veremos en esta publicacion.
- 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.
Configurando el VBScript para descargar archivos adjuntos en Outlook
- Primeramente debemos copiar el script en el editor de Visual Basic de Outlook; Mas información ver: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript).
- Se debe crear la regla con las condiciones para ejecutar el script; Mas informacion ver: Outlook – Crear y configurar 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])
- 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 SubVBScript 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 SubVBScript 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 SubVBScript 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 SubVBScript 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 SubVBScript 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 SubVBScript 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 SubVBScript 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 SubVBScript 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 SubVBScript 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
