Instância Única - Sair se for mais que uma aberta

Olá a todos,

A propósito deste tópico, partilho exemplo como verificar se existe mais que uma instancia aberta e sair sempre que uma já esteja aberta.
Para não atrasar a abertura dos meus aplicativos, normalmente coloco no botão de login do utilizador.

Código:

Código:

Private Sub cmdTeste_Click()
'ahteixeira para maximoaccess em 30-11-2021
    IsRunning
End Sub


'2008-05 Para verificar se mde já está aberta
Function IsRunning() As Integer
On Error GoTo PROC_ERR
Dim DB As DAO.Database
Set DB = CurrentDb
    
    If TestDDELink(DB.Name) Then
        DB.Close
        Set DB = Nothing
        Beep
        MsgBox (Chr(13) & "A aplicação já se encontra activa, verifique se não está minimizada." & Chr(13) & Chr(13) & "Esta inicialização será encerrada."), vbCritical, " Aviso"
        DoCmd.Quit
    End If
Exit Function

PROC_ERR:
    MsgBox "Erro no Arranque na função IsRunning : " & Error$
    Resume Next
End Function

'2008-05 Para verificar se mde já está aberta
Function TestDDELink(ByVal strAppName$) As Integer
    Dim varDDEChannel
    On Error Resume Next
    Application.SetOption ("Ignore DDE Requests"), True
    varDDEChannel = DDEInitiate("MSAccess", strAppName)
    ' When the app isn't already running this will error
    If Err Then
        TestDDELink = False
    Else
        TestDDELink = True
        DDETerminate varDDEChannel
        DDETerminateAll
    End If
    Application.SetOption ("Ignore DDE Requests"), False
End Function



Nota, para testar o exemplo devem abrir o ACCDE duas vezes.


Abraço