Imprimir página | Cerrar ventana

Enviar cuerpo correo desde carpeta outllook excel

Impreso de: Foro de Access y VBA
Categoría: Otros de Microsoft: Windows y Office
Nombre del foro: Otros Productos Microsoft
Descripción del foro: PowerPoint, Navision, Visio, FrontPage, InfoPath etc
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=82752
Fecha de impresión: 26/Febrero/2020 a las 12:37


Tema: Enviar cuerpo correo desde carpeta outllook excel
Publicado por: Galathea
Asunto: Enviar cuerpo correo desde carpeta outllook excel
Fecha de publicación: 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.



Respuestas:
Publicado por: Galathea
Fecha de publicación: 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.


Publicado por: Galathea
Fecha de publicación: 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.



Imprimir página | Cerrar ventana