Desconexión pasiva de usuarios en bases de datos Access

conectado

En los anteriores artículos Información de usuarios conectados (NetWkstaUserEnum y NetUserGetInfo) y Usuarios conectados a base de datos Access (User Roster) habíamos llegado a crear un Administrador de usuarios Access que nos proporcionaba la información de los usuarios que teníamos conectados a una base de datos que nosotros le pasábamos. Los datos que nos mostraba eran los siguientes:

  • Hora: Hora de la monitorización
  • BD: Usuario de base de datos (para versiones 2007 o posteriores siempre Admin)
  • Equipo: Equipo de la red desde el que conecta
  • Usuario Windows: Usuario de de la red de Active Directory o de red
  • Nombre completo: Nombre completo de Active Directory o de red
  • Dominio: Dominio de Active Directory o de red
  • Servidor: Servidor al que conecta cada usuario
  • Estado de la conexión (conectado/no conectado)
  • Cierre forzado (si/no) Base de datos cerrada de forma no habitual


Como decía en el anterior artículo, con esto podría ser suficiente para informar a los usuarios conectados de nuestra intención realizar modificaciones en la base de datos y pedirles que salieran de sus aplicaciones. Pero como todos los desarrolladores sabemos, siempre queda algún usuario conectado que no podemos localizar o que hace caso omiso de nuestras peticiones.

Para solventar este problema, en este artículo voy a explicar el primer tipo de desconexión que tendrá la aplicación de Administración de usuarios, la desconexión pasiva.

Desconexión pasiva

Aunque lo llamemos desconexión pasiva, realmente no se desconecta a los usuarios, simplemente no se les deja volver a conectar. Este tipo de desconexión se suele utilizar al final de la jornada de trabajo, impidiendo así que los usuarios se conecten al empezar la jornada siguiente.

Al igual que en el resto de artículos sobre el Administrador de usuarios, voy a explicar un poco por encima el código que he tenido que modificar para que funciones la desconexión y los problemas que me he encontrado. Os aconsejo que reviséis los anteriores artículos (Información de usuarios conectados (NetWkstaUserEnum y NetUserGetInfo) y Usuarios conectados a base de datos Access (User Roster)) para más información.

Necesitaremos de nuevo los 2 módulos que utilizamos en el anterior artículo, pero esta vez modificaremos el módulo conexiones para que permita la desconexión pasiva. Para ello, necesitaremos declarar la conexión como pública para que siga activa una vez salgamos de la función en la que la abrimos (conexión persistente). Aquí es donde he tenido la mayoría de los problemas.

Empezamos haciendo pública la conexión en la sección de declaraciones de nuestro módulo:

Option Compare Database
Option Explicit
Public Conexion As New ADODB.Connection 'Para crear la conexión. Tengo que utilizar ADO, aunque no me guste. Lo hago público para que sea persistente (desconexión pasiva)

En otros ejemplos de desconexión pasiva de usuarios he visto que declaran tanto las conexiones como los recordsets como objetos, pero de momento no veo la utilidad de hacerlo, a mí me funciona perfectamente de esta forma.

Una vez declarada la conexión, tenemos que asignarle las propiedades que nos interesan tal y como hacíamos en la anterior versión, pero tenemos que asegurarnos de que no hayamos abierto ya la conexión (permanecerá abierta mientras tengamos activa la aplicación) utilizando la propiedad «state» de las conexiones ADO. Veamos cómo implementarlo:

If Conexion.state = 0 Then
        
        Conexion.Provider = CurrentProject.Connection.Provider 'Por si acaso asignamos el proveedor aunque se supone que será Microsoft ACE OLEDB 12.0
        
        If Len(Trim(Contraseña)) > 0 Then 'Si el usuario mete la contraseña. Si no tiene contraseña funciona bien aunque metas
            Conexion.Properties("Jet OLEDB:Database Password") = Contraseña
        End If
        
        Conexion.Open "Data Source=" & Fichero
        
   
   End If

Por supuesto, si seleccionamos un backend nuevo, también tendremos que volver a crear la conexión. Una posible idea es cerrarla al seleccionar el fichero (si no sabéis como crear un filedialog, estaré encantado de contestaros en los comentarios) de la siguiente manera:

If Not Conexion Is Nothing Then
        If Conexion.state = 1 Then
            Conexion.Close 'Cerramos la conexión. 1 es adStateOpen
        End If
        Set Conexion = Nothing
        
End If

Y ahora vamos a establecer la propiedad que hará que se active la desconexión pasiva (he modificado la función principal para que además de recibir el fichero de base de datos y la contraseña, reciba otro parámetro booleano que controle esta propiedad):

Public Function Usuarios_Conectados(ByVal Fichero As String, ByVal Contraseña As String, ByVal Opcion As Boolean)

Y establecemos la propiedad:

'Desconexión pasiva, conectamos y desconectamos
    If Opcion = True Then
        Conexion.Properties("Jet OLEDB:Connection Control") = 1 'Impedimos que se conecten nuevos usuarios
     Else
        Conexion.Properties("Jet OLEDB:Connection Control") = 2 'Se permiten las nuevas conexiones
     End If

El resto del código debería de ser igual que en la anterior versión, pero hay un problema a la hora de abrir el esquema, que por cierto me hizo perder varias horas. En la anterior versión abríamos el esquema User Roster de la siguiente manera:

Set rsConexiones = Conexion.OpenSchema(schema:=adSchemaProviderSpecific, schemaID:=schemaID) ' Conexión sacada de la web de Microsoft 

Declarando la variable schemaID anteriormente:

Dim schemaID As String

'**********************************************************************
'En nuestro caso utilizamos JET_SCHEMA_USERROSTER -> {947bb102-5d43-11d1-bdbf-00c04fb92675}
schemaID = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
'**********************************************************************

Pues bien, de esta forma no funciona siempre (no me preguntéis el motivo) así que después de mucho investigar donde estaba el error, he encontrado esta otra forma de abrirlo que parece que funciona siempre:

Set rsConexiones = Conexion.OpenSchema(adSchemaProviderSpecific, , schemaID) ' Conexión sacada de la web de Microsoft. NO tira con a veces la variable... locura para encontrarlo
    'Set rsConexiones = Conexion.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")'Parece que al final funciona la de arriba...

Edito: Parece que finalmente funciona con la versión inicial. Me parece más clara así que la dejo como al principio.

Y con esto ya tenemos la versión de nuestro administrador de usuarios modificada para que permita desconexión pasiva de usuarios. Ahora bastará con llamar a la función Usuarios_Conectados con el tercer parámetro con el valor «TRUE» para que nuestra aplicación empiece con la desconexión pasiva de usuarios.

Tendremos que mantener la aplicación abierta para que se mantenga nuestra desconexión pasiva ya que al cerrarla se pierde la conexión persistente. Así y todo, no estaría de más cerrarla por código al cerrar el formulario:

If Not Conexion Is Nothing Then
        If Conexion.state = 1 Then
            Conexion.Close 'Cerramos la conexión. 1 es adStateOpen
        End If
        Set Conexion = Nothing
 End If

Aquí os paso los 2 módulos ya implementados, recordad que necesitamos tener una tabla llamada CONEXIONES y llamar a la función pasándole la ruta del fichero, la contraseña (si es necesario) y TRUE/FALSE para activar/desactivar la desconexión pasiva.

Módulo Conexiones

'*************************************************************************************************************************************
'Autor: Arkaitz Arteaga
'Más artículos: www.programadordepalo.com
'Mail de contacto: admin@programadordepalo.com
'Fecha: Enero 2014
'Version: 1.0
'*************************************************************************************************************************************
    'Sacado de la web de Microsoft (necesario Microsoft ActiveX Data Objects 2.x Library)
    ' Para abrir connection.OpenSchema(querytype, criteria, schemaID)
    ' schemaID -> Hay diferentes tipos, en este caso utilizaremos JET_SCHEMA_USERROSTER -> {947bb102-5d43-11d1-bdbf-00c04fb92675}
    '-Nombre del equipo que está utilizando el usuario.
    '-Nombre de seguridad, es decir, el identificador de usuario. Siempre va a ser 'admin' a partir de 2007
    '-Si el usuario está actualmente conectado a la base de datos.
    '-Si la conexión del usuario se terminó con normalidad.
'
'*************************************************************************************************************************************
'*************************************************************************************************************************************
'Copyright: Por favor, no cuesta nada mantener un enlace a mi web en el código.
'Incluso pudes dejar los formularios tal cual, con un enlace a mi web.
'Si vas a utilizar este código con fines lucrativos (es decir, te van a pagar por ello) contacta conmigo por favor.
'*************************************************************************************************************************************

Option Compare Database
Option Explicit
Public Const VERSION As String = "2.2"
Public Conexion As New ADODB.Connection 'Para crear la conexión. Tengo que utilizar ADO, aunque no me guste. Lo hago público para que sea persistente (desconexión pasiva)
Public horaConectado As String 'Hora de la conexión recurrente


Public Function Usuarios_Conectados(ByVal Fichero As String, ByVal Contraseña As String, ByVal Opcion As Boolean)
    
    On Error GoTo AlgoPasa
    
    'Dim Conexion As New ADODB.Connection    'Sin conexión persistente se puede hacer desde aqui
    Dim rsConexiones As New ADODB.Recordset  'Para la tabla que tendrá las conexiones
    Dim rsConectados As DAO.Recordset        'Para la tabla local que tendrá los usuarios conectados. Ya lo sabéis, no me gusta ADO, ;)
    Dim MiBD As DAO.Database                 'Muchos criticaréis esta forma, pero así utilizamos ADO y DAO de manera que los no iniciados aprendan
    Dim datosWin As USUARIO_FINAL            'Guardo los datos que devuelve la función UsuarioWindows
    
    Dim schemaID As String
    

    '**********************************************************************
    'En nuestro caso utilizamos JET_SCHEMA_USERROSTER -> {947bb102-5d43-11d1-bdbf-00c04fb92675}
    schemaID = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
    '**********************************************************************
      
  
  If Conexion.state = 0 Then
        
        Conexion.Provider = CurrentProject.Connection.Provider 'Por si acaso asignamos el proveedor aunque se supone que será Microsoft ACE OLEDB 12.0
        
        If Len(Trim(Contraseña)) > 0 Then 'Si el usuario mete la contraseña. Si no tiene contraseña funciona bien aunque metas
            Conexion.Properties("Jet OLEDB:Database Password") = Contraseña
        End If
        
        Conexion.Open "Data Source=" & Fichero
        
   
   End If
    
    'Desconexión pasiva, conectamos y desconectamos
    
    If Opcion = True Then
        Conexion.Properties("Jet OLEDB:Connection Control") = 1 'Impedimos que se conecten nuevos usuarios
     Else
        Conexion.Properties("Jet OLEDB:Connection Control") = 2 'Se permiten las nuevas conexiones
     End If
   
    
    Set rsConexiones = Conexion.OpenSchema(adSchemaProviderSpecific, , schemaID) ' Conexión sacada de la web de Microsoft. NO tira con a veces la variable... locura para encontrarlo
    'Set rsConexiones = Conexion.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")'Parece que al final funciona la de arriba...
    
    Set MiBD = CurrentDb
    CurrentDb.Execute "DELETE * FROM CONEXIONES", dbFailOnError 'Vamos a borrar las conexiones anteriores
    Set rsConectados = MiBD.OpenRecordset("CONEXIONES")
        
    While rsConexiones.EOF = False
        
        rsConectados.AddNew
        rsConectados("HORA") = Now
        rsConectados("USUARIO") = Trim(rsConexiones!LOGIN_NAME)
        rsConectados("EQUIPO") = Trim(rsConexiones!COMPUTER_NAME)
        rsConectados("CONECTADO") = rsConexiones!CONNECTED
        rsConectados("ESTADO") = Trim(rsConexiones!SUSPECT_STATE)
        datosWin = UsuarioWindows(rsConectados("EQUIPO")) 'Llamo a la función UsuarioWindows para cada usuario
        rsConectados("USUARIO_WINDOWS") = datosWin.info_usuario
        rsConectados("NOMBRE_COMPLETO") = datosWin.info_completo
        rsConectados("DOMINIO") = datosWin.info_dominio
        rsConectados("SERVIDOR") = datosWin.info_servidor
        rsConectados.Update
        rsConexiones.MoveNext
        
    Wend
    
     
    rsConectados.Close
    Set rsConectados = Nothing
    rsConexiones.Close
    Set rsConexiones = Nothing
    
    
    Exit Function
AlgoPasa:

    MsgBox ("Error al comprobar las conexiones de usuarios. " & Err.Description), vbCritical, "Error al comprobar las conexiones"
    
    
End Function

Módulo redWindows

'*************************************************************************************************************************************
'Autor: Arkaitz Arteaga
'Más artículos: www.programadordepalo.com
'Mail de contacto: admin@programadordepalo.com
'Fecha: Enero 2014
'Version: 1.0
'*************************************************************************************************************************************
'Módulo para mostrar el usuario de Windows. Basado en http://msdn.microsoft.com/en-us/library/windows/desktop/aa370669%28v=vs.85%29.aspx
'De aqui la información de cada usuario http://msdn.microsoft.com/en-us/library/bb706729.aspx y http://support.microsoft.com/kb/151774/es
'OJO, he tenido problemas con las conversiones. Al final pasando a NetUserGetInfo los valores de servidor y de usuario remoto con arrays de bytes funciona.
'También había problemas ya que estaba pasando el equipo remoto en vez del servidor de base de datos de cada usuario
'
'*************************************************************************************************************************************
'*************************************************************************************************************************************
'Copyright: Por favor, no cuesta nada mantener un enlace a mi web en el código.
'Incluso pudes dejar los formularios tal cual, con un enlace a mi web.
'Si vas a utilizar este código con fines lucrativos (es decir, te van a pagar por ello) contacta conmigo por favor.
'*************************************************************************************************************************************
Option Compare Database

Option Explicit

'*************************************************************************************************************************************
'Traduzco que me aclaro mejor
'*************************************************************************************************************************************
Private Const NO_HAY_ERROR As Long = 0&      'Lo ponemos a 0. Se utiliza para comprobar luego que no hay errores
Private Const LONGITUD_PREFERIDA As Long = -1 'Buscando en la web de Microsfot "A constant of type DWORD that is set to –1"
Private Const MAS_DATOS As Long = 234&


Private Type usuario
  info_usuario  As Long 'Usuario actualmente logeado en esa máquina
  info_dominio  As Long 'Dominio al que se ha logeado el usuario
  info_otros    As Long 'En nuestro caso null
  info_servidor As Long 'Servidor donde se autenticó el usuario. Muy importante para luego utilizar NetUserGetInfo
End Type

'En este guardo lo que me devuelve NetWkstaUserEnum y NetUserGetInfo, y luego lo devuelvo con la función. Lo hago público para poder dar de alta al llamar
Public Type USUARIO_FINAL
  info_usuario       As String
  info_dominio       As String
  info_otros         As String 'En nuestro caso null
  info_servidor      As String
  'info_comentario   As String 'No veo más campos con información, tal vez en otros tipos de redes...
  info_completo      As String 'Aqui guardo el nombre completo que devuelve NetUserGetInfo
End Type

'Lo mismo para sacar NetUserGetInfo*********Al fin parece que funciona, le estaba pasando el equipo remoto y no el servidor. Le paso level 10
Private Type INFORMACION_USUARIO
   info_nombre           As Long 'Aqui sale el nombre de usuario
   info_ucomentario      As Long
   info_comentario       As Long
   info_completo         As Long 'Aqui sale el nombre completo
End Type

Private Type INFORMACION_USUARIO_FINAL
   info_nombre           As String
   info_ucomentario      As String
   info_comentario       As String
   info_completo         As String
End Type

'***********************************************************************************
'Copio tal cual de las declaraciones de Microsoft para la función NetWkstaUserEnum
'***********************************************************************************
Private Declare Function NetWkstaUserEnum Lib "netapi32" _
  (ByVal equipo As Long, _
   ByVal nivel As Long, _
   buffer As Long, _
   ByVal longitudp As Long, _
   entradasLeidas As Long, _
   entradasTotales As Long, _
   reanudar As Long) As Long
   
'***********************************************************************************
'Me daba problemas pasando strings como aparece en la web de Microsoft, tal vez convirtiendo a UNICODE hubiera funcionado.
'Queda por probar hacerlo con strings. Con bytes no hay problema
'***********************************************************************************
Private Declare Function NetUserGetInfo Lib "netapi32" _
  (servidor As Byte, _
   usuario As Byte, _
   ByVal nivel As Integer, _
   buffer As Long) As Integer
'***********************************************************************************
'Las copio tal cual de otros ejemplos
'***********************************************************************************

Private Declare Function NetApiBufferFree Lib "netapi32" _
   (ByVal buffer As Long) As Long
   
Private Declare Sub CopyMemory Lib "Kernel32" _
   Alias "RtlMoveMemory" _
  (pTo As Any, uFrom As Any, _
   ByVal lSize As Long)
   
Private Declare Function lstrlenW Lib "Kernel32" _
  (ByVal lpString As Long) As Long
'***********************************************************************************
'***********************************************************************************


 Function UsuarioWindows(NombreEquipo As String) As USUARIO_FINAL

   Dim dservidor       As Long
   Dim entraLeidas     As Long
   Dim entraTotales    As Long
   Dim entraReanuda    As Long
   Dim estado          As Long
   Dim bufNet          As Long
   Dim tamaStruct      As Long
   Dim servidor        As String
   Dim info1           As usuario
   Dim pasaInfo        As USUARIO_FINAL
   Dim usuInfo         As INFORMACION_USUARIO_FINAL
   Dim bservidor()     As Byte
   Dim busuario()      As Byte
   
   On Error GoTo algo_pasa
     
   'NombreEquipo = Trim(NombreEquipo) 'No lo quita, será así.
   servidor = "\\" & NombreEquipo & vbNullString
   dservidor = StrPtr(servidor) 'StrPtr - devuelve la dirección del búfer de cadena UNICODE.
   
   
      estado = NetWkstaUserEnum(dservidor, _
                                 1, _
                                 bufNet, _
                                 LONGITUD_PREFERIDA, _
                                 entraLeidas, _
                                 entraTotales, _
                                 entraReanuda)
    
      If estado = NO_HAY_ERROR Or _
         estado = MAS_DATOS Then
         
         If entraLeidas > 0 Then
         
            tamaStruct = LenB(info1)
         
                   
               CopyMemory info1, ByVal bufNet, tamaStruct
               UsuarioWindows.info_usuario = Trim(PasaLoString(info1.info_usuario)) 'Trim por si acaso, aunque no mete mucha historia
               UsuarioWindows.info_dominio = Trim(PasaLoString(info1.info_dominio))
               UsuarioWindows.info_servidor = Trim(PasaLoString(info1.info_servidor))
               bservidor = UsuarioWindows.info_servidor & Chr$(0) 'Convertimos
               busuario = UsuarioWindows.info_usuario & Chr$(0)
               '************************************************************************************
               'No me funciona.... Pues ahora parece que si, le estaba pasando el equipo remoto en vez del servidor
                usuInfo = UsuarioWindowsInformacion(bservidor(), busuario())
               '************************************************************************************
                UsuarioWindows.info_completo = usuInfo.info_completo
         Else:
          UsuarioWindows.info_usuario = "Posible maquina Win98"
            
         End If
      
      Else:
         
         UsuarioWindows.info_usuario = "Error"
      
      End If
   
   
   Call NetApiBufferFree(bufNet)
   
   Exit Function
   
algo_pasa:
   MsgBox ("Error al revisar las conexiones a la base de datos" & Err.Description), vbCritical, "Error al revisar las conexiones"
   
End Function
Private Function UsuarioWindowsInformacion(eServidor() As Byte, eUsuario() As Byte) As INFORMACION_USUARIO_FINAL
   
   '******************************************************
   'Modificado de aqui
   'http://msdn.microsoft.com/en-us/library/bb706729.aspx
   '******************************************************
   Dim usuario As INFORMACION_USUARIO
   Dim buff As Long
   
   On Error GoTo algo_pasa
   
   If NetUserGetInfo(eServidor(0), eUsuario(0), 10, buff) = NO_HAY_ERROR Then 'es 10 -> Return user and account names and comments. The bufptr parameter points to a USER_INFO_10 structure.


    CopyMemory usuario, ByVal buff, Len(usuario)
    
    UsuarioWindowsInformacion.info_nombre = Trim(PasaLoString(usuario.info_nombre))
    UsuarioWindowsInformacion.info_completo = Trim(PasaLoString(usuario.info_completo))
    UsuarioWindowsInformacion.info_comentario = Trim(PasaLoString(usuario.info_comentario))
    UsuarioWindowsInformacion.info_ucomentario = Trim(PasaLoString(usuario.info_ucomentario))
    
    
    NetApiBufferFree buff

   
   End If
   
Exit Function
algo_pasa:
   MsgBox ("Error al revisar el usuario Windows" & Err.Description), vbCritical, "Error al revisar las conexiones"
End Function

Private Function PasaLoString(ByVal loPasa As Long) As String
''******************************************************
'Tal cual de la web de Microsoft
''******************************************************
  
   Dim tmp() As Byte
   Dim tmplon As Long
   
   On Error GoTo algo_pasa
   
   If loPasa <> 0 Then
   
      tmplon = lstrlenW(loPasa) * 2 '2 bytes cada char
      
      If tmplon <> 0 Then
      
         ReDim tmp(0 To (tmplon - 1)) As Byte
         CopyMemory tmp(0), ByVal loPasa, tmplon
         PasaLoString = tmp
         
     End If
     
   End If
   Exit Function
algo_pasa:
   MsgBox ("Error al transformar" & Err.Description), vbCritical, "Error al revisar las conexiones"
End Function

Espero que os sirva, pero si tenéis alguna duda, os responderé en los comentarios de la web.

The following two tabs change content below.
Llevo más de 10 años programando, sobre todo en Visual Basic y con bases de datos Access. Para mí, VBA y Access siguen siendo herramientas muy potentes. He desarrollado varios proyectos con PHP y MySql. Si sumo las webs que he tenido, probablemente pasaría de 100. Ahora prefiero dedicar todo mi esfuerzo a este blog (aunque sigo manteniendo unas cuantas...). Trabajo en la administración pública (si, soy funcionario), pero he trabajado en pequeñas empresas e incluso en una "grande" de las telecomunicaciones. Ultimamente estoy bastante metido en abrirme nuevos horizontes con C# y .NET. Renovarse o morir!

Deja una respuesta