VBScript – Respaldar o Copiar los Correos de Outlook a una Carpeta en el Disco Duro

Publicidad +
Publicidad +
Publicidad +
Publicidad +

Algunas veces es mejor organizar los correos (.msg) en carpetas en el disco duro y no en un .PST todo dependiendo de el uso y el volumen de correos electrónicos que se manejen, puede ser mejor guardar los archivos .msg en el disco duro si se maneja una gran cantidad de correos al día y más cuando un Folder Personal PST esta por llegar a su limite maximo que son 20 Gb, en la empresa hemos identificado muchos PST dañados a partir de los 19 Gb, en estos casos se ha estado optando por ayudar a los usuarios a respaldar los correos de ese PST a una Carpeta en el Disco Duro.

Hace unos dias nos hicieron una consulta sobre como hacerlo automáticamente con un VBScript conservar la estructura de los folders del PST o Mailbox dando un formato al nombre del correo (.msg) guardado, Diane Poremsky ha creado un VBScript el cual les mostramos a continuación, haciendo una pequeña modificación a este para que este guarde los mensajes conforme a la petición del usuario.

Como funciona el VBScript

Ver Articulo Como utilizar el Editor VBA en Outlook

Recomendación: Al momento de respaldar los correos se recomienda guardar en una ruta corta Ej: C:\Outlook\ ya que el nombre maximo permitido por Windows son 256 Caracteres incluyendo la direccion de las carpetas.

1.- Una vez pegado el codigo en el Modulo, Presionamos F5 o vamos a Run (Ejecutar) > Run Sub/UserForm Ejecutar VBScript Copiar los correos de Outlook

2.- Nos mostrará los Scripts que tengamos para ejecutar en este ejemplo solo aparece el Script para Respaldar los Correos a una Carpeta, seleccionamos y damos clic en Run.Ejecutar VBScript Copiar los correos de Outlook-2

3.- Ahora nos mostrará la siguiente ventana donde seleccionamos lo que vamos a Copiar o Respaldar al Disco Duro, puede ser un Mailbox o un PST.Ejecutar VBScript Copiar los correos de Outlook-3

4.- Ahora en la siguiente ventada nos mostrará la carpeta Mis Documentos para seleccionar donde guardar los correos.Ejecutar VBScript Copiar los correos de Outlook-4

5.- Esperamos a que finalice el proceso, dependiendo de la cantidad de correos es el tiempo que tardara ejecutándose el Script, en aproximado con un PST con aprox. 300 correos tardo 5 minutos en mi equipo.

Ejemplo Respaldo de Correos

6.- En la imagen anterior vemos un ejemplo del formato que se guardan que es Fecha (YYYYMMDD-hhmm) – From – Subject.

VBScript para Copiar los correos de Outlook conservando la estructura de los folders

Ver Articulo Como utilizar el Editor VBA en Outlook

Actualizaciónes de Código

18/Febrero/2016 – Solución de errores al momento de guardar correos con subject extenso.

15/Marzo/2016 – Solución de errores al crear folder multinivel.

Option Explicit
       Dim StrSavePath     As String
 
Sub SaveAllEmails_ProcessAllSubFolders()
       
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim strSubject      As String
    Dim StrName         As String
    Dim strFrom         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrSentOn       As String
    Dim StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim objShell    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection
    Dim itm             As Object
       
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    Set objShell = CreateObject("Wscript.Shell")
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
       
BrowseForFolder StrSavePath
          
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
       
    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, "\") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & "\" & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        If Not FSO.FolderExists(StrFolderPath) Then
            BuildFullPath StrFolderPath
        End If
           
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
            StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
            strSubject = mItem.Subject
' Eliminar el apostrofe de la siguiente linea si se desea agregar el From a los nombres de los correos NOTA: Solo funciona para los correos recibidos.
            'strFrom = mItem.senderName
            StrName = StripIllegalChar(strSubject)
' Eliminar el apostrofe de la siguiente linea si se desea agregar el From a los nombres de los correos NOTA: Solo funciona para los correos recibidos.
            ' StrFile = StrSaveFolder & StrReceived & " - " & strFrom & " - " & StrName & ".msg"
' Agregar un apostrofe al principio o eliminar la siguiente linea cuando utilice From en los archivos.
            StrFile = StrSaveFolder & StrReceived & " - " & StrName
            StrFile = Left(StrFile, 253)
            mItem.SaveAs StrFile & ".msg", 3
        Next j
        On Error GoTo 0
    Next i
    
       
ExitSub:
       
End Sub

Sub BuildFullPath(ByVal StrFolderPath)
Dim FSO             As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

If Not FSO.FolderExists(StrFolderPath) Then
BuildFullPath FSO.GetParentFolderName(StrFolderPath)
FSO.CreateFolder StrFolderPath
End If
End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object
       
    Set RegX = CreateObject("vbscript.regexp")
       
    RegX.Pattern = "[\" & Chr(34) & Chr(26) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
       
    StripIllegalChar = RegX.Replace(StrInput, "")
       
ExitFunction:
    Set RegX = Nothing
       
End Function
   
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder
       
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
       
