VBScript – Exportar Información de correos Outlook a Excel

En seguimiento a la solicitud en el comentario del artículo redactamos el siguiente artículo.

El Script solicitado es para Exportar Información tal como Remitente, Fecha, Asunto, Mensaje. Para de los correos recibidos en Outlook a Excel automáticamente cuando llegan y también poder utilizar con reglas para configurar ciertos remitentes y asunto. El script guarda en el registro de Windows el numero consecutivo de renglón para que no se pierda la secuencia al momento de cerrar Outlook o reiniciar nuestro equipo.

Instrucciones de Uso

1.- Abrir el editor de Visual Basic (ALT+F11).

2.- Insertar un modulo nuevo (Insert > Module).

3.- Copiar el código VBScript.

4.- Debemos crear un documento Excel el cual guardaremos en una ruta de fácil acceso para el ejemplo creamos un folder en C:\1-Tests\test.xlsx, el cual dentro del folder 1-Tests tenemos nuestras pruebas y el archivo llamado test.xlsx es el documento Excel que creamos. Estos datos los especificamos en la linea 30 del código.

5.- En el documento Excel debemos dar un nombre a la hoja en este caso la nombramos Test. Este dato lo especificamos en la linea 41 del código.

6.- Podemos dar formato al documento y poner los encabezados como en la imagen, el código esta configurado para que se salte el primer renglón.

exportar-informacion-de-correos-outlook-a-excel-documento 7.- El registro del valor numérico del renglón consecutivo disponible se guarda en la ruta: HKEY_CURRENT_USER\SOFTWARE\VB and VBA Program Settings\Outlook\received el cual si deseamos reinicializarlo debemos entrar a la ruta anterior y modificar (Tambien podemos eliminar) la llave Current Value Number XLS por el numero 2.

exportar-informacion-de-correos-outlook-a-excel-cambiar-numero-en-registro

8.- Configuramos la regla requerida para ejecutar el Script.

Para mas información de configuración ver: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript) y Outlook – Crear y configurar reglas

Código

Option Explicit
Public Sub CopyEmailToExcelWhenArrive(olItem As Outlook.MailItem)
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim iDefault As Long
'Declare registry
 Dim sKey As String
 Dim lRegValue As Long
 Dim sAppName As String
 Dim sSection As String
'Set name of registry keys
 sAppName = "Outlook"
 sSection = "received"
 sKey = "Current Value Number XLS"
 iDefault = 2
 lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
 
 Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim obj As Object
 Dim strColB, strColC, strColD, strColE, strColF, strColG As String
            
' Get Excel set up
'the path of the workbook
 strPath = "C:\1-Tests\test.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Test")
    ' Process the message record
     
    On Error Resume Next
    
 'collect the fields
     strColB = olItem.senderName
     strColC = olItem.SenderEmailAddress
     strColD = olItem.Subject
     strColE = olItem.Body
     strColF = olItem.To
     strColG = olItem.ReceivedTime
     
 
'write them in the excel sheet
  xlSheet.Range("B" & lRegValue) = strColB
  xlSheet.Range("c" & lRegValue) = strColC
  xlSheet.Range("d" & lRegValue) = strColD
  xlSheet.Range("e" & lRegValue) = strColE
  xlSheet.Range("f" & lRegValue) = strColF
  xlSheet.Range("g" & lRegValue) = strColG
  
'Save registry row increment
 SaveSetting sAppName, sSection, sKey, lRegValue + 1
 
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     
     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

Basado un codigo de Diane Poremsky publicado en slipstick

Codigo anterior modificado para no utilizar registro

Ver Codigo

Código exportar información de los correos en la carpeta seleccionada de Outlook a Excel de forma horizontal

El siguiente código exporta la información de la carpeta seleccionada o selección de correos de forma horizontal, ver imagen de ejemplo:

Ejemplo exportar informacion de correos forma horizontal
Ejemplo exportar informacion de correos forma horizontal

 

Instrucciones de Uso

1.- Abrir el editor de Visual Basic (ALT+F11).

2.- Insertar un modulo nuevo (Insert > Module).

3.- Copiar el código VBScript.

4.- Debemos crear un documento Excel el cual guardaremos en una ruta de fácil acceso para el ejemplo creamos un folder en C:\1-Tests\test.xlsx, el cual dentro del folder 1-Tests tenemos nuestras pruebas y el archivo llamado test.xlsx es el documento Excel que creamos. Estos datos los especificamos en la linea 35 del código.

5.- En el documento Excel debemos dar un nombre a la hoja o dejar la predeterminada Sheet1. Este dato lo especificamos en la linea 47 del código.

Para mas información de configuración ver: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript) y Outlook – Crear y configurar reglas

Option Explicit
Option Explicit
Public Sub CopyEmailToExcelWhenArrive() 'olItem As Outlook.MailItem)
 Dim olItem As Outlook.MailItem
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim iDefault As Long
                                            
'Bloque Registro Declarar Registro - Se puede eliminar si no se utiliza
 Dim sKey As String
 Dim lRegValue As Long
 Dim sAppName As String
 Dim sSection As String
'Dar nombre a las llaves de registro - Se puede eliminar si no se utiliza
 sAppName = "Outlook"
 sSection = "received"
 sKey = "Current Value Number XLS"
 iDefault = 2
 lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)

'Fin Bloque Registro

 Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim objOL As Outlook.Application
 Dim objFolder As Outlook.MAPIFolder
 Dim objItems As Outlook.Items
 Dim obj As Object
 
 Dim strColB, strColC, strColD, strColE, strColF, strColG As String
            
'Iniciar Excel
'Ruta del Excel
 strPath = "C:\1-Tests\test.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Abre la hoja de calculo
     Set xlWB = xlApp.Workbooks.Open(strPath)
     'Especificar nombre de hoja de calculo
     Set xlSheet = xlWB.Sheets("Sheet1")
     'Lee el ultimo registro de la hoja de calculo
     lRegValue = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
     ' Requerido para Outlook 2016 -  si genera espacios en blanco
     lRegValue = lRegValue + 1
     
    On Error Resume Next
    
    'Bloque para leer folder actual- se puede remover si no se utiliza
    Set objOL = Outlook.Application
                                                                            
    Set objFolder = objOL.ActiveExplorer.CurrentFolder
    Set objItems = objFolder.Items
    For Each obj In objItems       

    Set olItem = obj                      
        
 'Recolecta los datos
     strColB = olItem.SenderName
     strColC = olItem.SenderEmailAddress
     strColD = olItem.Subject
     strColE = olItem.Body
     strColF = olItem.To
     strColG = olItem.ReceivedTime
     
' Obtener las direcciones Exchange - Se puede remover si no se utiliza Exchange
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColB)

 If InStr(1, strColC, "/") > 0 Then
     Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
     End Select
End If
'Finaliza Seccion de Exchange
 
'Escribe valores en hoja de calculo
  xlSheet.Range("A" & lRegValue) = "Sender Name"
  xlSheet.Range("B" & lRegValue) = strColB
  lRegValue = lRegValue + 1
  xlSheet.Range("A" & lRegValue) = "Sender Email"
  xlSheet.Range("B" & lRegValue) = strColC
  lRegValue = lRegValue + 1
  xlSheet.Range("A" & lRegValue) = "Subject"
  xlSheet.Range("B" & lRegValue) = strColD
  lRegValue = lRegValue + 1
  xlSheet.Range("A" & lRegValue) = "Body"
  xlSheet.Range("B" & lRegValue) = strColE
  lRegValue = lRegValue + 1
  xlSheet.Range("A" & lRegValue) = "To"
  xlSheet.Range("B" & lRegValue) = strColF
  lRegValue = lRegValue + 1
  xlSheet.Range("A" & lRegValue) = "Received Time"
  xlSheet.Range("B" & lRegValue) = strColG
  lRegValue = lRegValue + 2

  'Si no se lee folder actual remover
  Next
  
'Guarda el registro - Si se utiliza registro remover el '
 'SaveSetting sAppName, sSection, sKey, lRegValue + 1
 
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     
     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

Modificación basada en un codigo de Diane Poremsky publicado en slipstick

Califica este articulo

Fernando O.

Soy analista de sistemas actualmente trabajo en una empresa con mas de 200 empleados que utilizan equipo de computo al cual se les da soporte en el departamento.
Uno de mis pasatiempos fuera de la empresa es escribir artículos para PortalMasTips donde documento los problemas, inquietudes y detalles interesantes que se presentan.

