Imprimir página | Cerrar ventana

Formularios: Impedir abrir Frm si está en uso

Impreso de: Foro de Access y VBA
Categoría: Access y VBA
Nombre del foro: Tus Funciones Favoritas & Aportaciones & Artí­culos
Descripción del foro: Para publicar código interesante, aportaciones y artículos
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=77394
Fecha de impresión: 03/Junio/2020 a las 22:26


Tema: Formularios: Impedir abrir Frm si está en uso
Publicado por: admin
Asunto: Formularios: Impedir abrir Frm si está en uso
Fecha de publicación: 21/Agosto/2013 a las 17:01
Original de Marius.


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




Imprimir página | Cerrar ventana