Nombre: Macro para Respaldar Correos de Outlook
Descripción:
Saludos, les dejo esta macro, la cual no la hice yo, si no que la encontré en la siguiente liga, fué realizada por Alex Castillo y la encuento util para la mayoría que dan soporte, por eso la comparto:
www.cofradia.org/modules.php?name=News&file=article&sid=16131&mode=&order=0&thold=0 Les anexo el texto original para que entiendan de qué se trata: "No sé si algunos de ustedes que los obligan a usar Outlook se ha enfrentado a esos desgraciados PST dañados. Resulta fastidioso tener que lidiar con ellos. Pues después de que se dañan vienen los usuarios a rogar para que se recuperen. Entonces los de soporte usan el scanpst.exe y reparan el archivo. ¿Después que viene? Pues un archivo que se daña se vuelve a dañar, así que la gente de soporte generalmente utiliza una utilería para extraer los correos. Ahí fue, cuando al ver a mis compañeros rogando por licencias de X programa, cuando pensé que de alguna manera el Outlook mismo podría hacer la chamba con una macro. Para eso creé esta macro que pongo a disposición de ustedes. Ella utiliza un directorio en C: Tempcorreos para crear una imagen de los folders del pst y sus mails los guarda como archivos .msg. La subrutina que uso es la CopiaEsteFolder, pero en general si leen el código verán que es sencillo entender el funcionamiento. Espero que les sirva tanto como a mi me ha sevido. Saludos, Alex Castillo"
URL: http://www.mygnet.net/codigos/vb/backup/macro_para_respaldar_correos_de_outlook.1298
Código Fuente:
Attribute VB_Name = "Module1"
Sub Exporta()
Set myOlApp = CreateObject("Outlook.Application")
Set myitem = myOlApp.ActiveInspector.CurrentItem
myitem.SaveAs "C:temp" & myitem.Subject & ".msg", olMSG
End Sub
Sub Seleciona()
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = _
myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitem = myFolder.Items(1)
myitem.Display
End Sub
Sub GuardaTodo()
Set CarpetaActual = Application.ActiveExplorer.CurrentFolder
Set TodosElementos = CarpetaActual.Items
NumElementos = CarpetaActual.Items.Count
' Loop through all of the items in the folder
For i = 1 To NumElementos
Set ElementoActual = TodosElementos.Item(i)
Subject = Replace(ElementoActual.Subject, ":", "")
Subject = Replace(ElementoActual.Subject, "", "")
Subject = Replace(ElementoActual.Subject, "/", "")
nombre = "C:temp2004" & Str(i) & Subject & ".msg"
Call ElementoActual.SaveAs(nombre, olMSG)
Next
MsgBox "Terminado"
End Sub
Sub CopiaFolders()
Dim path As String
path = "C:Tempcorreos"
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:Tempcorreos"
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
Descargar