137 comentarios en “VBScript – Exportar Información de correos Outlook a Excel

  1. Hola Fernando, es genial lo que haces! He estado leyendo varias de las soluciones que publicas y ahora me surgen mucho más ideas (y dudas!!).

    Tengo una consulta para éste script que publicas, crees que se le pueda añadir el nombre de cada uno de los archivos adjuntos en cada correo??

    Y aprovechando el comentario, una consulta más, existe algún script para reenviar un correo con cierto texto en el asunto. Sé que ésto se puede realizar desde las tareas simples de Outlook, pero mi interés es que las direcciones de envío vayan en CCO y sólo la mía en CC? Así los remitentes no pueden ver las direcciones del resto.

    Desde ya, gracias por la ayuda!
    Saludos.

    • Buen dia Israel

      La segunda consulta no comprendi bien, quieres que al dar responder las direcciones vayan al campo CCO?

      Para tu primer consulta claro que si se puede agregar, agregue las lineas necesarias

      Option Explicit
      Public Sub CopyEmailToExcelWhenArrive(olItem As Outlook.MailItem)
       Dim xlApp As Object
       Dim xlWB As Object
       Dim xlSheet As Object
       Dim rCount As Long
       Dim bXStarted As Boolean
       Dim enviro As String
       Dim strPath As String
       Dim iDefault As Long
      'Declare registry
       Dim sKey As String
       Dim lRegValue As Long
       Dim sAppName As String
       Dim sSection As String
      'Set name of registry keys
       sAppName = "Outlook"
       sSection = "received"
       sKey = "Current Value Number XLS"
       iDefault = 2
       lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
       
       Dim currentExplorer As Explorer
       Dim Selection As Selection
       Dim obj As Object
       Dim strColB, strColC, strColD, strColE, strColF, strColG, strColH As String
       
       Dim objAtt As Outlook.Attachment
       Dim saveFolder As String
                  
      ' Get Excel set up
      'the path of the workbook
       strPath = "C:1-Teststest.xlsx"
           On Error Resume Next
           Set xlApp = GetObject(, "Excel.Application")
           If Err <> 0 Then
               Application.StatusBar = "Please wait while Excel source is opened ... "
               Set xlApp = CreateObject("Excel.Application")
               bXStarted = True
           End If
           On Error GoTo 0
           'Open the workbook to input the data
           Set xlWB = xlApp.Workbooks.Open(strPath)
           Set xlSheet = xlWB.Sheets("Test")
          ' Process the message record
           
          On Error Resume Next
          
       'collect the fields
           strColB = olItem.senderName
           strColC = olItem.SenderEmailAddress
           strColD = olItem.Subject
           strColE = olItem.Body
           strColF = olItem.To
           strColG = olItem.ReceivedTime
           For Each objAtt In olItem.Attachments
              strColH = strColH & objAtt.DisplayName & ", "
           Next
           
       
      'write them in the excel sheet
        xlSheet.Range("B" & lRegValue) = strColB
        xlSheet.Range("c" & lRegValue) = strColC
        xlSheet.Range("d" & lRegValue) = strColD
        xlSheet.Range("e" & lRegValue) = strColE
        xlSheet.Range("f" & lRegValue) = strColF
        xlSheet.Range("g" & lRegValue) = strColG
        xlSheet.Range("h" & lRegValue) = strColH
        
      'Save registry row increment
       SaveSetting sAppName, sSection, sKey, lRegValue + 1
       
           xlWB.Close 1
           If bXStarted Then
               xlApp.Quit
           End If
           
           Set olItem = Nothing
           Set obj = Nothing
           Set currentExplorer = Nothing
           Set xlApp = Nothing
           Set xlWB = Nothing
           Set xlSheet = Nothing
       End Sub
      
      • Hola Fernando,

        Me funcionó perfecto el script que publicaste, era justo lo que quería mil gracias!!

        Sobre la segunda consulta, intento explicarme mejor: Recibo un correo todos los días, el cual reenvío a varios compañeros (alrededor de 70), siempre viene con el mismo título y del mismo remitente; las reglas predeterminadas de reenvío de Outlook no me conviene porque sólo puedes poner direcciones en los campos PARA o CC. La idea sería tener un script que al asociarlo a una regla (que verifique el asunto del mensaje recibido) reenvíe el correo (con adjuntos) a los destinatarios deseados pero en CCO, para ésto, las direcciones de los destinatarios podrían estar dentro del mismo script, ya que éstas direcciones casi no las cambio.

        No sé si mejoro o empeoró la explicación!!

        Gracias y saludos.

  2. Saludos gracias por el aporte, necesito algo realacionado con lo que planteas a ver si me puedes ayudar, necesito que la bandeja de entrada y de salida realize por usuario lo siguiente, de outllok se exporte a excel todo el correo entrante con los datos de cada contacto y a su vez cree unas carpetas por usuarios, ademas de eso incluir el adjunto si fuese el caso y pueda abrirse en pdf o xml, las carpetas por usuario deberian ser enviados y recibidos (subcarpetas) y por ultimo crear una especie de alarma que no sea la del outlook que indique revision del correo o responder a tal correo, se que lo que planteo es bastante complicado por eso te escribo, gracias de antemano por la atencion prestada:

    Daniel

    • Buen dia Daniel!

      Para crear las carpetas puedes utilizar otro Macro verifica en este articulo cual se ajusta a tus necesidades “VBScript para guardar automáticamente archivos adjuntos Outlook

      Para que te muestre un Mensaje tipo Popup puedes utilizar este pequeño código lo puedes configurar en otro modulo y ejecutar con regla. el unico problema que no se actualizara la bandeja de entrada hasta que den OK.

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim dateFormat
      Dim getFrom
      
      getFrom = itm.SenderName
      MsgBox "Tienes un Nuevo Mensaje de: " & getFrom, vbInformation, "Nuevo Mensaje"
      
      End Sub
      • Gracias por la informacion, si claro me ayudo mucho en eso estoy, quisiera es que ademas de la carpeta del usuario se cree una subcarpeta con la fecha del envio y dentro de ella el adjunto, y por otro lado que el correo se elimine apenas llegue al outlook que la bandeja se mantenga vacia en ese sentido y todo quede en las carpetas ya seleccionada anteriormente, nose si me puede ayudar con esto, de todas formas muchas gracias por el apoyo. Saludos desde Venezuela

        • Buen dia

          Daniel Intenta con el siguiente Script, para eliminarlo eso lo puedes hacer desde las reglas de Outlook, que primero ejecute el Script después mueva a Eliminados.

          Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
          Dim objAtt As Outlook.Attachment
          Dim saveFolder As String
          Dim dateFormat
          Dim getFrom
          Dim oFSO
          Set oFSO = CreateObject("Scripting.FileSystemObject")
          
              dateFormat = Format(Now, "yyyy-mm-dd H-mm")
              getFrom = itm.senderName
              saveFolder = "C:Archivos" & getFrom & "" & dateFormat & ""
          
          If Not oFSO.FolderExists(saveFolder) Then
            oFSO.CreateFolder saveFolder
          End If
          
               For Each objAtt In itm.Attachments
                    objAtt.SaveAsFile saveFolder & objAtt.DisplayName
                    Set objAtt = Nothing
                    Set itm = Nothing
               Next
          End Sub
  3. Saludos fernando te explico lo siguiente disculpa que no me he explicado de la mejor manera, entiendo que son varios scripts los que requiero, aqui mi necesidades

    1. el script lo requiero para entrada y salida de correos para ambos, todos los contactos, que me almacene en una carpeta en cualquier lugar que yo elija, por usuario y dentro de ello una subcarpeta con la fecha de envio o recepcion sea el caso y finalmente el adjunto, probe el ultimo script pero da un error 76 lo depure y es en la linea de oFSO.CreateFolder saveFolder.

    Cada carpeta por usuario deberá tambien crearse dos subcarpetas
    1.) “Recibidos”, es decir, los E-Mail´s que me envío “Juanito Pérez”
    2.) “Enviados”, donde irán todos los E-Mail´s que yo le envíe a “Juanito Pérez” a lo largo del tiempo.

    De esta forma tanto la carpeta “Recibidos” como “Enviados” contendrán carpetas con fechas las cuales contendrán todos los archivos que se adjunten en ese correo en particular (ya sea un correo que recibí o envié). Puedo así tener un respaldo organizado de todos los correos que me envían y que yo envío diariamente a lo largo del tiempo, en otras palabras, poder acceder ordenadamente a todo el contenido del correo por usuario, tipo y fecha.

    Finalmente para este punto requiero que las carpetas se ordenen automáticamente según el departamento en donde trabaja el o la que me envío el E-Mail, es decir, las carpetas anteriormente solicitadas, irán dentro de una carpeta llamada “Facturas” que es el departamento en donde trabaja ese individuo en particular.

    3.)Los contactos de Outlook generalmente traen información en su tarjeta de contacto, tal como: número de celular, teléfono, E-Mail etc. Es por esto que re-quiero que junto al punto número 1 se extraigan estos datos y se coloquen en un archivo Excel por cada contacto que me escriba un E-Mail. Así puedo tener un respaldo de todos los contactos y así poder comunicarme de manera eficientemente con ellos.

    Quizas sean unas locuras lo que pido ayuda, pero es lo que necesito solucionar, sino se puede entenderé no todo en la vida se puede pero si hay que tratar de intentarlo. Gracias de antemano y disculpa

    • Buen dia Daniel

      He modificado el Script para que no marque el error para la respuesta anterior, este aun no se ejecuta para los enviados ni obtiene los demas datos que solicitas. voy a poner el cola lo que solicitas podria tardar algunas semanas en procesarlo, como les he comentado a otros usuarios tengo otros proyectos primero en fila y también es prioridad no descuidar quien paga las cuentas. Por el momento ajusta el Script con los enviados por mientras se procesa tu solicitud, estamos en contacto.

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      Dim dateFormat
      Dim getFrom
      Dim oFSO
      Set oFSO = CreateObject("Scripting.FileSystemObject")
      Set objShell = CreateObject("Wscript.Shell")
          dateFormat = Format(Now, "yyyy-mm-dd H-mm")
          getFrom = itm.SenderName
          saveFolder = "C:Archivos" & getFrom & "" & dateFormat & ""
          
      
      If Not oFSO.FolderExists(saveFolder) Then
        'objShell.Run ("cmd /c mkdir" & saveFolder)
        'Call objShell.Run("%COMSPEC% /c mkdir " & saveFolder, 0, True)
        CreateDirs saveFolder
      End If
      
           For Each objAtt In itm.Attachments
                objAtt.SaveAsFile saveFolder & objAtt.DisplayName
                Set objAtt = Nothing
                Set itm = Nothing
           Next
      End Sub
      
      Sub CreateDirs(MyDirName)
      
          Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          strDir = objFSO.GetAbsolutePathName(MyDirName)
          arrDirs = Split(strDir, "")
      
          If Left(strDir, 2) = "\" Then
              strDirBuild = "\" & arrDirs(2) & "" & arrDirs(3) & ""
              idxFirst = 4
          Else
              strDirBuild = arrDirs(0) & ""
              idxFirst = 1
          End If
      
          For i = idxFirst To UBound(arrDirs)
              strDirBuild = objFSO.BuildPath(strDirBuild, arrDirs(i))
              If Not objFSO.FolderExists(strDirBuild) Then
                  objFSO.CreateFolder strDirBuild
              End If
          Next
      
          Set objFSO = Nothing
      End Sub
      
  4. Hola!

    Te felicito por el articulo, pero tengo una duda…. La siguiente ruta del registro no existe en mi computador
    HKEY_CURRENT_USER\SOFTWARE\VB and VBA Program Settings\Outlook\received

    Debo crearla?????

    Saludos

  5. Hola Fernando! he realizado todos los pasos solicitados, pero al momento de ejecutar la macro… se abre la ventana donde se listan los nombres de todas las macros que han sido creadas con las opciones (ejecutar , cancelar, paso a paso, modificar, crear, eliminar). El problema es que no aparece el nombre de esta macro “CopyEmailToExcel….” favor ayúdame, SALUDOS!

    • Buen dia Fiscofre

      No te aparece en el listado de las macros al momento de crear la regla? o estas intentando ejecutar la macro desde el editor de Visual Basic?, si es lo 2do no te lo va a mostrar en ese listado ya que este debe ejecutarse desde una regla.

  6. Hola Fernando!

    Partiendo por felicitarte por todo tu trabajo y muchas gracias por la ayuda que entregas… quería ver si me puedes dar una mano con una macro… necesito crear una macro que me permita seleccionar la carpeta de donde yo quiero exportar los correos a un archivo excel… anteriormente me funcionaba sin problema… pero ahora me di cuenta que no me exporta todos los correos, ya que durante la ejecución se produce una interrupción con el error ’13’ (No coinciden los tipos). a continuación te dejo el código que usaba… sólo necesito exportar datos como la hora de envío, remitente, asunto(es lo mas importante que necesito…), espero me puedas ayudar.

    Sub ExportarAExcel()
    Dim olns As Outlook.Namespace
    Dim myInbox As Outlook.Folder
    Dim XLApp As Object
    Dim wkb As Object
    Dim wks As Object
    Dim StartCount As Long
    Dim myRecipient As Outlook.Recipient
    Dim outlookmessage As Outlook.MailItem
     
        Set olns = Outlook.GetNamespace("MAPI")
        Set myInbox = olns.PickFolder
       
        On Error Resume Next
        Set XLApp = GetObject(, "Excel.Application")
        If Err Then
            Set XLApp = CreateObject("Excel.Application")
       End If
        XLApp.Visible = True
          
        On Error GoTo 0
     
        Set wkb = XLApp.Workbooks.Add
        Set wks = wkb.Sheets(1)
        With wks
            StartCount = 1        
            For Each outlookmessage In myInbox.Items
                StartCount = StartCount + 1        
                .Range("A" & StartCount).Value = outlookmessage.ReceivedTime
                .Range("B" & StartCount).Value = outlookmessage.SenderName
                .Range("C" & StartCount).Value = outlookmessage.Subject
                .Range("D" & StartCount).Value = outlookmessage.SenderEmailAddress
                .Range("E" & StartCount).Value = outlookmessage.Body 
            Next
        End With
     
        Set olns = Nothing
        Set myInbox = Nothing
       
    End Sub
    • Olvidé comentarte que la macro la ejecuto desde un archivo excel, y se detiene en el “Next” Sólo me exporta 26 correos que han llegado a la bandeja de entrada, y ahí se detiene 🙁

      • Buen dia Felipe.

        Siempre son exactos 26 registros? puede que se este saliendo del rango de la hoja de Excel.
        Se debe declarar algo como:

        rCount = xlSheet.Range(“B” & xlSheet.Rows.Count).End(-4162).Row

        Para que tome el rango.

        Porque no adaptas el codigo publicado solo debes cambiar los valores en las lineas (lo que esta despues del punto Ej. “.SenderEmailAddress” por “.ReceivedTime”)

        strColC = olItem.SenderEmailAddress
        strColB = olItem.SenderName
        strColD = olItem.Subject
        strColE = olItem.To
        strColF = olItem.ReceivedTime

        por los tuyos.

        .Range(“A” & StartCount).Value = outlookmessage.ReceivedTime
        .Range(“B” & StartCount).Value = outlookmessage.SenderName
        .Range(“C” & StartCount).Value = outlookmessage.Subject
        .Range(“D” & StartCount).Value = outlookmessage.SenderEmailAddress
        .Range(“E” & StartCount).Value = outlookmessage.Body

        Saludos.

  7. Buenos dias Fernando,

    Estoy gestionando tu macro en mi outlook 2016 y cuando me llega un mail no me realiza el traspaso de información… He probado con otra macro para asegurar que la regla me funcione correctamente y me realiza la macro… Que puede ser que no me ejecute tu macro??

    Gracias

  8. Buenas de nuevo Fernando,

    Tras hacer diversas pruebas con la macro en mi PC funciona perfectamente (outlook 2016). Pero cuando copio la macro y pongo la misma configuracion en otro PC con versiones de outlook 2010 la macro no funciona, se que se ejecuta pq si le quito una declaración de variable me da error pero no me copia ninguna información… Puede ser por las versiones?

    Muchas gracias!

    • Buen dia Carlos

      Yo lo he utilizado en Outlook 2007 y 2013, mas no en 2010 pero esta raro ya que es una versión intermedio a la que lo he utilizado, si ejecuta cualquier otro macro? el anterior que estuviste utilizando si lo ejecutaba correctamente?

  9. Buen día Fernando, tu scrip me resulto excelente, pero no se si me puedas apoyar, manejo varias carpetas de cuentas compartidas en el correo y requiero que bajar la información igual estoy utilizando la exepcion de Outlook.Folder pero sin tener exito

        • Buen dia Clara

          Te paso la idea original de del Codigo el cual exporta a Excel los correos dentro de un folder

          Option Explicit
           Private Const xlUp As Long = -4162
          
          Sub CopyAllMessagesToExcel()
           Dim objOL As Outlook.Application
           Dim objItems As Outlook.Items
           Dim objFolder As Outlook.MAPIFolder
           Dim olItem As Outlook.MailItem
           Dim xlApp As Object
           Dim xlWB As Object
           Dim xlSheet As Object
           Dim vText, vText2, vText3, vText4, vText5 As Variant
           Dim sText As String
           Dim rCount As Long
           Dim bXStarted As Boolean
           Dim enviro As String
           Dim strPath As String
           Dim Reg1 As Object
           Dim M1 As Object
           Dim M As Object
                        
          'the path of the workbook
          strPath = "C:\1-Tests\test.xlsx"
               On Error Resume Next
               Set xlApp = GetObject(, "Excel.Application")
               If Err <> 0 Then
                   Application.StatusBar = "Please wait while Excel source is opened ... "
                   Set xlApp = CreateObject("Excel.Application")
                   bXStarted = True
               End If
               On Error GoTo 0
               'Open the workbook to input the data
               Set xlWB = xlApp.Workbooks.Open(strPath)
               Set xlSheet = xlWB.Sheets("Sheet1")
          
              'Find the next empty line of the worksheet
               rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
               rCount = rCount + 1
               
              Set objOL = Outlook.Application
              Set objFolder = objOL.ActiveExplorer.CurrentFolder
              Set objItems = objFolder.Items
           
              For Each olItem In objItems
           
                On Error Resume Next
          
               With olItem
               
               sText = olItem.Body
          
               Set Reg1 = CreateObject("VBScript.RegExp")
              ' \s* = invisible spaces
              ' \d* = match digits
              ' \w* = match alphanumeric
               
              With Reg1
                  .Pattern = "(Volume\s*(\d*)\s*Issue\s*(\d*))"
              End With
              If Reg1.Test(sText) Then
               
          ' each "(\w*)" and the "(\d)" are assigned a vText variable
                  Set M1 = Reg1.Execute(sText)
                  For Each M In M1
                     vText = Trim(M.SubMatches(1))
                     vText2 = Trim(M.SubMatches(2))
                  Next
            
            xlSheet.Range("B" & rCount) = vText
            xlSheet.Range("c" & rCount) = vText2
            xlSheet.Range("d" & rCount) = .Subject
            xlSheet.Range("e" & rCount) = .ReceivedTime
            'xlSheet.Range("f" & rCount) = vText5
          
          ' next line   
           rCount = rCount + 1
          
              End If
                ' do whatever
                 Debug.Print .Subject
               
               End With
              Next
               xlWB.Close 1
               If bXStarted Then
                   xlApp.Quit
               End If
               Set M = Nothing
               Set M1 = Nothing
               Set Reg1 = Nothing
               Set xlApp = Nothing
               Set xlWB = Nothing
               Set xlSheet = Nothing
               
              Set objItems = Nothing
              Set objFolder = Nothing
              Set objOL = Nothing
          
           End Sub
  10. Hola de nuevo

    ya pude hacer que funcione, de verdad muchas gracias.

    Tengo un problema, cada que llega un correo se cierra el excel y ademas el formato que aparece no me favorece para la visualización de la información

    hay algún modo de modificar el formato??

    y como puedo evitar que se cierre el excel?

    saludos y de antemano gracias

      • Hola Fernando de verdad muchísimas gracias, solo me queda otra duda, tengo configuradas dos cuentas de outlook, como puedo hacer que funcione el script solo con una de ellas??

        saludos

        y de antemano gracias!

        • Buen dia Isaac

          Al momento de crear la regla en el paso uno te permite seleccionar cual cuenta (through the specified account)[a través de la cuenta especificada] donde vas a seleccionar cual cuenta es en la que deseas ejecutar el script.

          Saludos.

  11. hola fernando una consulta quiero ejecutar una macro que reenvia correo que llega ala bandeja de entrada , encontre en internet un codigo te lo adjunto :
    Private Sub Application_Startup()
    ‘ esta será la carpeta inspeccionada.
    Set oFolderItems = Session.Folders(“[email protected]”).Folders(“Bandeja de entrada”).Folders(“NOVEDAD”).Items
    End Sub

    ‘Private Sub Application_Quit()

    ‘ MsgBox “Goodbye, ” & Application.GetNamespace(“MAPI”).CurrentUser

    ‘End Sub
    Private Sub Application_Quit()
    Set oFolderItems = Nothing
    End Sub

    Private Sub oFolderItems_ItemAdd(ByVal Item As Object)

    Dim oMsg As MailItem
    Dim oMoveToFolder As Outlook.MAPIFolder
    Dim oNameSpace As Outlook.NameSpace
    Dim i, j As Integer

    Set oNameSpace = Application.GetNamespace(“MAPI”)
    ‘ esta será la carpeta a la que moveremos los mensajes una vez procesados (enviados)
    Set oMoveToFolder = oNameSpace.Folders(“[email protected]”).Folders(“Bandeja de entrada”).Folders(“Bryan”)

    On Error GoTo ErrorHandler

    j = oFolderItems.Count
    ProgressBox.Percent = 0
    ProgressBox.Text = “Wait…..”
    ProgressBox.Show

    For i = 1 To j
    If i 1 Then
    ExecPause 1
    End If
    Set oMsg = Application.CreateItem(olMailItem)
    ‘Debug.Print oFolderItems(1).Subject

    oMsg.Body = oFolderItems(1).Body
    oMsg.Subject = oFolderItems(1).Subject
    ‘ a continuación la dirección de correo electrónico donde serán reenviados los mensajes.
    oMsg.Recipients.Add “[email protected]
    oMsg.Send
    ProgressBox.Increment (100 * i) / j, “Procesado ” & oFolderItems(1).Subject
    ExecPause 1
    oFolderItems(1).Move oMoveToFolder
    Set oMsg = Nothing
    Next

    ProgressBox.Hide
    Set oNameSpace = Nothing
    Set oMoveToFolder = Nothing

    ProgramExit:
    Exit Sub
    ErrorHandler:
    MsgBox Err.Number & ” – ” & Err.Description
    Resume ProgramExit

    End Sub

    Private Sub ExecPause()
    iPauseTime As Integer
    Start = Timer
    Do While Timer < Start + iPauseTime
    DoEvents
    Loop
    Finish = Timer
    End Sub

    .. lo coipie en en thisoutlokksession , pero no se ejcuta nada tienes alguna idea de como ejecutar esta macro ya uqe la necesito para mi trabajo MICROFSOTF 2010..

    Saludos

  12. Buen día Fernando, quisiera saber si puedes colaborarme con los siguiente ando con la creación de un sistema que ayude a la asignación y respuesta de solicitudes que llegan al area, por lo cual necesito que Excel extraiga los asuntos y quien envía el correo y del mismo modo cuando sea contestado el correo me notifique de alguna manera en el Excel

    quedaría super agradecido si me ayudaras, cualquier duda o sí no fui claro dime si por otro medio es más fácil tu colaboració

    • Buen dia Gabriel

      El Script lo que hace es leer los datos de cada correo recibido y escribirlos en una hoja de excel llevando un contador para no sobrescribir renglones.
      De ahí en fuera requieres ligar los correos mediante un ID, realizar la búsqueda en Excel del mismo para obtener el numero de renglón y escribir que fue contestado.
      Creo que te sera mas fácil escribir un script nuevo a modificar este ya que a lo comentado es 1/4 de lo que requieres.

      Saludos.

  13. Hola Fernando, ante mano muchas gracias por tu tiempo para responder las preguntas, soy nuevo en el foro y quisiera saber sí existe una manera de copiar el código ya que no me deja seleccionarlo debe ser porque es una imagen.

    al mismo tiempo quisiera comentarte lo siguiente necesito de alguna manera extraer la información de la bandeja de entrada de una cuenta de outlook a excel extrayendo datos como hora y fecha de recibido quien lo envía y el asunto, pero a su vez necesito que cuando este correo sea respondido al que lo envié en excel me diga en otra casilla respondido, de verdad quedaría suprema mente agradecido con tu ayuda.

    • Buen dia Gabriel.

      Te envíe el código que quieres copiar vía correo electrónico, respecto a lo que comentas los datos que extrae del correo se especifican en las lineas 47 a 52. el cual son las siguientes:

      strColB = olItem.senderName ‘Remitente
      strColC = olItem.SenderEmailAddress ‘ Correo electronico remitente
      strColD = olItem.Subject ‘Asunto
      strColE = olItem.Body ‘Cuerpo de correo
      strColF = olItem.To ‘Destinatario
      strColG = olItem.ReceivedTime ‘Fecha y hora de recepción

      De ahí en fuera para que te capture en el Excel si fue respondido requieres ligar los correos mediante un ID, realizar la búsqueda en Excel del mismo para obtener el numero de renglón y escribir que fue contestado / respondido.

      Lamentablemente, tenemos unos proyectos en puerta y no estamos realizando personalizaciones; tenemos ya bastantes solicitudes el cual en algún momento deseamos responder.

      Saludos.

    • Buen dia Gabriel

      Que versión de Office utilizas?

      Lo primero para trabajar con los scripts es tener habilitados los macros, para esto en Opciones > ajustes de centro de confianza > configuración de macro en este los habilitas.
      Después abres el editor de VBA de Office en este caso en Outlook, abres un nuevo Modulo y pegas código del vbscript.

      Es ta mejor explicado en el siguiente articulo: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript)

      Una vez lo anterior debes crear una regla, donde cada que cumpla las condiciones que especifiques se ejecutara el script. (Si no cumple las condiciones configuradas no realizara accion alguna).

      Outlook – Crear y configurar reglas

      si utilizas Office 2016

      Me comentas si se ejecuta.

      Saludos.

      • Hola Fernando muchas gracias por tu colaboración, ya me funciono , te tengo tres preguntas si no es mucha molestia

        1) es posible separar la fecha y hora de llegada del correo, para que queden en dos celdas diferentes?

        2) Es posible delimitar el cuerpo del mensaje que queda en el excel?,esto lo necesito porque muchos correos vienen con firmas y espacios entre sí haciendo que la celda de cuerpo quede muy extensa

        3) Es posible reinicar el contador?? es q usando un archivo nuevo para extraer los correos me empieza en número de celdas muy adelantado

        Muchas gracias por tu tiempo y ayuda

        • Buen dia Gabriel

          Me alegra que ya te haya funcionado el script, te anexo un codigo respondiendo tus consultas.

          1.- Si es posible, se agrego una nueva columna linea 54; en las lineas 53 y 54 se agrego el formato.
          2.- También se agrego en la linea 51 el limite, yo lo limite a 50, tu lo puedes ajustar al numero de caracteres que desees.
          3.- También es posible reiniciar, en el punto 7 del articulo se explica como hacer esto; si va a ser frecuente te recomiendo que exportes el registro asi cada que quieres reiniciarlo solo ejecutas el archivo del registro. entra al siguiente articulo: Como realizar un respaldo del registro de Windows para que veas la idea.

          Código

          Option Explicit
          Public Sub CopyEmailToExcelWhenArrive(olItem As Outlook.MailItem)
           Dim xlApp As Object
           Dim xlWB As Object
           Dim xlSheet As Object
           Dim rCount As Long
           Dim bXStarted As Boolean
           Dim enviro As String
           Dim strPath As String
           Dim iDefault As Long
          'Declare registry
           Dim sKey As String
           Dim lRegValue As Long
           Dim sAppName As String
           Dim sSection As String
          'Set name of registry keys
           sAppName = "Outlook"
           sSection = "received"
           sKey = "Current Value Number XLS"
           iDefault = 2
           lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
           
           Dim currentExplorer As Explorer
           Dim Selection As Selection
           Dim obj As Object
           Dim strColB, strColC, strColD, strColE, strColF, strColG, strColH As String
                      
          ' Get Excel set up
          'the path of the workbook
           strPath = "C:\1-Tests\test.xlsx"
               On Error Resume Next
               Set xlApp = GetObject(, "Excel.Application")
               If Err  0 Then
                   Application.StatusBar = "Please wait while Excel source is opened ... "
                   Set xlApp = CreateObject("Excel.Application")
                   bXStarted = True
               End If
               On Error GoTo 0
               'Open the workbook to input the data
               Set xlWB = xlApp.Workbooks.Open(strPath)
               Set xlSheet = xlWB.Sheets("Test")
              ' Process the message record
               
              On Error Resume Next
              
           'collect the fields
               strColB = olItem.SenderName
               strColC = olItem.SenderEmailAddress
               strColD = olItem.Subject
               'Left(string,length)
               strColE = Left(olItem.Body, 50)
               strColF = olItem.To
               strColG = FormatDateTime(olItem.ReceivedTime, 2)
               strColH = FormatDateTime(olItem.ReceivedTime, 3) 'Cambiar por 4 si se desea en formato de 24 horas.
               
          'write them in the excel sheet
            xlSheet.Range("B" & lRegValue) = strColB
            xlSheet.Range("c" & lRegValue) = strColC
            xlSheet.Range("d" & lRegValue) = strColD
            xlSheet.Range("e" & lRegValue) = strColE
            xlSheet.Range("f" & lRegValue) = strColF
            xlSheet.Range("g" & lRegValue) = strColG
            xlSheet.Range("h" & lRegValue) = strColH
            
          'Save registry row increment
           SaveSetting sAppName, sSection, sKey, lRegValue + 1
           
               xlWB.Close 1
               If bXStarted Then
                   xlApp.Quit
               End If
               
               Set olItem = Nothing
               Set obj = Nothing
               Set currentExplorer = Nothing
               Set xlApp = Nothing
               Set xlWB = Nothing
               Set xlSheet = Nothing
           End Sub

          Saludos.

          • Hoa,Fernando muchas gracias por tu ayuda ha sido de mucha ayuda, por ahora no te molestaré más, si llego a tener alguna duda o inconveniente espero contar con tu ayuda muchas gracias

          • Hola Fernando, que pena contigo quisiera saber si puedes ayudarme con otra cosa, requiero hacer que cada correo que sea enviado desde mi cuenta no quede una copia guardada en elementos enviados, sino que quede en una carpeta local creada, eso es posible??? esto con el fin de no oucpar espacio del correo

  14. Por algún motivo me deja el body en blanco utilizando tu script tal cual. Me genera información sobre el título del e-mail y sobre la hora de recibirlo pero con el body (que es lo que necesito) no me funciona 🙁 que puede ser?

    • Buen dia Sergio

      En ocasiones cuando el correo trae saltos de linea se visualiza en Excel como celda en blanco, pero si revisas la celda la información si se encuentra ahí, nos confirmas.
      Si te marca algún otro mensaje o error nos comentas para tener alguna noción de lo que puede causar el inconveniente.

      Saludos.

  15. Buenas tardes Fernando,

    ENHORABUENA por tus artículos porque son geniales y muy didácticos! El script de este artículo me funciona perfectamente, aunque voy a necesitar una modificación, me gustaría desglosar la información de los correos (que son todos iguales) por columnas. Si el body de mi correo es:

    Event: ENTERED: HW Danger/Alarm 2
    Location: Grupo 4\Grupo 4\Alternador\Rotor\Cojinete6\6C
    Severity: 4
    Date/Time: 4/5/2017 1:10:27 PM

    Quiero obtener en Excel los datos repartidos en 4 columnas:

    Event Location Severity Date/Time

    ¿Es posible con el mismo macro? ¿o hay que hacer uno a parte en Excel para que ponga todos los datos en orden?

    Gracias de antemano y un saludo!!

    • Buen dia Irene

      El script esta desarrollado para tomar el texto plano de cada variable y lo transportarlo a una celda especifica en Excel; no manipula el texto, en este caso el body o cuerpo de correo para el script es un solo elemento.

      Tendrías que utilizar algún Delimited Text-to-Columns en Excel para crear la macro para separarlo por el primer símbolo “:” y aplicar Transpose a los datos aun que creo que hay una formula para esto ultimo.

      Saludos.

      • Buenas Fernando,

        Muchas gracias por tu eficacia respondiendo. Ya solucioné el problema y ahora tengo un par de preguntas más:
        – ¿Es posible almacenar el número de fila en un archivo distinto a HKEY_CURRENT_USER? Ya que tengo el acceso a esa carpeta restringido con usuario de administrador en el trabajo.
        – Si durante la noche cuando no uso el pc llega algún correo de los que debe copiarse, ¿se copia en excel en el momento que llega, al día siguente cuando abro outlook o no se pasa?

        Gracias otra vez de antemano, un saludo!

        • Buen dia Irene.

          1.- Pudemos intentar tomar el ultimo registro con datos con lo siguiente:

          Sustituye la linea 21 por esto:

          lRegValue = xlSheet.Range(“B” & xlSheet.Rows.Count).End(-4162).Row
          ‘Requerido en Outlook 2016, eliminar si crea registros en blanco
          lRegValue = lRegValue + 1

          Sustituye la linea 64 por esto:
          lRegValue = lRegValue + 1

          2.- Outlook debe estar abierto para ejecutar el script, una vez que se abre (al dia siguiente) este va a procesar todos los correos que cargue en el mailbox.

          Nos comentas
          Saludos.

          • Muchas gracias Fernando, paralelamente lo estaba intentando con Access y por ahora creo que me voy a quedar ahí. Pero he aprendido mucho con tu blog y me llevo una visión estupenda de tu trabajo. Muchas gracias por tu gran ayuda.

  16. Quiero saber si es posible, que con una macro se pueda contestar un correo en especifico de Outlook o tengo que crear desde cero el correo con Subject, destinararios, etc..

  17. Buenas Fernando, oye crees q se podría hacer algo para desde una carpeta de outlook determinada pasar todos los correos que hubiera en esta a excel?
    Lo necesario sería el destinatario y el cuerpo del correo que vendría a ser una tabla, pegando en una hoja de excel, pero uno debajo de otro.

    Gracias.

      • Con el seundo código ya se lo lleva al excel.
        Fernando lo que me ocurre es que el cuerpo del correo lo deja todo en una misma celda, ¿sabes si se podría poner por celdas independientes, como en columnas?

        Ejemplo:

        Destalinatario: [email protected]
        Cuerpo del correo:

        A B C D

        1111 12 15 17
        1111 16 19 13
        1111 22 23 56

        Imagina que es una tabla en el cuerpo del correo recibido, y que lo que pretendo es que tal y como hace tu código se lo lleve a excel, pero que no me cambie la forma de la tabla, ubicando cada columna de la tabla del correo en columnas diferentes en excel.

        Gracias.

        • Buen dia Manuel

          En el actual código simplemente copia el texto tal cual sin manipular el contenido lo pega en texto plano a la celda correspondiente de Excel.
          Se puede implementar para leer los elementos tabla de los correos pero si toma bastante tiempo, lo mas simple mas no es lo optimo es copiar el cuerpo de correo el problema si contiene mas texto, prueba el siguiente:

          Option Explicit
          Public Sub CopyEmailToExcelWhenArrive() 'olItem As Outlook.MailItem)
           Dim olItem As Outlook.MailItem
           Dim xlApp As Object
           Dim xlWB As Object
           Dim xlSheet As Object
           Dim rCount As Long
           Dim bXStarted As Boolean
           Dim enviro As String
           Dim strPath As String
           Dim iDefault As Long
          'Prueba Tabla
           Dim doClip As MSForms.DataObject
          'Bloque Registro Declarar Registro - Se puede eliminar si no se utiliza
           Dim sKey As String
           Dim lRegValue As Long
           Dim sAppName As String
           Dim sSection As String
          'Dar nombre a las llaves de registro - Se puede eliminar si no se utiliza
           sAppName = "Outlook"
           sSection = "received"
           sKey = "Current Value Number XLS"
           iDefault = 2
           lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
          
          'Fin Bloque Registro
          
           Dim currentExplorer As Explorer
           Dim Selection As Selection
           Dim objOL As Outlook.Application
           Dim objFolder As Outlook.MAPIFolder
           Dim objItems As Outlook.Items
           Dim obj As Object
           
           Dim strColB, strColC, strColD, strColE, strColF, strColG As String
                      
          'Iniciar Excel
          'Ruta del Excel
           strPath = "C:\1-Tests\test.xlsx"
               On Error Resume Next
               Set xlApp = GetObject(, "Excel.Application")
               If Err  0 Then
                   Application.StatusBar = "Please wait while Excel source is opened ... "
                   Set xlApp = CreateObject("Excel.Application")
                   bXStarted = True
               End If
               On Error GoTo 0
               'Abre la hoja de calculo
               Set xlWB = xlApp.Workbooks.Open(strPath)
               'Especificar nombre de hoja de calculo
               Set xlSheet = xlWB.Sheets("Sheet1")
               'Lee el ultimo registro de la hoja de calculo
               'lRegValue = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
               ' Requerido para Outlook 2016 -  si genera espacios en blanco
               'lRegValue = lRegValue + 1
               
              On Error Resume Next
              
              'Bloque para leer folder actual- se puede remover si no se utiliza
              Set objOL = Outlook.Application
              'Cambiar CurrentFolder por Selection para exportar selecció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 = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
              ' Requerido para Outlook 2016 -  si genera espacios en blanco
              lRegValue = lRegValue + 1
          
              Set olItem = obj
              Set doClip = New MSForms.DataObject
                  doClip.SetText olItem.HtmlBody
                  doClip.PutInClipboard
                  
           'Recolecta los datos
               strColB = olItem.SenderName
               strColC = olItem.SenderEmailAddress
               strColD = olItem.Subject
               strColE = olItem.Body
               strColF = olItem.To
               strColG = olItem.ReceivedTime
               
          ' Obtener las direcciones Exchange - Se puede remover si no se utiliza Exchange
           Dim olEU As Outlook.ExchangeUser
           Dim oEDL As Outlook.ExchangeDistributionList
           Dim recip As Outlook.Recipient
           Set recip = Application.Session.CreateRecipient(strColB)
          
           If InStr(1, strColC, "/") > 0 Then
               Select Case recip.AddressEntry.AddressEntryUserType
                 Case OlAddressEntryUserType.olExchangeUserAddressEntry
                   Set olEU = recip.AddressEntry.GetExchangeUser
                   If Not (olEU Is Nothing) Then
                       strColC = olEU.PrimarySmtpAddress
                   End If
                 Case OlAddressEntryUserType.olOutlookContactAddressEntry
                   Set olEU = recip.AddressEntry.GetExchangeUser
                   If Not (olEU Is Nothing) Then
                      strColC = olEU.PrimarySmtpAddress
                   End If
                 Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
                   Set oEDL = recip.AddressEntry.GetExchangeDistributionList
                   If Not (oEDL Is Nothing) Then
                      strColC = olEU.PrimarySmtpAddress
                   End If
               End Select
          End If
          'Finaliza Seccion de Exchange
           
          'Escribe valores en hoja de calculo
            xlSheet.Range("A" & lRegValue) = "Sender Name"
            xlSheet.Range("B" & lRegValue) = strColB
            lRegValue = lRegValue + 1
            xlSheet.Range("A" & lRegValue) = "Sender Email"
            xlSheet.Range("B" & lRegValue) = strColC
            lRegValue = lRegValue + 1
            xlSheet.Range("A" & lRegValue) = "Subject"
            xlSheet.Range("B" & lRegValue) = strColD
            lRegValue = lRegValue + 1
            xlSheet.Range("A" & lRegValue) = "To"
            xlSheet.Range("B" & lRegValue) = strColF
            lRegValue = lRegValue + 1
            xlSheet.Range("A" & lRegValue) = "Received Time"
            xlSheet.Range("B" & lRegValue) = strColG
            lRegValue = lRegValue + 1
            xlSheet.Range("A" & lRegValue) = "Body"
            xlSheet.Range("B" & lRegValue).PasteSpecial "Text" '= strColE
            lRegValue = lRegValue + 1
          
            
            'Si no se lee folder actual remover
            Next
            
          'Guarda el registro - Si se utiliza registro remover el '
           'SaveSetting sAppName, sSection, sKey, lRegValue + 1
           
               xlWB.Close 1
               If bXStarted Then
                   xlApp.Quit
               End If
               
               Set olItem = Nothing
               Set obj = Nothing
               Set currentExplorer = Nothing
               Set xlApp = Nothing
               Set xlWB = Nothing
               Set xlSheet = Nothing
           End Sub

          No olvides seguirnos para que estés enterado de nuestros últimos artículos.

          Saludos.

          • Fernando, para que antes de ejecutar el código se pueda elegir una carpeta con un nombre concreto de forma automática cómo se haría.

            Es para que cuando haga clic en el botón de comando se seleccione la carpeta en cuestión y no otra que no desee.
            Gracias.

          • Buen dia Manuel

            Remplaza la linea 62 por estas tres lineas

                Dim ns As NameSpace
                Set ns = GetNamespace("MAPI")
                Set objFolder = ns.GetDefaultFolder(olFolderInbox).Folders("Test")
            

            Saludos.

  18. Oye Fernado, estoy trabajando con la segunda parte del código que me pasaste, ahora es sobre excel; tengo que limpiar mucho texto y organizar después de pegar los cuerpor de los correos.

    Busco algún bucle que se ejecute siempre y cuando se cumpla una condición.

    Ejemplo Hoja Excel

    A B C
    1 X 1 2
    2 1
    3 4 2
    4 Y 1
    5 3

    Lo que busco es que en la columna A tome el primer valor de la misma y lo pegue hacia abajo siempre y cuando en la columna B tenga algún valor. Quedaría así:

    A B C
    1 X 1 2
    2 X 1
    3 X 4 2
    4 Y 1
    5 Y 3

    Gracias

    • Buen dia Manuel

      Para eso hay que leer la tabla enviada en el correo y crear las condiciones que requieres, si es algo que deseas aplicar te podemos cotizar el desarrollo de un vbscript que cumpla exactamente con lo que requieres; el cual primero requerimos ponernos en contacto para tener tus requerimientos.

      Quedamos a la espera.

      Saludos.

  19. Buen día Fernando, estoy copiando exactamente el código como lo publicas, el excel tal cual mencionas pero no ocurre nada, no aparece nada en el archivo Excel. Que sugeris? Gracias.

      • Se resolvió habilitando desde centro de confianza para cualquier macro en ambas aplicaciones, Outlook y Excel.

        Otro problema que esta sucediendo: los registros aparecen a partir de la fila 10 o 12, muy abajo, por mas formateado que este el excel, tambien cada tanto deja alguna fila vacía, a que se debe esto? algo a corregir en alguna linea?

        Gracias.

    • Buen dia Jaime

      Para realizarlo automáticamente te recomiendo utilizar Excel puedes eliminar del script la lectura de los campos que no requieres, de otra forma puedes exportar los datos de un correo en especifico a un archivo de texto te adjunto un ejemplo, automáticamente no es posible a TXT con el script adjunto ya que al abrirlo te remplaza el texto.

      Sub saveAllEmailSubjectInFolderToTXT()
      Dim objItem As Outlook.MailItem
      Dim sText As String
      Dim objFS
      Set objFS = CreateObject("Scripting.FileSystemObject")
      Dim sFile As String
      Dim objFile
      sFile = "C:\1-Tests\321.txt"
      
      Set objFile = objFS.CreateTextFile(sFile, False)
      
      For Each objItem In ActiveExplorer.CurrentFolder.Items
       With objFile
          .Write vbCrLf & "--Inicio--" & vbCrLf
          .Write "Subject: " & objItem.Subject & vbCrLf & vbCrLf
          .Write vbCrLf & "--Fin--" & vbCrLf
       End With
      Next
        objFile.Close
      End Sub

      Saludos.

  20. Muy buenas!!

    Yo concretamente me estoy volviendo loco, no veo porque me salta todo el rato este error:

    No se ha definido el tipo definido por el usuario. y el error es en la linea ” Dim currentExplorer As Explorer”

    Mil gracias por tu ayuda,
    Sven G.D.

    • Buen dia SvenGD

      Esa linea no se utiliza en el código publicado mas la deje para otro implementar fácilmente por selección, Elimina las lineas 23, 24 y 73, nos comentas si te deja de marcar el error

      Saludos.

  21. Buenas Fernando

    Nada no hay manera… no se que ando haciendo mal. Agradezco de todas formas tu contestación y ayuda. Te felicito por tu trabajo con esto.

    No se si seria posible que subieras un archivo sample donde este todo esto.

    Mil gracias!!
    Sven G.D.

    • Buen dia SvenGD

      ¿Que ocupas en el archivo de ejemplo?

      En que lineas te marca el error?

      Puedes intentar con este codigo, lo depure mas no se si ejecute correctamente ya que no tuve tiempo para realizar prueba.

      Option Explicit
      Public Sub CopyEmailToExcelWhenArrive(olItem As Outlook.MailItem)
       Dim xlApp As Object
       Dim xlWB As Object
       Dim xlSheet As Object
       Dim bXStarted As Boolean
       Dim strPath As String
       Dim lRValue As Long
      'Set name of registry keys
      lRValue = xlSheet.Range(“B” & xlSheet.Rows.Count).End(-4162).Row
       
       Dim strColB, strColC, strColD, strColE, strColF, strColG As String
                  
      ' Get Excel set up
      'the path of the workbook
       strPath = "C:\1-Tests\test.xlsx"
           On Error Resume Next
           Set xlApp = GetObject(, "Excel.Application")
           If Err <> 0 Then
               Application.StatusBar = "Please wait while Excel source is opened ... "
               Set xlApp = CreateObject("Excel.Application")
               bXStarted = True
           End If
           On Error GoTo 0
           'Open the workbook to input the data
           Set xlWB = xlApp.Workbooks.Open(strPath)
           Set xlSheet = xlWB.Sheets("Test")
          ' Process the message record
           
          On Error Resume Next
          
       'collect the fields
           strColB = olItem.senderName
           strColC = olItem.SenderEmailAddress
           strColD = olItem.Subject
           strColE = olItem.Body
           strColF = olItem.To
           strColG = olItem.ReceivedTime
           
       
      'write them in the excel sheet
        xlSheet.Range("B" & lRValue) = strColB
        xlSheet.Range("c" & lRValue) = strColC
        xlSheet.Range("d" & lRValue) = strColD
        xlSheet.Range("e" & lRValue) = strColE
        xlSheet.Range("f" & lRValue) = strColF
        xlSheet.Range("g" & lRValue) = strColG
        
      'Save registry row increment
       lRValue = lRValue + 1
       
           xlWB.Close 1
           If bXStarted Then
               xlApp.Quit
           End If
           
           Set olItem = Nothing
           Set xlApp = Nothing
           Set xlWB = Nothing
           Set xlSheet = Nothing
       End Sub
      
  22. saludos y gracias por todo lo que haces aqui, es de muchisima ayuda.

    Llegue a tu blog buscando la solución aun problema, tengo que enviar la información de outlook de los correos de una carpeta en especifico, y que se copien los valores de fecha y hora de recepción, subject, y además la fecha y hora en la que se marca como terminado. Me tomaré el tiempo necesario para leer todos los aportes que diste para buscar la solución a este problema. De momento lo hago manual arrastrando los correos a la hoja de excel con la que trabajo.

    Saludos

    • Buen dia Angel

      Gracias por los buenos comentarios y seguirnos.

      Si con fecha y hora en la que se marca como terminado te refieres a cuando se marco como leído el correo; el modelo de objetos de Outlook no proporciona datos de este estado (Leído o no leído). [Bueno al menos no tengo conocimiento de una forma para obtener el dato ver propiedades MailItem] de esto en fuera lo demás si se puede obtener, esperamos te sea de utilidad.

      Saludos.

  23. Hola Fernando, buen día

    Voy descubriendo el sitio y tus aportes, muy completos y que labor tan noble, muchas gracias.

    Estoy viendo que el código es para los correos que llegan, ¿habrá la forma de cambiarlo por los de salida? Viendo el destinatario. Ya que deseo hacer un conteo de los correos que le envío a cada uno de los clientes con fecha, para llevar un control, me sería muy útil.

    ¿Me ayudas?
    saludos y muchas gracias de antemano.

    • Buen dia Manuel

      Para ejecutar el script al momento de enviar un correo electronico lamentablemente no es posible desde las reglas de Outlook, debe ser desde ThisOutlookSession en el editor de VB el cual se ejecutara para todo correo enviado.
      Debes pegar el codigo en ThisOutlookSession cambiar la segunda linea por:

      Private Sub Application_ItemSend(ByVal olItem As Object, Cancel As Boolean)

      y listo.
      Ejemplo:

      VBScript - ThisOutlookSession - Ejemplo
      El inconveniente sera que se aplicara para todo correo enviado y no es configurable como las reglas, si deseas aplicar condiciones se deberan realizar por medio de codigo.

      Saludos.

      • Hola Fernando,

        Muchas gracias por tu labor, me estaba volviendo loco ya que he buscado por todos lados lo siguiente: deseo tomar de Outlook la información de la carpeta de enviados, por lo que entiendo el código que has puesto aquí es para los correos que se van enviando y lo que yo quiero es tomar la información (fecha de enviado, cuerpo del correo, de, para, de todos los correos de la carpeta enviados ¿es eso posible?

        • Buen dia Omar

          El código que se menciona en el tercer ejemplo te exporta lo que se encuentre en el folder seleccionado, este lo puedes adaptar a tus necesidades, si lo requieres de forma vertical los primeros ejemplos lo exportan de esa forma solo debes realizar el cambio en la parte que obtiene y escribe la información; El codigo se encuentra comentado para facilitarles realizar los cambios.

          Exelente dia.

  24. Hola Fernando

    Muchas gracias por todo tu aporte, ayudas a muchos en su dia a dia, tengo un problema, cuando le di aplicar a la regla me salio un error de depuracion y me manda a la ventana del VBA y me señala la linea 21 como no reconocido, luego he visto que has modificado el script y pegue el ultimo que publicaste en el comentario de SvenGD 26 mayo, 2017 at 1:43 am.
    Pero ahora la linea 2 me da error también de no reconocido, pls tu ayuda no logro hacerla funcionar.

    • Buen dia Juan

      Me puedes comentar la version de Office que utilizas, de igual forma prueba el siguiente script.

      Option Explicit
      Public Sub CopyEmailToExcelWhenArrive(olItem As Outlook.MailItem)
       Dim xlApp As Object
       Dim xlWB As Object
       Dim xlSheet As Object
       Dim rCount As Long
       Dim bXStarted As Boolean
       Dim enviro As String
       Dim strPath As String
       Dim iDefault As Long
      'Declare registry
       Dim sKey As String
       Dim lRegValue As Long
       Dim sAppName As String
       Dim sSection As String
      'Set name of registry keys
       sAppName = "Outlook"
       sSection = "received"
       sKey = "Current Value Number XLS"
       iDefault = 2
       'lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
       
       Dim currentExplorer As Explorer
       Dim Selection As Selection
       Dim obj As Object
       Dim strColB, strColC, strColD, strColE, strColF, strColG As String
                  
      ' Get Excel set up
      'the path of the workbook
       strPath = "C:\1-Tests\test.xlsx"
           On Error Resume Next
           Set xlApp = GetObject(, "Excel.Application")
           If Err <> 0 Then
               Application.StatusBar = "Please wait while Excel source is opened ... "
               Set xlApp = CreateObject("Excel.Application")
               bXStarted = True
           End If
           On Error GoTo 0
           'Abre la hoja de calculo
           Set xlWB = xlApp.Workbooks.Open(strPath)
           'Especificar nombre de hoja de calculo
           Set xlSheet = xlWB.Sheets("Sheet1")
           'Lee el ultimo registro de la hoja de calculo
           lRegValue = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
           ' Requerido para Outlook 2016 -  si genera espacios en blanco
           lRegValue = lRegValue + 1
           
          On Error Resume Next
          
       'collect the fields
           strColB = olItem.senderName
           strColC = olItem.SenderEmailAddress
           strColD = olItem.Subject
           strColE = olItem.Body
           strColF = olItem.To
           strColG = olItem.ReceivedTime
      	 
      ' Obtener las direcciones Exchange - Se puede remover si no se utiliza Exchange
       Dim olEU As Outlook.ExchangeUser
       Dim oEDL As Outlook.ExchangeDistributionList
       Dim recip As Outlook.Recipient
       Set recip = Application.Session.CreateRecipient(strColB)
      
       If InStr(1, strColC, "/") > 0 Then
           Select Case recip.AddressEntry.AddressEntryUserType
             Case OlAddressEntryUserType.olExchangeUserAddressEntry
               Set olEU = recip.AddressEntry.GetExchangeUser
               If Not (olEU Is Nothing) Then
                   strColC = olEU.PrimarySmtpAddress
               End If
             Case OlAddressEntryUserType.olOutlookContactAddressEntry
               Set olEU = recip.AddressEntry.GetExchangeUser
               If Not (olEU Is Nothing) Then
                  strColC = olEU.PrimarySmtpAddress
               End If
             Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
               Set oEDL = recip.AddressEntry.GetExchangeDistributionList
               If Not (oEDL Is Nothing) Then
                  strColC = olEU.PrimarySmtpAddress
               End If
           End Select
      End If
      'Finaliza Seccion de Exchange
           
       
      'write them in the excel sheet
        xlSheet.Range("B" & lRegValue) = strColB
        xlSheet.Range("c" & lRegValue) = strColC
        xlSheet.Range("d" & lRegValue) = strColD
        xlSheet.Range("e" & lRegValue) = strColE
        xlSheet.Range("f" & lRegValue) = strColF
        xlSheet.Range("g" & lRegValue) = strColG
        
      'Save registry row increment
       'SaveSetting sAppName, sSection, sKey, lRegValue + 1
       
           xlWB.Close 1
           If bXStarted Then
               xlApp.Quit
           End If
           
           Set olItem = Nothing
           Set obj = Nothing
           Set currentExplorer = Nothing
           Set xlApp = Nothing
           Set xlWB = Nothing
           Set xlSheet = Nothing
       End Sub
  25. Buenos días Estimado,

    De antemano agradecerte por tu aporte, ha sido muy valioso para el trabajo de medición que estamos haciendo en mi labor diaria.

    Te quisiera pedir un apoyo respecto a la exportación de los corres enviados; he logrado configurar lo para que funcione y exporte a un 2do archivo en excel, pero al momento de registrarse la información, solo queda registrado el ultimo correo enviado.

    Por alguna razón, no crea un registro historico, sino que se sobreescribre y deja una sola linea en el excel.

    El script que uso es el siguiente:

    Option Explicit
    Private Sub Application_ItemSend(ByVal olItem As Object, Cancel As Boolean)
     Dim xlApp As Object
     Dim xlWB As Object
     Dim xlSheet As Object
     Dim rCount As Long
     Dim bXStarted As Boolean
     Dim enviro As String
     Dim strPath As String
     Dim iDefault As Long
    'Declare registry
     Dim sKey As String
     Dim lRegValue As Long
     Dim sAppName As String
     Dim sSection As String
    'Set name of registry keys
     sAppName = "Outlook"
     sSection = "received"
     sKey = "Current Value Number XLS"
     iDefault = 2
     'lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
     
     Dim currentExplorer As Explorer
     Dim Selection As Selection
     Dim obj As Object
     Dim strColB, strColC, strColD, strColE, strColF, strColG As String
                
    ' Get Excel set up
    'the path of the workbook
     strPath = "C:\1-Tests\test2.xlsx"
         On Error Resume Next
         Set xlApp = GetObject(, "Excel.Application")
         If Err  0 Then
             Application.StatusBar = "Please wait while Excel source is opened ... "
             Set xlApp = CreateObject("Excel.Application")
             bXStarted = True
         End If
         On Error GoTo 0
         'Abre la hoja de calculo
         Set xlWB = xlApp.Workbooks.Open(strPath)
         'Especificar nombre de hoja de calculo
         Set xlSheet = xlWB.Sheets("Test")
         'Lee el ultimo registro de la hoja de calculo
         lRegValue = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
         ' Requerido para Outlook 2016 -  si genera espacios en blanco
         lRegValue = lRegValue + 1
         
        On Error Resume Next
        
     'collect the fields
         strColB = olItem.ReceivedOnBehalfOfName
         strColC = olItem.SenderEmailAddress
         strColD = olItem.Subject
         strColE = olItem.Body
         strColF = olItem.To
         strColG = olItem.ReceivedTime
         
    ' Obtener las direcciones Exchange - Se puede remover si no se utiliza Exchange
     Dim olEU As Outlook.ExchangeUser
     Dim oEDL As Outlook.ExchangeDistributionList
     Dim recip As Outlook.Recipient
     Set recip = Application.Session.CreateRecipient(strColB)
    
     If InStr(1, strColC, "/") > 0 Then
         Select Case recip.AddressEntry.AddressEntryUserType
           Case OlAddressEntryUserType.olExchangeUserAddressEntry
             Set olEU = recip.AddressEntry.GetExchangeUser
             If Not (olEU Is Nothing) Then
                 strColC = olEU.PrimarySmtpAddress
             End If
           Case OlAddressEntryUserType.olOutlookContactAddressEntry
             Set olEU = recip.AddressEntry.GetExchangeUser
             If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
             End If
           Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
             Set oEDL = recip.AddressEntry.GetExchangeDistributionList
             If Not (oEDL Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
             End If
         End Select
    End If
    'Finaliza Seccion de Exchange
         
     
    'write them in the excel sheet
      xlSheet.Range("B" & lRegValue) = strColB
      xlSheet.Range("c" & lRegValue) = strColC
      xlSheet.Range("d" & lRegValue) = strColD
      'xlSheet.Range("e" & lRegValue) = strColE
      xlSheet.Range("f" & lRegValue) = strColF
      xlSheet.Range("g" & lRegValue) = strColG
      
    'Save registry row increment
     'SaveSetting sAppName, sSection, sKey, lRegValue + 1
     
         xlWB.Close 1
         If bXStarted Then
             xlApp.Quit
         End If
         
         Set olItem = Nothing
         Set obj = Nothing
         Set currentExplorer = Nothing
         Set xlApp = Nothing
         Set xlWB = Nothing
         Set xlSheet = Nothing
     End Sub
    • Buen dia Enrique

      En la linea 49 cambia la B por una C tal como se muestra a continuación

      lRegValue = xlSheet.Range("C" & xlSheet.Rows.Count).End(-4162).Row

      Este registro es para la persona que envia el correo como esta guardando los correos enviados no existe este registro.

      Saludos.

  26. Muchas gracias por toda la información que compartes, Fernando, ya que es de gran valor.
    Llevo muy poco tiempo programando y no consigo localizar una propiedad del correo que me permita identificar unívocamente un correo entrante y su relación con los correos salientes que sean contestación o reenvío del original. ¿Existe dicha variable?

    MI idea es tener una base de datos con las cabeceras de los correos entrantes, así como los correos salientes y comprobar el tiempo que se tarda en contestar un correo.

    Muchas gracias de antemano.

  27. Fernando buenas tardes,
    Una pregunta, necesito por favor saber cómo hacer para almacenar el asunto y remitente de un correo en un archivo.txt al momento de eliminarlo ya sea con el botón eliminar o con teclado.

    Agradecería enormemente tu ayuda.

  28. Gracias Fernando,
    He leído el artículo y hay un evento llamado BeforeDelete pero no se cómo implementarlo, podría ser esa la solución y me podrías dar una luz por favor con este tema

    • Buen dia Jhonatan

      El evento BeforeDelete solo funciona cuando se elimina el mensaje estando abierta la ventana fuera buena opción para ejecutar el script mas genera el inconveniente mencionado si se elimina del listado no realizara acción alguna, Leí que para realizar una acción utilizan BeforeItemMove mas tendría que buscar como se puede implementar al código actual.

  29. Buenas tardes Fernando:

    He usado la propiedad ConversationIndex, ya que la ConversationID, no siempre me da un valor cuando envío la respuesta a un correo.
    Utilizando esta opción, tengo los siguientes valores para un correo de entrada y su respuesta:

    Entrada———– ConversationIndex :01D2F1B640ADDFD648BF04AD4D13AB59F39056396B7D
    Salida———– ConversationIndex: 010209F763AA98FDB7D162BE51282D85423BEEC38EE4A1CF7DE320

    Como se puede observar no son iguales, ni tiene una parte en común.

    ¿puedes darme otra orientación?, ya que por más que investigo, no consigo obtener ninguna información clara.

    Gracias por tu ayuda.

  30. Buenas, es inmensamente eficaz toda la información que he podido contrastar en este artículo.
    Hasta hoy, ejecutaba genial una regla que me pasaba tal cuál mencionas en el ejemplo de este artículo, un body de un email y los demás campos, se generaba un registro (visible con REGEDIT) y lo pasaba todo estupendamente a una tabla Excel.
    Hará unos días dejé el portátil encendido y ejecuté una regla que comprobase una carpeta con más de 10.000 emails para pasar a un Excel tal cuál tu código, marcándome el inicio de una larga espera nocturna, y cuál es mi sorpresa cuando al día siguiente compruebo que se ha quedado detenido o mejor dicho “colgado” en la fila 3.400 aproximadamente del Excel. El Outlook no obedece por lo que me toca apagar y encender de nuevo.
    Pero mi problema empieza cuando vuelvo a ejecutar la regla, ya que no obedece en ningún momento.
    Mi necesidad me hace eliminar la regla, el Excel, volver a pegar el código en visual basic script, elimino el registro, y cuando lo genero todo de nuevo, no pasa nada al Excel, ni siquiera genera el registro, por lo que decido escribir al no saber qué más cosas probar…
    Eh aquí mi nivel de desesperación para tener que recurrir al “padre de mi aplicativo” que me deja todos los emails que necesito en un Excel para poder manipular dichos datos a mi antojo.

    Espero no haberte aburrido demasiado y puedas darme alguna pequeña solución de maestro experto en la temática tratada…
    Abrazos!

  31. Buen dia Jaime quisiera contar con tu acostumbrada colaboración; quisiera saber si es posible que cada vez que llegue un correo a mi bandeja de entrada se vaya a una carpeta específica si en el correo también va copia ciertos contactos, quedaría agradecido profundamente

  32. Hola Fernando como vas???, enserio que pena moelstarte tanto, pero necesito otra ayuda, necesito que al enviar los correos se vayan directamente a una carpeta del local, mirando las reglas solo deja enviar una copia, es posible que todo correo que sea enviado se vaya a una local sin que quede nada en al carpeta enviados del outlook?

  33. Buenos días Fernando, te hablo de Sinaloa, en busca de una solución que me están pidiendo en mi trabajo, me piden que en determinados correos que llegan a una bandeja, o mas bien los correos que tengan una tabla de solicitud de prestamos que venga ya rellenada obviamente por los clientes, se exporte a un excel, se puede agregar ademas de la tabla que viene en el cuerpo, el remitente asunto etc.
    este link de abajo es la imagen de la tabla que me mandaran rellenada los clientes.

    https://drive.google.com/open?id=0B9lgrdHyZlmhZ1ZWTXlEWXBTcG8

    ya se con un boton en una macro en excel o igual con VBA en un modulo al iniciar outllok, o cuando yo jale algun correo a determinada bandeja se active el script, o igual con el boton desde un excel que me exporte en una hoja por separado los correos con esa tabla , o en un excel diferente cada correo para tenerlos separados por cliente. lo que me puedas aportar sera de muchisima ayuda,,ya hice algunos ejemplos de algunos codigos que mencionas arriba, en la mayoria me marca error con el option explicit en esta linea de codigo:
    Set olItem = obj

  34. Se que es mucho pedir, soy practicante de ingenieria de sistemas y me gustaria saber si podrias hacer un tutorial, ya que nos serviria de mucho para lnosotros. Muchas Gracias

  35. Exacto. lo que pasa es que constantemente nos llegan requerimientos en el trabajo y quisieramos crear un correo donde solo lleguen requerimientos, y esos correos me gustaria poder verlos en filas de excel. Es posible? Saludos

    • Buen dia Jhonattan Llanos

      Debes realizarlo a través de Outlook, puedes utilizar como base alguno de los scripts en este articulo. Estos exportan los datos de los correos a una hoja de Excel.

      Excelente dia.

  36. Hola Fernado antes que nada queiro felicitarte, tengo una duda tengo varios PST´y no se como indicarle cual el pst correcto y de que folderdebe de extraer la informacion

    • Buen dia Kary

      El primer codigo exporta los correos entrantes mas no los seleccionados, el segundo si exporta la selección del folder mas el orden de la información cambia; el codigo que indica para exportar el folder seleccionado es:

       Set objOL = Outlook.Application
          Set objFolder = objOL.ActiveExplorer.CurrentFolder
          Set objItems = objFolder.Items
          For Each obj In objItems

      Puedes ver en el segundo codigo donde se insertaron esas lineas y colocarlas en el primero.
      asi como en la 2da linea se dele eliminar el Item quedando asi: Public Sub CopyEmailToExcelWhenArrive()

      Excelente dia

  37. Hola Fernando y buenas noches, tenia una consulta sobre una macro para el outlook.
    Lo que ocurre es que en mi trabajo me solicitan que pueda copiar los datos de unos correos, para ser exactos solo “Nombre de la carpeta de donde esta, correo del remitente, el asunto, la hora y la categoria”.
    Lo que pasa es que estos correos estan dentro de una carpeta, que esta dentro de otra carpeta, que esta dentro de otra carpeta y asi.
    La estructura es la siguiente, La carpeta “Asesores” que es la carpeta raiz por asi decirlo, dentro se encuentran varias subcarpetas con los nombres de los asesores por ejemplo “Mayra” y dentro de esta subcarpeta estan otras carpetas donde se distribuyen los correos dependiendo de su categoria, como por ejemplo “prestamos”, “liquidaciones” etc.
    Tengo este codigo que coloca los datos que necesito, lo que pasa es que muestra el nombre de la carpeta en la esta el correo en la Fila 1, pero lo que yo quiero y no puedo lograr es que muestre solo la carpeta del asesor al que pertenece, es decir que diga “Mayra” o “Jose” dependiendo de a que asesor corresponde.
    Con este codigo me permite seleccionar la carpeta raiz y copia todos los datos de los correos pero terminan como antes mencione.

    Para explicar mejor las carpetas estan asi dentro del Outlook:
    Asesores/Nombre del asesor “que es el dato que necesito”/Carpetas con el nombre de la categoria.

    Crees que me puedas ayudar?, Mucha gracias de ante mano y saludos.

    Codigo:

    Public xlSht As Excel.Worksheet
    
    Sub DocumentFolders(objParent As folder, lRow As Long)
    Dim objItm As Object
    Dim objFolder As folder
    
    On Error Resume Next
    With xlSht
    For Each objItm In objParent.Items
    .Cells(lRow, 1) = objParent
    .Cells(lRow, 2) = objItm.SenderEmailAddress
    .Cells(lRow, 3) = objItm.Subject
    .Cells(lRow, 4) = objItm.ReceivedTime
    .Cells(lRow, 5) = objItm.Categories
    lRow = lRow + 1
    Next
    End With
    On Error GoTo 0
    
    If objParent.folders.Count > 0 Then
    For Each objFolder In objParent.folders
    Call DocumentFolders(objFolder, lRow)
    Next
    End If
    
    End Sub
    
    Sub Exportar_datos()
    Dim xlApp As Excel.Application
    Dim xlWb As Excel.Workbook
    Dim folder
    
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Add
    Set xlSht = xlWb.Sheets(1)
    
    With xlSht
    .Cells(1, 1) = "Carpeta"
    .Cells(1, 2) = "Correo"
    .Cells(1, 3) = "Asunto"
    .Cells(1, 4) = "Hora"
    .Cells(1, 5) = "Categoría"
    End With
    
    Call DocumentFolders(Session.PickFolder(), 2)
    
    xlApp.Visible = True
    
    Set xlSht = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
    
    End Sub
    • Buen dia Richard

      Mira con una función puedes hacer lo siguiente:
      1.- En el principal indicarías la carpeta donde tienes los correos por ejemplo: mis pruebas las realice desde un Folder Personal que es “Correos Anteriores” y un sub carpeta “Asesores”, se indicaría de la siguiente forma:

      Dim olStartFolder As Outlook.MAPIFolder 'Declaracion
      Set olStartFolder = olSession.Folders("Correos Anteriores").Folders("Asesores")

      Otra opcion es si tu seleccionas la carpeta, tienes dos opciones que la solicite al momento de ejecutar el script o tomar la que tienes activa en Outlook:

      Opcion a

      Set olStartFolder = olSession.PickFolder

      Opcion b

      Set olStartFolder = Application.ActiveExplorer.CurrentFolder

      2.- Llamas la función enviando la selección.

      If Not (olStartFolder Is Nothing) Then
               ' Start the search process.
              ProcessFolder olStartFolder
          End If

      3.- La funcion obtiene las carpetas dentro del folder indicado.

      	
      Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)
          Dim i As Long
          Dim olTempFolder As Outlook.MAPIFolder
          For i = CurrentFolder.Folders.Count To 1 Step -1
              Set olTempFolder = CurrentFolder.Folders(i)
              strFolders = strFolders & vbCrLf & olTempFolder
              lCountOfFound = lCountOfFound + 1
          Next
      End Sub

      Excelente dia

  38. Hola Fernando.
    Muy interesante todo esto que posteas.
    Quisiera ver si me puedes ayudar :
    1.- Funciona para outloock de off 365 ?. Me dicen de microsoft que los script no funcionan para off 365, entonces quiero saber para ver si me pongo a leer tu post y aplicarlo.
    2.- Tengo 2 necesidades de los correos que entran, en ambas es generar un excel
    2.a.- El correo trae solamante texto (texto plano) de cual requiero los campos elementales (asunto, fecha, cuerpo,, etc)
    2.b.- El correo trae una tabla de datos de la cual requiero extraer los datos

    gracias, saludos

    • Buen dia Sergio

      Para ser honesto desconozco el funcionamiento de Office 365, las migraciones que he realizado han sido en las versiones 2007, 2010, 2013, 2016 el cual esta comprobado que funcionan; mas he escuchado algunos usuarios que “Si aplican algunos scripts” en Office 365, tambien en la comunidad de Microsoft he leído que tiene soporte a VBA.

      Prueba cualquier script y nos comentas para tener conocimiento si funciona.

      Excelente dia

      • Buen día Fernando.
        Primeramente gracias por contestar, me gusta.

        Probé con un script para mandar correos repetitivos en determinado período de tiempo, lo tome de un soporte de Microsoft, no funcionó, se hizo para 2010 en su momento, por cierto lo resolví con google.
        Consulte 2 veces a Microsoft vía chat y teléfono, distintos asesores, diferían en su respuesta, uno de me dijo que en off 365 ya no se usan los script (no le creí, quedaría rezagados con la competencia y no veo la razón.) y el otro me dijo que debería, me paso unas ligas de ayuda, nada que ver. Entonces ando investigando la realidad.

        Cuando sepa algo lo aportaré por y a este medio.

        Volviendo a mi consulta original.

        – Hay forma de hacerte llegar un correo ?, aparentemente trae una tabla (no como Excel) que no es imagen, contiene texto. Quisiera saber si se puede extraer la información, en caso de que si, no dudaría en migrar a un outlook anterior.

        Gracias por tus atenciones

        • Buen dia Sergio

          A lo visto, deben funcionar en 365 ya has logrado ejecutar un script sencillo tal como

          Sub Main()
                MsgBox("Hello, World!") ' Display message on computer screen.
          End Sub

          Debes asegurarte que tengas Macros habilitados y se muestre la opción Ejecutar Script.

          Respecto la tabla por el momento no tengo script que extraiga solo los datos de la tabla que se encuentra en el cuerpo del correo, realice una modificación algunos comentarios atrás VER el cual hace la acción de copiar y pegar el cuerpo del correo, por lo tanto las tablas se pegan en Excel en su celda correspondiente cada dato.

          Por otro lado seria posible siempre y cuando sea una tabla y el formato de correo sea HTML, este código no esta implementado en el código mencionado en el articulo, ya que pueden existir otras variantes a tomar en cuenta el cual por motivos de tiempo no he tenido oportunidad, esta solicitud aun la tengo pendiente ya que la han solicitado varias ocasiones, en algún momento les traeré ese código.

          'Leer HTML de cuerpo de correo
          Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
          Dim oElColl As MSHTML.IHTMLElementCollection
          With oHTML
              .Body.innerHTML = oMail.HTMLBody
              Set oElColl = .getElementsByTagName("table")
          End With
          
          'Importar a Excel
          Dim x As Long, y As Long
          
          For x = 0 To oElColl(0).Rows.Length - 1
              For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
                  Range("A1").Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText
              Next y
          Next x

          Excelente dia

      • Buen día Fernando.

        Primeramente gracias por contestar, muy bien.

        Al no poder que se ejecutara un script que está en la página de soporte de Microsoft para enviar correos repetitivos en un periodo definido, consulté en Microsoft. Aclaro que el post correspondía para Outlook 2010

        Dos asesores me atendieron en consultas diferentes, diferían de sus conocimientos
        – uno me dijo que en off 365 no funcionaban los script, no le creí ya que es una buena herramienta y de ser así quedaría en desventaja con su competencia.
        – el otro me dijo que deberían funcionar los scripts, me proporciono unas ligas de ayuda, nada que ver

        He estado leyendo sin encontrar tema acerca de off 365, fue que llegue a tu página.

        Seguiré sobre el tema, cuando tenga algo que proporcionar lo haré en este medio.

        Volviendo a la consulta original
        – en el 365 s puede exportar varios campos de los correos, me topo con que el cuerpo de mi correo trae una tabla (no imagen) de la cual quiero extraer la información
        – Hay forma de hacerte llegar un correo para que la evalúes y me ayudes para ver si se puede extraer la información ?, si es necesario migrar a un Outlook versión anterior, no dudaría en hacerlo.

        gracias

        saludos

        • Buen dia Sergio

          Los comentarios se quedan en moderación por eso no se muestran hasta que yo los lea, es por motivo de control para poder responder todos los comentarios que realicen en el sitio.

          Ya te di respuesta en el primero comentario.

          Excelente dia

  39. Hola fernando, tengo una duda, me funciona de maravilla tu Macro para exportar los datos a excel muchas gracias!! pero me gustaria saber si puedo exportar también los datos adjuntos , por ejemplo una planilla excel personalizada a cada proveedor.

    Muchas gracias por tu tiempo !

  40. Buenas noches Fernando…!!!

    De verdad muchas felicidades, eres un master con los codigos estoy leyendo algunos para ver si alguno se apega a mis necesidades, y creo que uno si, pero mejor pregunto??

    Me solicitan que de los correos solo busque en la redacción NOMBRES del personal, hasta el momento tengo 600 correo que tengo que revisar un por uno y seleccionar el nombre y pasarlo a excel, se pude crear una macro que me busque este dato??

    Espero me puedas ayudar, gracias

    Excelente Noche

    • Buen dia Carlos

      Se puede realizar búsquedas en el cuerpo del correo, siempre y cuando se tenga que es lo que se va a buscar; mas no es posible especificar que extraiga nombres porque no se puede diferenciar las palabras; para el script todo el contenido del correo son palabras.

      A diferencia si el cuerpo de correo viene en un formato especifico es posible extraer partes del cuerpo de correo, el cual si el correo cambia la estructura tomara otros valores.

      ¿Cual es tu caso?, ¿Tienen un parámetro en común en los correos?

      • Buenas noches fernando como estas….!!! una disculpa por no contestar en el momento pero se me junto un poco el trabajo, y uno de ellos es pasar del correo de OUTLOOK a excel los nombres de personas que me van mandando diarios, es una lista de personas que ingresaron en otros estados o se dieron de baja como tal el correo viene de la siguiente manera:

        para: Carlos
        de: Recursos Humanos
        Titulo: Altas de personal Puebla o Bajas (segun sea el caso)
        ————————————————————————————————
        pedrito perez
        Fernando cepeda
        felicia fernandez

        Atentantamente
        Recursos humanos

        Como tal solo selecciono los nombres y los paso a excel, y diariamente son de 30 a 40 correos y ya te imaginaras, es un poco tedioso, crees que haya alguna manera mas facil de seleccionar estos parametros.

        Excelente dia, espero me puedas ayudar.

        Saludos.

        • Buen dia

          Para poder realizar una selección se debe contar con un formato ya establecido para poder indicar en el script (tomar de tal a tal renglón) ya que el script por si solo no podria detectar que es un nombre y que no, asi que en el caso te exportaría la firma y cualquier otro comentario; actualmente eso es lo que hace el script seria cuestion que adaptaras para que solo descargue el cuerpo del correo.

          Excelente dia

  41. Hola, Fernando! Muy buena la publicación!

    Te hago una consulta. Yo nunca armé una Macro en Excel, y para el trabajo me pidieron intentar armar una que tome datos de unos archivos adjuntos que llegan por mail, y actualicen un libro de un archivo de Excel. Estuve buscando, y todos los ejemplos son con Outlook. El problema es que en el trabajo utilizamos Lotus Notes.

    Tenés idea que podría llegar a utilizar para lograr esta funcionalidad? O dónde puedo buscar?
    Muchas gracias!!

  42. cuando voy a buscar en el registro del sistema la ruta que señalas HKEY_CURRENT_USER\SOFTWARE\VB, no me aparece en el listado, ahi que esta ocurriendo o que hago??

Deja un comentario...

Compartir1
Twittear
+1
Compartir
Pin
Stumble