Copiar mensajes de Outlook al pc.

[Salvador1]

Hola:

He visto macros que permiten descargar archivos adjuntos del Outlook a una carpeta del pc, pero no he visto ninguna que pueda descargar o copiar los propios mensajes p.ej. a Excel, Word o a una carpeta.

¿Conocéis alguna?

[Taburiente]

Esta macro (CopiaEstaCarpeta) te guardara todos lo correos que tengas en una carpeta determinada de tu Outlook previamente seleccionada ( es decir, selecciona primero la carpeta a copiar y luego ejecuta la macro), en la siguiente ruta : path = "C:\correos\".......puede cambiarla por cualquier otra, espero que te sea útil.

Un saludo

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 CopiaEstaCarpeta()
    Dim path As String
'    On Error GoTo errores
'    Set fs = CreateObject("Scripting.FileSystemObject")
'    Set f = fs.CreateTextFile("c:temperrors.txt", True)

   ' En esta carpeta se guardan los correos
    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[/PHP]

[Invitado Gengis Khan]

Hola todos:

Otra macro distinta a la de Taburiente, la suya crea una archivo de mensaje por cada mensaje dela carpeta Outlook seleccionada previamente, la mía crea un archivo Excel con todos los mensajes de la carpeta Outlook que seleccione al ejecutar la macro.

Basada en este tema del foro MrExcel :

Vba macro export from outlook to excel

Sub ExportToExcel(): 'On Error Resume Next


Dim appExcel As Excel.Application

Dim wkb As Excel.Workbook

Dim wks As Excel.Worksheet

Dim nms As Outlook.NameSpace

Dim fld As Outlook.MAPIFolder

Dim itm As Object


'Creamos la instancia a Excel

Set appExcel = CreateObject("Excel.Application")

Workbooks.Add

Set wkb = appExcel.ActiveWorkbook

Set wks = wkb.ActiveSheet

appExcel.Application.Visible = True



'Fila de cabecera

wks.Range("A1") = "Asunto"

wks.Range("B1") = "Cuerpo"

wks.Range("C1") = "Remitente"

wks.Range("D1") = "Destinatario"

wks.Range("E1") = "Importancia"

wks.Range("F1") = "Privacidad"



'Seleccionamos la carpeta

Set nms = Application.GetNamespace("MAPI")

Set fld = nms.PickFolder


If fld Is Nothing Then

   Exit Sub

End If



If fld.DefaultItemType <> olMailItem Or _

   fld.Items.Count = 0 Then

   MsgBox "La carpeta no contiene mensajes de correo electrónico"

   Exit Sub

End If



fila = 1

'Recorremos los mensajes

For Each itm In fld.Items

   If itm.Class = olMail Then

      fila = fila + 1

      wks.Range("A" & fila) = itm.Subject

      wks.Range("B" & fila) = itm.Body

      wks.Range("C" & fila) = itm.SenderName

      wks.Range("D" & fila) = itm.To

      wks.Range("E" & fila) = itm.Importance

      wks.Range("F" & fila) = itm.Sensitivity

   End If

Next itm


'Ajustar al texto el cuepo del mensaje

wks.Range("B:B").WrapText = True

wks.Columns.ColumnWidth = 25

wks.Columns("B:B").ColumnWidth = 80

wks.Cells.VerticalAlignment = xlTop



MsgBox "*** Proceso de exportación de mensajes terminado correctamente ***"



'

'Limpiamos objetos

Set appExcel = Nothing

Set wkb = Nothing

Set wks = Nothing

Set nms = Nothing

Set fld = Nothing

Set itm = Nothing


End Sub

[/CODE]

Saludos

[pegones1]

Gracias Gengis por tu aporte.

Yo incluiría dos columnas más:

G: fecha y hora de recepción

H: tamaño del mensaje

Incluyendo estas 4 líneas:

'Fila de cabecera

wks.Range("G1") = "Recibido"

wks.Range("H1") = "Tamaño"


'Recorremos los mensajes

      wks.Range("G" & fila) = itm.ReceivedTime

      wks.Range("H" & fila) = itm.Size[/CODE]

Para los que no sepan cómo encontrar otras propiedades:

1. Entrar desde Outlook al editor de Visual Basic pulsando simultáneamente las teclas <Alt>+<F11>.
   
2. Entrar en el Examinador de Objetos con la tecla <F2>
   
3. Buscar en el primer desplegable: Outlook
   
4. Escribir en el segundo desplegable: mailitem
   
5. Presionar el botón con anteojos para buscar los miembros de MailItem (las propiedades tienen el símbolo de una mano agarrando una tarjeta)
   

[Salvador1]

Hola de nuevo:

No he podido responder antes porque no la probé hasta el lunes en trabajo, y ayer no funcionaba el foro.

No he conseguido que funcione ninguna de las 2 macros (la he ejecutado tanto en Outlook como Excel).

De la macro de Gengis Khan, recuerdo que en Outlook se me resaltaba en amarillo una de estas dos lineas (creo que la primera, porque si la ejecutaba en excel, me resaltaba la segunda)

Dim appExcel As Excel.Application

ó

Dim nms As Outlook.NameSpace

No sé si será problema de no tener activada alguna "Herramientas-Referencias" en vba, o algo que estoy pasando por alto. Yo simplemente he abierto el editor, he pegado el código, he modificado la ruta donde quiero que se guarde y he ejecutado.

Saludos.

[pegones1]

Hola Salvador1,

La macro ExportToExcel se debe ejecutar en Outlook pero antes tienes que tener una referencia porque sino te saltará un mensaje de Microsoft Visual Basic de error de compilación:

No se ha definido el tipo definido por el usuario

Pues eso, que toca definir el tipo sin definir, para que no resalte en amaillo la línea:

Dim appExcel As Excel.Application

Sigue estos pasos:

1. Entrar desde Outlook al editor de Visual Basic pulsando simultáneamente las teclas <Alt>+<F11>
   
2. Selecciona el menú: Herramientas y Referencias
   
3. Busca entre las referencias disponibles y chequea: Microsoft Excel 12.0 Object Library (o la versión que uses. Para Excel 2007 es la 12.0)
   
4. Pulsa el botón Aceptar
   
5. Vuelve a ejecutar la macro.
   

¡Ya nos contarás como te ha ido!

[Invitado Gengis Khan]

Hola:

Como muybien apunta el Sr. Pegones1, las macros deben ser ejecutadas desde Outlook.

Aquí le dejo las Referencias para Excel 2010 (Versión 12 para Excel 2007)

[ATTACH]36106.vB[/ATTACH]

Con estas referencias funcionan las dos macros sin problemas.

Saludos

[logroastur]

Buenas chequea enlace

[DBOX]Outlook a Excel[/DBOX]

puede que te sea de utilidad

un saludo

[Salvador1]

¡Perfecto! Muchas gracias.

Se puede dar por solucionado.