Macros para respaldar correo Outlook 2007

Hola amigos a los que les interesa respaldar la información de los correos Outlook 2007 buscando encontre un macro copia todos los correo en una carpeta en el disco duro para luego ser respaldados.
Tened que crear una carpeta en disco C:Correos o mirar como esta el macro para que le puedas editar saludos




Sub CopiaFolders()
Dim path As String
path = "C:correosCarpetas_de_Correo"
Set myNameSpace = Application.GetNamespace("MAPI"
Call RecorreFolders(myNameSpace.Folders, path)
'For i = 1 To myNameSpace.Folders.Count
' Set myFolder = myNameSpace.Folders(i)
'Next i

End Sub

Sub RecorreFolders(carpeta As Folders, ByVal path As String)
Dim currFolder As MAPIFolder

Set fs = CreateObject("Scripting.FileSystemObject"

'parte de la recursion que controla la salida
If carpeta.Count <> 0 Then

'fs.createfolder (path)

For i = 1 To carpeta.Count
Set currFolder = carpeta(i)

fs.createfolder (Trim(path & DepuraNombreFolder(currFolder.Name)) & ""

If currFolder.Folders.Count <> 0 Then
Call RecorreFolders(currFolder.Folders, Trim(path & DepuraNombreFolder(currFolder.Name)) & ""
End If

' ahora procedemos a obtener los items
Call guardaFolder(currFolder, Trim(path & DepuraNombreFolder(currFolder.Name)) & ""

Next i
End If

End Sub

Sub guardaFolder(fol As MAPIFolder, ByVal path As String)
Dim i As Long, Subject As String
'Set fs = CreateObject("Scripting.FileSystemObject"

For i = 1 To fol.Items.Count
Set ElementoActual = fol.Items.Item(i)

Subject = ElementoActual.Subject
'Subject = Replace(Subject, "", ""
'Subject = Replace(Subject, "/", ""
'Subject = Replace(Subject, "?", ""
'Subject = Replace(Subject, "¿", ""
'Subject = Replace(Subject, ",", ""
'Subject = Replace(Subject, "*", ""
'Subject = Replace(Subject, "<", ""
'Subject = Replace(Subject, ">", ""
'Subject = Replace(Subject, ".", ""
'Subject = Replace(Subject, "|", ""
'Subject = Replace(Subject, Chr(34), "" 'comilla doble
If Len(Subject) > 200 Then
Subject = Mid(Subject, 1, 100)
End If

nombre = path & Str(i) & DepuraNombre(Subject) & ".msg"
Call ElementoActual.SaveAs(nombre, olMSG)
Next i
End Sub

Function DepuraNombreFolder(ByVal nombre As String) As String
nombre = Replace(nombre, ":", ""
nombre = Replace(nombre, "", ""
nombre = Replace(nombre, "/", ""
nombre = Replace(nombre, "*", ""
nombre = Replace(nombre, "?", ""
nombre = Replace(nombre, "¿", ""
nombre = Replace(nombre, "<", ""
nombre = Replace(nombre, ">", ""
nombre = Replace(nombre, ".", ""
nombre = Replace(nombre, Chr(34), "" 'comilla doble

DepuraNombreFolder = nombre
End Function

Sub CopiaEsteFolder()
Dim path As String
' On Error GoTo errores
' Set fs = CreateObject("Scripting.FileSystemObject"
' Set f = fs.CreateTextFile("c:temperrors.txt", True)

path = "C:correos"
Call RecorreFolders(Application.ActiveExplorer.CurrentFolder.Folders, path)
Call guardaFolder(Application.ActiveExplorer.CurrentFolder, path) 'agregado para que guarde el primero

'errores:
' f.Writeline "Error: " & Err.Number
' f.Writeline "Description: " & Err.Description
' Resume Next
End Sub

Function DepuraNombre(ByVal filename As String) As String
For i = 0 To 255
' numeros mayusculas minusculas espacio
If Not ((i >= 48 And i <= 57) Or (i >= 65 And i <= 90) Or (i >= 97 And i <= 122) Or (i = 32)) Then
filename = Replace(filename, Chr(i), "" '
End If
Next i
DepuraNombre = filename
End Function


les dejo el link donde encontre
Saludos
http://foros.cristalab.com/respaldar-correos-outlook-no-pst-a-mi-disco-duro-t56312/