ExitSub:
    Set SubFolder = Nothing
       
End Sub
   
   
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
    Dim objShell As Object
    Dim objFolder
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0)
StrSavePath = objFolder.self.Path
 
    On Error Resume Next
    On Error GoTo 0
       
ExitFunction:
    Set objShell = Nothing
       
End Function

VBScript para Copiar los correos de un contacto especifico (from) conservando la estructura de los folders

Para hacer uso de este se debe especificar en la linea 86 el correo o parte del correo de la persona a guardar sus correos, asi como tambien se puede buscar por nombre de domino ejemplo: @portalmastips.com

Linea 86:

If InStr(LCase(strFromEmail), "fernando") Then 'Cambiar fernando por el correo o parte del correo

Una vez realizado el cambio este guardara todos los correos del contacto o dominio especifico.

Option Explicit
       Dim StrSavePath     As String
 
Sub SaveAllEmails_ProcessAllSubFolders()
       
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim strSubject      As String
    Dim StrName         As String
    Dim strFrom         As String
    Dim strFromEmail    As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrSentOn       As String
    Dim StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim objShell    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection
    Dim itm             As Object
       
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    Set objShell = CreateObject("Wscript.Shell")
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
       
BrowseForFolder StrSavePath
          
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
       
    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, "\") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & "\" & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        If Not FSO.FolderExists(StrFolderPath) Then
            BuildFullPath StrFolderPath
        End If
           
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            
            Set mItem = SubFolder.Items(j)
            strFrom = mItem.SenderName
            strFromEmail = mItem.SenderEmailAddress
        ' Obtener las direcciones Exchange - Se puede remover si no se utiliza Exchange
        Dim olEU As Outlook.ExchangeUser
        Dim oEDL As Outlook.ExchangeDistributionList
        Dim recip As Outlook.Recipient
        Set recip = Application.Session.CreateRecipient(strFrom)

        If InStr(1, strFromEmail, "/") > 0 Then
         Select Case recip.AddressEntry.AddressEntryUserType
            Case OlAddressEntryUserType.olExchangeUserAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
				If Not (olEU Is Nothing) Then
					strFromEmail = olEU.PrimarySmtpAddress
				End If
             Case OlAddressEntryUserType.olOutlookContactAddressEntry
             Set olEU = recip.AddressEntry.GetExchangeUser
				If Not (olEU Is Nothing) Then
					strFromEmail = olEU.PrimarySmtpAddress
				End If
             Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
             Set oEDL = recip.AddressEntry.GetExchangeDistributionList
				If Not (oEDL Is Nothing) Then
					strFromEmail = olEU.PrimarySmtpAddress
				End If
		 End Select
        End If
            If InStr(LCase(strFromEmail), "fernando") Then 'se puede buscar parte del correo ejemplo para [email protected] se puede capturar solo fernando
            StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
            strSubject = mItem.Subject
			' Eliminar el apostrofe de la siguiente linea si se desea agregar el From a los nombres de los correos NOTA: Solo funciona para los correos recibidos.
            'strFrom = mItem.senderName
            StrName = StripIllegalChar(strSubject)
			' Eliminar el apostrofe de la siguiente linea si se desea agregar el From a los nombres de los correos NOTA: Solo funciona para los correos recibidos.
            ' StrFile = StrSaveFolder & StrReceived & " - " & strFrom & " - " & StrName & ".msg"
			' Agregar un apostrofe al principio o eliminar la siguiente linea cuando utilice From en los archivos.
            StrFile = StrSaveFolder & StrReceived & " - " & StrName
            StrFile = Left(StrFile, 253)
            mItem.SaveAs StrFile & ".msg", 3
            End If
        Next j
        On Error GoTo 0
    Next i
    
       
ExitSub:
       
End Sub

Sub BuildFullPath(ByVal StrFolderPath)
Dim FSO             As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

If Not FSO.FolderExists(StrFolderPath) Then
	BuildFullPath FSO.GetParentFolderName(StrFolderPath)
	FSO.CreateFolder StrFolderPath
End If
End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object
       
    Set RegX = CreateObject("vbscript.regexp")
       
    RegX.Pattern = "[\" & Chr(34) & Chr(26) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
       
    StripIllegalChar = RegX.Replace(StrInput, "")
       
ExitFunction:
    Set RegX = Nothing
       
End Function
   
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder
       
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
       
ExitSub:
    Set SubFolder = Nothing
       
End Sub
   
   
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
    Dim objShell As Object
    Dim objFolder
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0)
StrSavePath = objFolder.self.Path
 
    On Error Resume Next
    On Error GoTo 0
       
ExitFunction:
    Set objShell = Nothing
       
End Function
Califica este articulo

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.

