** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Otros de Microsoft: Windows y Office > Otros Productos Microsoft
  Mensajes nuevos Mensajes nuevos RSS - Enviar cuerpo correo desde carpeta outllook excel
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoEnviar cuerpo correo desde carpeta outllook excel

 Responder Responder
Autor
Mensaje
Galathea Ver desplegable
Habitual
Habitual
Avatar

Unido: 15/Septiembre/2012
Localización: España
Estado: Sin conexión
Puntos: 134
Enlace directo a este mensaje Tema: Enviar cuerpo correo desde carpeta outllook excel
    Enviado: 19/Abril/2017 a las 01:17
No estoy muy al día con las macros con respecto al Outlook, pero sería posible esto:

1. Imaginemos que tengo una carpeta en Outlook llamada "Extraer Cuerpo" , donde he guardado una serie de correos indefinidos.

2. En cada correo, lo que necesito solamente es el cuerpo del correo, y la dirección de quien envía.

  El cuerpo del correo es una tabla de 3 ó 4 columnas, y filas varias.

3. Necesito copiar lo anterior de cada correo y pegarlo en un archivo excel.

4. Se podría hacer desde el mismo archivo de excel xlsm?

Ejemplo correo:

1111@talytal@cccc.com

A B C
1 2 3
1 2 3
1 2 3




y así con cada uno de los correos que hubiera en dicha carpeta.
Mil gracias.

he escrito tanta inútil cosa, sin descubrirme, sin dar conmigo.
Arriba
Galathea Ver desplegable
Habitual
Habitual
Avatar

Unido: 15/Septiembre/2012
Localización: España
Estado: Sin conexión
Puntos: 134
Enlace directo a este mensaje Enviado: 19/Abril/2017 a las 12:47
https://www.portalmastips.com/vbscript-exportar-informacion-correos-outlook-a-excel/#comment-981

Hice esto pero no me funciona, pese a q no me da error
he escrito tanta inútil cosa, sin descubrirme, sin dar conmigo.
Arriba
Galathea Ver desplegable
Habitual
Habitual
Avatar

Unido: 15/Septiembre/2012
Localización: España
Estado: Sin conexión
Puntos: 134
Enlace directo a este mensaje Enviado: 20/Abril/2017 a las 11:28
Option Explicit
Public Sub CopyEmail­ToExcelWhenArrive() 'olItem As Outlook.M­ailItem)
 Dim olItem As Outlo­ok.MailItem
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Obje­ct
 Dim rCount As Long
 Dim bXStarted As Bo­olean
 Dim enviro As String
 Dim strPath As Stri­ng
 Dim iDefault As Long
'Prueba Tabla
 Dim doClip As MSFor­ms.DataObject
'Bloque Registro Dec­larar Registro - Se puede eliminar si no se utiliza
 Dim sKey As String
 Dim lRegValue As Lo­ng
 Dim sAppName As Str­ing
 Dim sSection As Str­ing
'Dar nombre a las ll­aves de registro - Se puede eliminar si no se utiliza
 sAppName = "Outlook"
 sSection = "receive­d"
 sKey = "Current Val­ue Number XLS"
 iDefault = 2
 lRegValue = GetSett­ing(sAppName, sSecti­on, sKey, iDefault)
 
'Fin Bloque Registro
 
 Dim currentExplorer As Explorer
 Dim Selection As Se­lection
 Dim objOL As Outloo­k.Application
 Dim objFolder As Ou­tlook.MAPIFolder
 Dim objItems As Out­look.Items
 Dim obj As Object
 
 Dim strColB, strCol­C, strColD, strColE, strColF, strColG As String
            
