Ante una pregunta de las News de como evitar abrir dos instancias a la vez de una MDB

Solución de Juan M. Afan de Ribera
==================================

' El siguiente código se encarga de averiguar si ya
' existe una instancia abierta de la base de datos que
' se está abriendo en ese momento.
'
' Ejemplo de uso:
'
' If PrevInstance = True Then
'   MsgBox "Ya existe una instancia de la base actual"
'   DoCmd.Quit
' End If
'
' Autor: Juan M. Afán de Ribera
' Fecha: Junio 2004
'
' ¿Por qué? porque alguien lo preguntó y a mí me gusta
' complicarme la vida...
'
Private Declare Function FindWindowEx Lib "user32.dll" _
                Alias "FindWindowExA" _
                (ByVal hWnd1 As Long, _
                ByVal hWnd2 As Long, _
                ByVal lpsz1 As String, _
                ByVal lpsz2 As String) As Long
                
Private Declare Function GetWindow Lib "user32.dll" _
                (ByVal hwnd As Long, _
                ByVal wCmd As Long) As Long
                
Private Declare Function GetDesktopWindow _
                Lib "user32.dll" () As Long

Private Declare Function GetWindowText Lib "user32.dll" _
                Alias "GetWindowTextA" _
                (ByVal hwnd As Long, _
                ByVal lpString As String, _
                ByVal cch As Long) As Long
                
Private Declare Function GetClassName Lib "user32.dll" _
                Alias "GetClassNameA" _
                (ByVal hwnd As Long, _
                ByVal lpClassName As String, _
                ByVal nMaxCount As Long) As Long

Private Const GW_HWNDNEXT = 2&
Private Const GW_CHILD = 5&

' Esta función enumera las ventanas abiertas y comprueba
' que no sea otra ventana de Access. En caso de que 
' encuentre una, compara los títulos de las ventanas
' de base de datos. Si son iguales es que ya hay una
' instancia abierta de la base de datos.
'
Function PrevInstance() As Boolean
Dim sODb1 As String, sODb2 As String, sClass As String
Dim hwnd As Long

    ' averiguamos el título de la ventana Base de Datos
    sODb1 = ODbCaption(hWndAccessApp)
    
    ' enumeramos las ventanas abiertas
    hwnd = GetWindow(GetDesktopWindow, GW_CHILD)
    sClass = Space(255)
    
    Do
      If hwnd Then
        ' si la ventana no es la de nuestra aplicación
        If hwnd <> hWndAccessApp Then
          ' averiguamos el nombre de la clase de ventana
          Call GetClassName(hwnd, sClass, 255)
          ' si la ventana es una ventana de Access...
          If Trim(sClass) = "OMain" & vbNullChar Then
            sODb2 = ODbCaption(hwnd)
            ' si la ventana base de datos tiene el mismo
            ' título que la nuestras, es que ya está 
            ' abierta
            If sODb2 = sODb1 Then
              PrevInstance = True
              Exit Function
            End If
          End If
        End If
          sClass = Space(255)
          ' obtenemos el manipulador de la siguiente 
          ' ventana abierta
          hwnd = GetWindow(hwnd, GW_HWNDNEXT)
      Else
        Exit Do
      End If
    Loop
        
End Function

' Esta función devuelve el título de la ventana base de
' datos de una aplicación de Access. El argumento hwnd
' ha de ser la propiedad hWndAccessApp (manipulador de
' la ventana principal de Access)
'
Function ODbCaption(hwnd As Long) As String
Dim sODb As String
Dim hMDi As Long, hODb As Long

    ' obtenemos el manipulador de ventana de la ventana
    ' MDI de Access
    hMDi = FindWindowEx(hwnd, 0&, "MDIClient", vbNullString)
    
    ' obtenemos el manipulador de ventana de la ventana
    ' base de datos
    hODb = FindWindowEx(hMDi, 0&, "ODb", vbNullString)
    
    ' averiguamos el título de la ventana base de datos
    sODb = String(255, " ")
    Call GetWindowText(hODb, sODb, 255)
    ODbCaption = Trim(sODb)
    
End Function'*********************************************************

SOLUCION DEL BUHO
=================
Option Compare Database
Option Explicit
Private Declare Function EquipoApi Lib "kernel32" Alias _
    "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long


Function PrevInstanceRed() As Boolean
'esta sería ya la general, como la tuya, para el supuesto caso de una MDB en un ordenador
'en RED para impidir y que un usuario picara dos veces en la misma
'mdb e impedir abrir dos instancias en UN PC CONCRETO de la red.
'No utilizo metodos FIND ni similares, simplemente recorro
'el bucle a pelo, ya que se supone que una MDB no puede tener
'muchos accesos simultaneos. No sirve, claro para los ADP's

Const adhcUsers = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
   Dim RsADO As ADODB.Recordset, Contador As Integer
   Set RsADO = New ADODB.Recordset
   Set RsADO = CurrentProject.Connection.OpenSchema( _
       schema:=adSchemaProviderSpecific, schemaid:=adhcUsers)
   While Not RsADO.EOF = True
    If Trim(Replace(RsADO!Computer_name, vbNullChar, _
        "")) = DameEquipoWSH() Then
     Contador = Contador + 1
    End If
    RsADO.MoveNext
   Wend
   RsADO.Close
   Set RsADO = Nothing
   If Contador > 1 Then PrevInstanceRed = True
   
End Function

'*********************************************************************************
'Aqui, por recordar, que viene bien siempre, pongo los diferenets sistemas que
'conozco para sacar el nombre del equipo en RED.
'*********************************************************************************

'Hay varios sistemas para saber el nombre del equipo que corre en esta maquina.
'Si uso Environ,no funciona en sistema Windows < XP
Private Function DameEquipoEnviron() As String
 DameEquipoEnviron = Environ("COMPUTERNAME")
End Function

'Esta funcionará en equipos Win98 en adelante, no creo que haya
'alguna antiguaya con Win 95
Private Function DameEquipoWSH() As String
  Dim ObjetoRed As Object
  Set ObjetoRed = CreateObject("WScript.Network")
  DameEquipoWSH = ObjetoRed.Computername
  Set ObjetoRed = Nothing
End Function

'Aqui la API...pero tengo la misma duda, si en Win 95 existe esta API o no.
'Y es que manda guevos con las versiones !!!!
Private Function DameEquipoApi() As String
    Dim Devuelve As String
    Devuelve = String(255, Chr$(0))
    EquipoApi Devuelve, 255
    DameEquipoApi = Left$(Devuelve, InStr(1, Devuelve, Chr$(0)) - 1)
End Function