VBScript para guardar automáticamente archivos adjuntos Outlook

Hace poco uno de nuestros clientes comenzó a enviar facturas electrónicas para realizar tramites por medio de correo electrónico, el cual envia aproximadamente 30 facturas por hora en correos separados cada una, el cual para la persona encargada de realizar sus tramites su trabajo se torno un tanto tedioso y le quitaba tiempo en estar guardando en la carpeta manualmente cada factura, el cual optamos por automatizar esto.

En la empresa optamos por utilizar Attachment Save Add-In de Sperry Software [Ver articulo], pero si no deseamos comprar un programa o solo necesitamos algo con mayor configuración podemos utilizar un Script en Visual Basic el cual cumple perfectamente la función de guardar automáticamente los archivos adjuntos que se reciben por correo electrónico en Outlook.

Configurando el VBScript en Outlook

Nota: 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.

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
5 (100%) 1 vote

Fernando O.

Soy analista de sistemas actualmente trabajo en una empresa con mas de 200 empleados que utilizan equipo de computo al cual se les da soporte en el departamento.
Uno de mis pasatiempos fuera de la empresa es escribir artículos para PortalMasTips donde documento los problemas, inquietudes y detalles interesantes que se presentan.
Compartir1
Twittear
+1
Compartir
Pin
Stumble