Ayuda InFaCont

En términos generales, puede guardar todos los archivos adjuntos de un correo electrónico haciendo clic en Archivos adjuntos > Guardar todos los archivos adjuntos en Perspectiva. Pero, si necesita guardar todos los archivos adjuntos de todos los correos electrónicos recibidos y recibir correos electrónicos, ¿alguna idea? Este artículo presentará dos soluciones para descargar automáticamente archivos adjuntos de Outlook a una carpeta determinada

Descargue Automáticamente Los Archivos Adjuntos De Outlook A La Carpeta Con VBA Y La Regla

Este método introducirá un script VBA y ejecutará este script con una regla para descargar y guardar automáticamente los archivos adjuntos de Outlook en una carpeta determinada. Haz lo siguiente:

VBA: guardado automático de archivos adjuntos de Outlook en una carpeta determinada

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Facturacion\Adjuntos\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub

Nota:: Por favor averigüe sSaveFolder = "C:\Facturacion\Adjuntos\" y reemplace la ruta de la carpeta de destino según lo necesite.

EJEMPLOS VBScript

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:\Facturacion\Adjuntos\"
     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:\Facturacion\Adjuntos\"
     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:\Facturacion\Adjuntos\"
     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:\Facturacion\Adjuntos\"
     For Each objAtt In itm.Attachments   
    if InStr(objAtt.DisplayName, ".zip") 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:\Facturacion\Adjuntos\"
     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:\Facturacion\Adjuntos\"
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:\Facturacion\Adjuntos\"
     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:\Facturacion\Adjuntos\"
' 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:\Facturacion\Adjuntos\"
       '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:\Facturacion\Adjuntos\" & 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:\Facturacion\Adjuntos\" & 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

Código VBA 1: Guardar Archivos Adjuntos De Forma Masiva De Varios Correos Electrónicos (Guardar Archivos Adjuntos Con El Mismo Nombre Directamente)

Sugerencias : este código guardará los archivos adjuntos con el mismo nombre agregando los dígitos 1, 2, 3... después de los nombres de los archivos

Dim GCount As Integer
Dim GFilepath As String
Public Sub SaveAttachments()
'Update 20200821
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
    VBA.MkDir xFolderPath
End If
GFilepath = ""
For Each xMailItem In xSelection
    Set xAttachments = xMailItem.Attachments
    xAttCount = xAttachments.Count
    xSaveFiles = ""
    If xAttCount > 0 Then
        For i = xAttCount To 1 Step -1
            GCount = 0
            xFilePath = xFolderPath & xAttachments.Item(i).FileName
            GFilepath = xFilePath
            xFilePath = FileRename(xFilePath)
            If IsEmbeddedAttachment(xAttachments.Item(i)) = False Then
                xAttachments.Item(i).SaveAsFile xFilePath
                If xMailItem.BodyFormat <> olFormatHTML Then
                    xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
                Else
                    xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
                End If
            End If
        Next i
    End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub

Function FileRename(FilePath As String) As String
Dim xPath As String
Dim xFso As FileSystemObject
On Error Resume Next
Set xFso = CreateObject("Scripting.FileSystemObject")
xPath = FilePath
FileRename = xPath
If xFso.FileExists(xPath) Then
    GCount = GCount + 1
    xPath = xFso.GetParentFolderName(GFilepath) & "\" & xFso.GetBaseName(GFilepath) & " " & GCount & "." + xFso.GetExtensionName(GFilepath)
    FileRename = FileRename(xPath)
End If
xFso = Nothing
End Function

Function IsEmbeddedAttachment(Attach As Attachment)
Dim xItem As MailItem
Dim xCid As String
Dim xID As String
Dim xHtml As String
On Error Resume Next
IsEmbeddedAttachment = False
Set xItem = Attach.Parent
If xItem.BodyFormat <> olFormatHTML Then Exit Function
xCid = ""
xCid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
If xCid <> "" Then
    xHtml = xItem.HTMLBody
    xID = "cid:" & xCid
    If InStr(xHtml, xID) > 0 Then
        IsEmbeddedAttachment = True
    End If
End If
End Function

Código VBA 2: Guardar Archivos Adjuntos De Forma Masiva De Varios Correos Electrónicos (Verificar Si Hay Duplicados)

Public Sub SaveAttachments()
'Update 20200821
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
Dim xYesNo As Integer
Dim xFlag As Boolean
On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
    VBA.MkDir xFolderPath
End If
For Each xMailItem In xSelection
    Set xAttachments = xMailItem.Attachments
    xAttCount = xAttachments.Count
    xSaveFiles = ""
    If xAttCount > 0 Then
        For i = xAttCount To 1 Step -1
            xFilePath = xFolderPath & xAttachments.Item(i).FileName
            xFlag = True
            If VBA.Dir(xFilePath, 16) <> Empty Then
                xYesNo = MsgBox("The file is exists, do you want to replace it", vbYesNo + vbInformation, "Kutools for Outlook")
                If xYesNo = vbNo Then xFlag = False
            End If
            If xFlag = True Then
                xAttachments.Item(i).SaveAsFile xFilePath
                If xMailItem.BodyFormat <> olFormatHTML Then
                    xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
                Else
                    xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
                End If
            End If
        Next i
    End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub

Creado con el Personal Edition de HelpNDoc: Revolucione la salida de su archivo de ayuda CHM con HelpNDoc