** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Tus Funciones Favoritas & Aportaciones & Artí­culos
  Mensajes nuevos Mensajes nuevos RSS - FORMULARIOS:Impedir abrir mas de un Form a la vez
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoFORMULARIOS:Impedir abrir mas de un Form a la vez

 Responder Responder
Autor
Mensaje
admin Ver desplegable
Administrador
Administrador
Avatar

Unido: 14/Agosto/2013
Localización: Cualquier lugar
Estado: Sin conexión
Puntos: 790
Enlace directo a este mensaje Tema: FORMULARIOS:Impedir abrir mas de un Form a la vez
    Enviado: 14/Agosto/2013 a las 08:26
Autor Marius 2004

Esta función impide abrir un formulario mientras otro usuario este usando ese (u otro) formulario, en un entorno FrontEnd / BackEnd

Uso:

Private Sub Form_Open(Cancel As Integer)
If Not AWformUnico() Then
    Cancel = True
    Exit Sub
End If
'...
End Sub

'******************************

'* Marcar en referencias:

'* Microsoft DAO 3.x

'* Windows Script Host Object Model (wshom.ocx)

'*

'* Si no usamos WSHOM borrar las lineas  'referencia a wshom

'*

'* (Esta funcion debe incluirse dentro del modulo del Form)

'*

'* ******************************

 

 

Private Function AWformUnico()

  Static dbsUnico As DAO.Database

  Dim tbl As DAO.TableDef, dbs As DAO.Database

  Dim AWrutaDb, AWconnectDb, AWrutaDbForm, usrName

  Dim shellTMP As New IWshNetwork_Class 'referencia a wshom

 

  On Error GoTo errorAWformUnico

  For Each tbl In CurrentDb.TableDefs

    If tbl.Connect > "" Then

      AWrutaDb = Mid(tbl.Connect, InStr(tbl.Connect, "DATABASE=") + 9)

      AWconnectDb = Left(tbl.Connect, InStr(tbl.Connect, "DATABASE=") - 2)

      AWrutaDbForm = Left(AWrutaDb, InStrRev(AWrutaDb, "\")) & "DbForm.mdb"

      If Dir(AWrutaDbForm) = "" Then

        DBEngine.Workspaces(0).CreateDatabase AWrutaDbForm, dbLangGeneral

      End If

      Set dbs = OpenDatabase(AWrutaDb, False, False, AWconnectDb)

      Set dbsUnico = OpenDatabase(AWrutaDbForm, True, False)

      On Error Resume Next

      dbs.Properties.Delete "DbForm"

      usrName = CurrentUser

      usrName = usrName & " (" & shellTMP.ComputerName & "/" & shellTMP.UserName & ")"

      ' linea superior, referencia a wshom

      On Error GoTo errorAWformUnico

      dbs.Properties.Append dbs.CreateProperty("DbForm", DB_TEXT, usrName)

      dbs.Close

      Exit For

    End If

  Next

  AWformUnico = True

 

AWformUnicoExit:

  Set dbs = Nothing

  Exit Function

 

errorAWformUnico:

  If Err.Number = 3045 Then

    MsgBox "En este momento " & dbs.Properties("DbForm").Value & vbNewLine _

    & "esta usando este formulario. " & vbNewLine & vbNewLine & "Intentelo mas tarde." _

    , vbInformation, "No puede abrir " & Me.Caption

    AWformUnico = False

  Else

    MsgBox Err.Description

  End If

  Resume AWformUnicoExit

End Function

Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable