Pasar mensajes de outlook a excel

publicado el 3 de febrero10 años

Hola:

Os dejo esta macro a ejecutar desde Outlook que crea un libro Excel con los mensajes de la carpeta escogida.

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

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

   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]