pmjavy

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/