21 comentarios en “VBScript – Respaldar o Copiar los Correos de Outlook a una Carpeta en el Disco Duro

  1. Buen día.

    Muchas gracias por el apoyo!!, es exactamente lo que necesitaba, por lo que me fue de gran ayuda.

    Gracias por tu comentario lo tendre en cuenta para futuras consultas o asesorias 🙂

    Saludos.

    • Buen dia HernanMTY

      Te dare seguimiento sobre este articulo; Tienes razon no pense que no se podían poner símbolos en el Editor 🙁 gracias por compartirnos tu solucion, editare el codigo anterior aun que lo agregare a la linea 80 con el ASCII que nos proporcionaste.

      Para el segundo error si los recorta en la linea 63 a 256 caracteres incluyendo la ruta completa por ejemplo: C:UserssistemasDocumentsOutlookBKInboxSUBJECT DEL CORREO.msg, solo que si encontré un error, al truncarlos a 256 no los guarda con la extensión .msg ya lo actualice en el codigo superior al igual que eliminar el carácter especial.

      La linea 63 decia StrFile = Left(StrFile, 256) este trunca o recorta el nombre a 256, lo modifique a 253 si continuas con problemas puedes recortarlo a 252 quizas cuente el punto.

      Saludos.

    • Buen dia

      Si, el codigo esta modificado ya que la persona que nos solicito como realizar el respaldo, quiere cambiar el nombre de los correos y ponerles el “From” en el nombre del correo, como los enviados no tienen este elemento debe marcar error.

      ' Agrega en la linea 56 un ' al principio para comentarlo o eliminalo 
      ' strFrom = mItem.senderName
      'En la linea 58 se debe eliminar StrFrom y que quede de la siguiente manera
      58 StrFile = StrSaveFolder & StrReceived & " - " & StrName & ".msg"
      

      Ya modifique el código en la fuente poniendo los comentarios.

      Saludos.

      • Hola buen día, ya lo probé en una cuenta de Gmail y me funciono a la perfección, el detalle es que lo intento con una cuenta de Outlook.com y esa no me funciona, alguna idea o sugerencia??? Por cierto, muchas gracias por su valioso tiempo y compartir conocimiento!!!

          • Hola Buen día una disculpa por la tardanza, si lo intente pero en los enviados es la misma situación (no se respaldan), no se si sea la forma en que esta configurada la cuenta en el outlook, intente configurarla en imap pero no lo logre, alguna sugerencia de como configurar el correo para que me descargue los enviados, o si tienen una idea de como respaldarlos directo desde la pagina de Outlook.com, de antemano muchas gracias y que tengan excelente día.

          • Buen dia Noel!

            Que raro que no te funcione ni el exportador de Outlook, estuve haciendo una búsqueda de lo que podría estar causando este inconveniente, encontré que si hacen los respaldos utilizando la configuración POP3 o IMAP(No utilizo Hotmail/Outlook.com).

            Para usar estos debes activar la opción para permitir a las aplicaciones hacer uso del protocolo POP3, para esto sobre el menu superior derecho buscas More mail settings (Mas configuraciones de correo). en Administrar tu cuenta busca Connect devices (Conectar dispositivos)

            POP3
            Server: pop-mail.outlook.com
            Port: 995
            Encrypted Connection: SSL
            User name: Tu Correo
            Password: Tu Contraseña

            IMAP
            Server: imap-mail.outlook.com
            Port: 993
            Encrypted Connection: SSL
            User name: Tu Correo
            Password: Tu Contraseña

            Otra opción que puedes utilizar es utilizar Windows Live Mail este hace una copia de tus correos en un archivo .eml el cual una vez que termine de descargar todos tus correos, lo puedes copiar a otra carpeta e importar a Outlook utilizando alguna utileria no conozco gratuitas (Descarga Windows live mail)

            Tambien podrias utilizar Thunderbird configurar tu cuenta y exportar tus correos, el problema es que estos ultimos no generan pst 🙁

    • Buen dia Adrian,

      Con este Script no es posible realizarlo automáticamente; hay un script para guardar los correos entrantes en X carpeta predefinida automáticamente, pero no conservaría la estructura si tienes reglas el cual re direcciones el correo a X carpeta dentro de outlook. Si es lo que buscas nos comentas para proporcionarte el Script.

      Saludos.

      • la estructura de guardado es mas bien lo que busco, pero al correr este Script cada que quiero respaldar el correo, sobre escribiria lo ya guardado , es correcto?

  2. Antes de nada, enhorabuena. Una pregunta: ¿qué pasa con los archivos adjuntos? ¿pueden grabarse? ¿Hay algún medio para salvar también los anexos? Gracias de antemano.
    Saludos.

      • Exacto, comprobado. Muchísimas gracias. Funciona fenomenal, animo a usarlo sin problemas.
        Sólo un tema más: al principio se dice que “Recomendación: Al momento de respaldar los correos se recomienda guardar en una ruta corta Ej: C:Outlook ya que el nombre maximo permitido por Windows son 256 Caracteres incluyendo la direccion de las carpetas.”… Sin embargo, luego el programa sólo te permite grabar en /Mis Documentos… y sus subcarpetas… Pero no me permite cambiar a C: No?
        Abrazos & gracias.

        • Buen dia

          Debe permitirte, actualice el codigo el dia 15 del presente y eso fue uno de los cambios que realice, tambien solucione algunos bugs que encontré.

          Copia de nuevo el codigo y te debe permitir.

          Saludos.

Deja un comentario...

Compartir
Twittear
+1
Compartir
Pin
Stumble