** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Otros de Microsoft: Windows y Office > Otros Productos Microsoft
  Mensajes nuevos Mensajes nuevos RSS - Macro VBA Para Exportar Datos de Outlook a Excel
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoMacro VBA Para Exportar Datos de Outlook a Excel
 Responder Responder
Autor
Mensaje
  Tema Buscar Tema Buscar  Opciones del Tema Opciones del Tema
alexsc Ver desplegable
Habitual
Habitual
Avatar

Unido: 02/Septiembre/2010
Localización: Colombia
Estado: Sin conexión
Puntos: 188 		Enlace directo a este mensaje Tema: Macro VBA Para Exportar Datos de Outlook a Excel
    Enviado: 23/Marzo/2016 a las 18:50
Buenos dias:

He creado una macro en VBA sobre outlook 2007 para poder exportar los mensajes de correo entrante hacia un archivo de Excel. Necesito incluir en la informacion exportada, si alguno de los mensajes entrantes fueron respondidos y en que fecha y hora se respondio, pero no he podido lograrlo

Recurro a ustedes para que por favor me den ayudita con esta parte. Les agradezco mucho su valiosa y pronta colaboraciòn. Saludos
"El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..."



Alexsc

Bogotá - Colombia
Arriba
Galathea Ver desplegable
Habitual
Habitual
Avatar

Unido: 15/Septiembre/2012
Localización: España
Estado: Sin conexión
Puntos: 135 		Enlace directo a este mensaje Enviado: 20/Abril/2017 a las 11:26
pon esto en un modulo, después selecciona la carpeta en cuestión y ejecuta:

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
he escrito tanta inútil cosa, sin descubrirme, sin dar conmigo.
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable