¿Quién ha abierto mi libro de Excel?

Categoría: Macros y VBA

Basado en la opción de confirmación de lectura que tiene Microsoft Outlook, te presento una pequeña herramienta que te permitirá averiguar tanto el usuario como el momento exacto en que se ha abierto un libro de Excel.

Atención: Antes de implementar este ejemplo debes saber que cada vez que un usuario abra el archivo, recibirás un correo electrónico de confirmación. Esto puede parecer algo inofensivo, pero si se hace una gran distribución y el archivo es abierto por cientos o miles de usuarios, recibirás otros tantos correos electrónicos, lo que puede ser agobiante.

La mayor parte del código que contiene el archivo que adjunto al pie del artículo se encuentra dentro del evento Open del libro. Además, he creado un módulo que contiene una pequeña función que extrae el nombre de usuario de Windows en caso de no tener configurado el remitente en Outlook.

Inserta el siguiente código en el módulo de libro:

Option Explicit

Private Sub Workbook_Open()
   Dim objOutlook As Outlook.Application
   Dim objOutlookMsg As Outlook.MailItem
   Dim objOutlookRecip As Outlook.Recipient
   Dim strUser As String
   Set objOutlook = CreateObject("Outlook.Application")
   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
   strUser = cptName
   If cptName = "" Then strUser = Application.UserName
   On Error Resume Next
   With objOutlookMsg
' La siguiente línea es la que contiene el correo del destinatario
      Set objOutlookRecip = .Recipients.Add("micorreo@correo.com")
      objOutlookRecip.Type = olTo
      .Subject = "Atención: Se ha abierto el archivo " & ThisWorkbook.Name
      .Body = "El archivo " & ThisWorkbook.Name & _
         " fue abierto por " & strUser & " el " & Date & " a las " & Time & _
            " h." & vbLf & vbLf
      objOutlookRecip.Resolve
      .Send
   End With
   Set objOutlook = Nothing
End Sub

Y este otro en un módulo estándar:

Option Explicit

Declare Function GetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" (ByVal lpBuffer As String, _
    nSize As Long) As Long

Function cptName()
   Dim Buffer As String * 100
   Dim BuffLen As Long
   BuffLen = 100
   GetUserName Buffer, BuffLen
End Function

Para que el código funcione correctamente, el usuario debe tener Microsoft Outlook abierto. En caso contrario, se produce un error que es gestionado por la instrucción On Error Resume Next, por lo que no se muestra de ninguna forma.
Si deseas implementar este código en otro archivo, tienes que habilitar la referencia a Microsoft Outllook 14 Object Library.

Si tienes cualquier duda puedes plantearla en el foro de Ayuda Excel.