'Iniciar Excel
'Ruta del Excel
 strPath = "C:\Users­\Manuel\Desktop\Corr­eo\Prueba.xlsx"
     On Error Resume Next
     Set xlApp = Get­Object(, "Excel.Appl­ication")
     If Err <> 0 Then
         Application­.StatusBar = "Please wait while Excel so­urce is opened ... "
         Set xlApp = CreateObject("Excel­.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Abre la hoja de calculo
     Set xlWB = xlAp­p.Workbooks.Open(str­Path)
     'Especificar no­mbre de hoja de calc­ulo
     Set xlSheet = xlWB.Sheets("Test")
     'Lee el ultimo registro de la hoja de calculo
     'lRegValue = xl­Sheet.Range("B" & xl­Sheet.Rows.Count).En­d(-4162).Row
     ' Requerido para Outlook 2016 -  si genera espacios en blanco
     'lRegValue = lR­egValue + 1
     
    On Error Resume Next
    
    'Bloque para leer folder actual- se puede remover si no se utiliza
    Set objOL = Outl­ook.Application
    'Cambiar Current­Folder por Selection para exportar selec­ción de correos
    Set objFolder = objOL.ActiveExplorer­.CurrentFolder
    Set objItems = objFolder.Items
    For Each obj In objItems
    
    'Lee el ultimo registro de la hoja de calculo
    lRegValue = xlSh­eet.Range("B" & xlSh­eet.Rows.Count).End(­-4162).Row
    ' Requerido para Outlook 2016 -  si genera espacios en blanco
    lRegValue = lReg­Value + 1
 
    Set olItem = obj
    Set doClip = New MSForms.DataObject
        doClip.SetTe­xt olItem.HTMLBody
        doClip.PutIn­Clipboard
        
 'Recolecta los datos
     strColB = olIte­m.SenderName
     strColC = olIte­m.SenderEmailAddress
     strColD = olIte­m.Subject
     strColE = olIte­m.Body
     strColF = olIte­m.To
     strColG = olIte­m.ReceivedTime
     
' Obtener las direcc­iones Exchange - Se puede remover si no se utiliza Exchange
 Dim olEU As Outlook­.ExchangeUser
 Dim oEDL As Outlook­.ExchangeDistributio­nList
 Dim recip As Outloo­k.Recipient
 Set recip = Applica­tion.Session.CreateR­ecipient(strColB)
 
 If InStr(1, strColC, "/") > 0 Then
     Select Case rec­ip.AddressEntry.Addr­essEntryUserType
       Case OlAddres­sEntryUserType.olExc­hangeUserAddressEntry
         Set olEU = recip.AddressEntry.G­etExchangeUser
         If Not (olEU Is Nothing) Then
             strColC = olEU.PrimarySmtpA­ddress
         End If
       Case OlAddres­sEntryUserType.olOut­lookContactAddressEn­try
         Set olEU = recip.AddressEntry.G­etExchangeUser
         If Not (olEU Is Nothing) Then
            strColC = olEU.PrimarySmtpAd­dress
         End If
       Case OlAddres­sEntryUserType.olExc­hangeDistributionLis­tAddressEntry
         Set oEDL = recip.AddressEntry.G­etExchangeDistributi­onList
         If Not (oEDL Is Nothing) Then
            strColC = olEU.PrimarySmtpAd­dress
         End If
     End Select
End If
'Finaliza Seccion de Exchange
 
'Escribe valores en hoja de calculo
  'xlSheet.Range("A" & lRegValue) = "Sen­der Name"
  'xlSheet.Range("B" & lRegValue) = strC­olB
  'lRegValue = lRegV­alue + 1
  'xlSheet.Range("A" & lRegValue) = "Sen­der Email"
  'xlSheet.Range("B" & lRegValue) = strC­olC
  'lRegValue = lRegV­alue + 1
  'xlSheet.Range("A" & lRegValue) = "Sub­ject"
  'xlSheet.Range("B" & lRegValue) = strC­olD
  'lRegValue = lRegV­alue + 1
  xlSheet.Range("A" & lRegValue) = "To"
  xlSheet.Range("B" & lRegValue) = strCo­lF
  lRegValue = lRegVa­lue + 1
  'xlSheet.Range("A" & lRegValue) = "Rec­eived Time"
  'xlSheet.Range("B" & lRegValue) = strC­olG
  'lRegValue = lRegV­alue + 1
  xlSheet.Range("A" & lRegValue) = "Body"
  xlSheet.Range("B" & lRegValue).PasteSp­ecial "Text" = strCo­lE
  lRegValue = lRegVa­lue + 1
 
  
  'Si no se lee fold­er actual remover
  Next
  
'Guarda el registro - Si se utiliza regi­stro remover el '
 'SaveSetting sAppNa­me, sSection, sKey, lRegValue + 1
 
     xlWB.Close 1
     If bXStarted Th­en
         xlApp.Quit
     End If
     
     Set olItem = No­thing
     Set obj = Nothi­ng
     Set currentExpl­orer = Nothing
     Set xlApp = Not­hing
     Set xlWB = Noth­ing
     Set xlSheet = Nothing
 End Sub

Para quien le pueda ser útil.

Se puede cerrar el hilo.
he escrito tanta inútil cosa, sin descubrirme, sin dar conmigo.
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable