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

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
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.
Compartir
Twittear
+1
Compartir
Pin
Stumble