VBScript – Guardar Archivos Adjuntos de Correos .MSG Automaticamente (Guardar adjuntos de correos adjuntos)

A solicitud de un usuario hemos creado un Script el cual su funcionamiento es guardar adjuntos de correos adjuntos automáticamente. Este consiste al momento de recibir un correo que contenga correos adjuntos en este, es decir archivos .msg este los va a guardar en una carpeta temporal, va a leer y guardara los adjuntos de cada correo (.msg) en esta carpeta.

También es posible que ya tengas guardados lo correos .msg en una carpeta y deseas extraer los adjuntos de estos puedes hacerlo con el siguiente Script Ver: VBScript – Guardar Archivos Adjuntos de Correos .MSG Ya Guardados en el Disco Duro

Código

Public Sub saveAttachtoDiskAuto(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim extFile As String
Dim saveName As String
Dim comp As String
Dim fso As Object
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:Temp"
Set fso = CreateObject("Scripting.FileSystemObject")

For Each objAtt In itm.Attachments
    If InStr(objAtt.FileName, ".msg") Then
        saveName = StripIllegalChar(objAtt.FileName)
        objAtt.SaveAsFile saveFolder & "" & saveName
        comp = "yes"
    End If
Next
If (comp = "yes") Then
        SaveMSGAttachments saveFolder
        comp = "no"
        fso.DeleteFile ("C:Temp*.msg") 'Deletes all files with the extension .msg in the folder
    End If
End Sub

Function StripIllegalChar(myAttachment)
    Dim RegX            As Object
       
    Set RegX = CreateObject("vbscript.regexp")
       
    RegX.Pattern = "[" & Chr(34) & "!@#$%^&*()=+|[]{}`';:<>?/,]"
    RegX.IgnoreCase = True
    RegX.Global = True
       
    StripIllegalChar = RegX.Replace(myAttachment, "")
       
ExitFunction:
    Set RegX = Nothing
       
End Function

Function SaveMSGAttachments(saveFolder)
Dim olItem As MailItem
Dim SH As Object
Dim msgFolder
Dim saveFolderAttachments
Dim strFilesFldr As String
Dim strSaveFldr As String
Dim objAtt As Outlook.Attachment
Dim strFilename As String

On Error GoTo Cleanup
Set SH = CreateObject("SHell.Application")

'Set msgFolder = SH.BrowseForFolder(0, "Selecciona el Folder que Contiene los .msg", &H400)
'If msgFolder Is Nothing Then Exit Function
strFilesFldr = saveFolder 'msgFolder.Items.Item.Path & ""

Set saveFolderAttachments = SH.BrowseForFolder(0, "Selecciona el Folder para Guardar los Adjuntos", &H400)
If saveFolderAttachments Is Nothing Then Exit Function
strSaveFldr = saveFolderAttachments.Items.Item.Path & ""

strFilename = Dir$(strFilesFldr & "*.msg")


While Len(strFilename) <> 0
    Set olItem = Application.CreateItemFromTemplate(strFilesFldr & strFilename)
    If olItem.Attachments.Count > 0 Then
        For Each objAtt In olItem.Attachments
           If ((InStr(objAtt.DisplayName, ".pdf") Or InStr(objAtt.DisplayName, ".xml"))) Then
            'objAtt.SaveAsFile strSaveFldr & Format(Now, "yyyymmdd-HHMMSS") & Chr(32) & objAtt.FileName ' Add Date to The Name
            objAtt.SaveAsFile strSaveFldr & objAtt.FileName
            End If
        Next objAtt
    End If
    olItem.Delete
    strFilename = Dir$()
Wend
Cleanup:
Set msgFolder = Nothing
'Set saveFolder = Nothing
Set SH = Nothing
Set objAtt = Nothing
Set olItem = Nothing
End Function

Instrucciones de Uso

1.- Creamos el modulo en VBScript (Ver: Como utilizar el Editor VBA en Office Outlook).

2.- Configuramos la regla del cual normalmente recibimos los correos adjuntos en los correos (por asi llamarlo) para que se ejecute cuando lo recibamos (Ver:Crear y Configurar Reglas).

3.- Una vez que tengamos configurado lo anterior debemos crear la carpeta temporal que vemos en la linea 10 del código el cual es: Temp esta la crearemos en el C:Temp si deseamos cambiar la ruta también se debe realizar en el código en las lineas 10 y 23.

4.- Modificamos el tipo de archivo que deseamos guardar en el ejemplo solicitaron que fueran .pdf y .xml asi que en la linea 71 se especifico de la siguiente manera, lo pueden modificar a la extension de el archivo que deseen.

If ((InStr(objAtt.DisplayName, ".pdf") Or InStr(objAtt.DisplayName, ".xml"))) Then

Si deseamos que guarde todos los archivos adjuntos podemos eliminar las lineas 71 y 73 el cual sería la linea anterior y el End If.

5.- Ya configurado y creadas las carpetas requeridas al momento de recibir un correo con correos adjuntos por ejemplo:

6.- El script se ejecutara, guardara los archivos en la ruta temporal y nos preguntara donde deseamos guardar los adjuntos de esos correos; extraerá y guardara los adjuntos en la carpeta indicada.7.- En la siguiente imagen se muestra que guardo los pdf contenidos, en los correos venian adjuntos archivos .xls, .doc y ninguno traia adjunto un xml.

8.- Una vez guardados se eliminan los correos de la carpeta temporal.

9.- Listo, finaliza nuestro proceso, así con cada correo que recibamos con adjuntos y que cumpla con las condiciones que se especificaron al crear la regla.