UniversoExcelForo

Respuesta a consultas.
Fecha de creación: 09.Abril.2012

Fundadores: Wibly,Tyno,Servando,Sakkar,Rosendo2,RMaximo,Railar,Mcoronel,Ioyama,Igtelo,Hugotron,Drochar,Dedos,Alberto,Adolfo

No se pueden hacer consultas de Excel o VBA por mensaje privado.
Utiliza el botón buscar del foro y te ahorras tiempo para obtener "ayuda".

No estás conectado. Conéctate o registrate

Ver el tema anterior Ver el tema siguiente Ir abajo  Mensaje [Página 1 de 1.]

Br1Style


Buenas tardes,

Agadezco por favor me puedan colaborar con la siguiente duda.

Necesito una macro que extraiga de Una Carpeta en especial de Outlook los correos que alli se contienen. Es decir necesito los datos basicos como De, Para, Con Copia, asunto y fecha Hora de la llegada del correo y si trae adjunto.

Buscando en la red encontre un codigo pero este se crea en el VBA de Outlook 2013 como un modulo nuevo y al ejecutarlo abre un Excel y pone los encabesados de Para, Con Copia, asunto y fecha Hora de la llegada del correo y si trae adjunto pero no diligencia la Información y mis conocimientos no son tan grandes como para saber porque.

Agradezco si alguien conoce una manera de poder realizar esta tarea.

Para mayor información pego el codigo que ejecuto en Oulook 2013 y que aun no me funciona completamente.

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") = "Fecha"

'Seleccionamos la carpeta
Set nms = Application.GetNamespace("001_Reporting")
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.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

Ver el tema anterior Ver el tema siguiente Volver arriba  Mensaje [Página 1 de 1.]

Permisos de este foro:
No puedes responder a temas en este foro.