Inicio MS / Office

VBScript – Exportar Información de correos Outlook a Excel

88


Ultima Actualización del Artículo: Jun 8, 2017

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

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
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
'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

COMPARTIR
Mi nombre es Fernando, 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.

88 Comentarios

  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.

  20. Hola Fernando,

    Agradezco tu ayuda, necesito generar un archivo txt con el asunto de cada correo recibido de forma automatica.

    • 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.

  21. 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.

  22. 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
      
  23. 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.

  24. 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.

  25. 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
  26. 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.

  27. 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.

Deja un comentario...