Contador de emails en Outlook con Visual Basic

Cuando los recursos son escasos y hay que buscar automatizar y facilitar procesos para tener control del trabajo que entra, necesitamos exprimir los programas que tenemos a disposición. En este caso, se plantea la necesidad de contar los emails recibidos en la bandeja de entrada mediante una macro de Excel. Es por ello, que en este post se verá una macro para contar emails en Outlook.

Activar Microsoft Outlook en Visual Basic

Antes de iniciar esta macro, es necesario activar Microsoft Outlook en Visual Basic de Excel, y para ello, debemos abrir el editor de Visual Basic e ir al menú Herramientas y seguidamente Referencias. 

En esta ventana, debemos asegurarnos que la referencia Microsoft Outlook 15.0 Object Library esté activada.

Archivo inicial para recoger la información

La macro para contar los emails recibidos en la bandeja de entrada necesita de un archivo Excel desde donde ejecutaremos esta macro y se vayan plasmando ahí. Simplemente en la columna A le decimos los días que queremos analizar, y la columna B se irá rellenando con la macro.

Macro para contar emails

Elección de la carpeta a analizar

Hay una línea del código que es la que se debe personalizar a cada uno, en la que se indique la carpeta a analizar.

Set objFolder = objnSpace.Folders("aprendiz@devisualbasic.com").Folders("Bandeja de entrada")

En el caso de querer analizar una carpeta dentro de la Bandeja de Entrada, habría que alargar ese mismo código de la siguiente forma.

Set objFolder = objnSpace.Folders("aprendiz@devisualbasic.com").Folders("Bandeja de entrada").Folders("Carpeta a analizar")

Macro completa

Sub Contador_Emails()

Dim olApp As Outlook.Application

Dim olName As Outlook.Namespace

Dim olFolder As Outlook.MAPIFolder

Dim olSubFolder  As Outlook.MAPIFolder

Dim objOutlook As Object, objnSpace As Object, objFolder As Object

Dim EmailCount, DateCount, iCount As Integer

Dim myDate As Date

Dim arrEmailDates()

Dim trasponer, resumen As String

Set objOutlook = CreateObject("Outlook.Application")

Set objnSpace = objOutlook.GetNamespace("MAPI")

Set olApp = GetObject(, "Outlook.Application")

Set olName = olApp.GetNamespace("MAPI")

Set objFolder = objnSpace.Folders("aprendiz@devisualbasic.com").Folders("Bandeja de entrada")

Set objOutlook = CreateObject("Outlook.Application")

Set objnSpace = objOutlook.GetNamespace("MAPI")

    If Err.Number <> 0 Then

        Err.Clear

    msgbox "Carpeta no encontrada"

    

Set objFolder = Nothing

Set objnSpace = Nothing

Set objOutlook = Nothing

        Exit Sub

    End If

' Emails en Array

EmailCount = objFolder.Items.Count

For iCount = 1 To EmailCount

    With objFolder.Items(iCount)

        ReDim Preserve arrEmailDates(iCount - 1) ''

        On Error Resume Next

        arrEmailDates(iCount - 1) = DateSerial(year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))

    End With

Next iCount

' Clear Outlook objects

'Set objFolder = Nothing

Set objnSpace = Nothing

Set objOutlook = Nothing

' Cuenta los emails con fecha igual a la celda activa

Range("A2").Select

Do Until IsEmpty(ActiveCell)

    DateCount = 0

    myDate = ActiveCell.value

    For i = 0 To UBound(arrEmailDates) ' - 1

        If arrEmailDates(i) = myDate Then DateCount = DateCount + 1

    

    Next i

    Selection.Offset(0, 1).Activate

    ActiveCell.value = DateCount

    Selection.Offset(1, -1).Activate

    

Loop

msgbox "¡Éxito!"

End Sub