Запрет на повторный запуск Приложения (API)

'--------------------------------------------------------------------
' Module    : modAppRunOnceOnly
' Author    : es
' Date      : 15.03.2013
' Purpose   : Запрет на повторный запуск Приложения
'             работает по: СurrentDb.Properties ("AppTitle") = Заголовку
'--------------------------------------------------------------------
'Идея: АндрейК  http://www.sql.ru/forum/actualthread.aspx?tid=105844
'--------------------------------------------------------------------
'Использование:
'Запуск процедуры:
'   AppRunOnceOnlyTest ' - на старте приложения любым доступным способом
' На OnLoad() - стартовой формы например.
' - Собщение и выход из приложения = Автоматом
'--------------------------------------------------------------------

Option Compare Database
Option Explicit

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
    (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Public Sub AppRunOnceOnlyTest()
'--------------------------------------------------------------------
'es - 15.03.2013
' Тест апликации на повторный запуск по: CurrentDb.Properties("AppTitle")
' При обнаружении: ВЫХОД из ВТОРОЙ КОПИИ c Сообщением ..
' ВНИМАНИЕ!!!
'   CurrentDb.Properties("AppTitle") - На момент проверки - должно быть задано!
'--------------------------------------------------------------------
On Error GoTo AppRunOnceOnlyTest_Err
Dim l As Integer
Dim s As String
    
    s = Trim(CurrentDb.Properties("AppTitle"))
    l = GetCountOfWindows(hWndAccessApp, s)
    'Debug.Print l
    If l > 1 Then
        MsgBox "Приложение: [" & s & "] - уже открыто на вашем компьютере !!!"
        Application.Quit acQuitSaveNone
    End If


AppRunOnceOnlyTest_Bye:
    Exit Sub

AppRunOnceOnlyTest_Err:
    If Err.Number = 3270 Then 'Err = Property not Found! - т.е. = CurrentDb.Properties("AppTitle")
        'Странно!
        ' - Заголовок аппликации не установлен
        ' - Так это первое, что нужно сделать!!!
        'тут можно что то ещё написать ...
        'MsgBox ...
    Else
        MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
        "in procedure AppRunOnceOnlyTest", vbCritical, "Error!"
    End If
    Resume AppRunOnceOnlyTest_Bye
End Sub

Private Function GetCountOfWindows(lHwnd As Long, sApplicationCaption As String) As Integer
Dim lResult As Long
Dim iCount As Integer
Dim StrAppName As String
'es - 15.03.2013
'Возвращает кол-во открытых окон с заголовком = sApplicationCaption
'--------------------------------------------------------------------
On Error GoTo GetCountOfWindows_Err
lResult = GetWindow(lHwnd, 0)

    Do Until lResult = 0
        If IsWindowVisible(lResult) Then
            StrAppName = GetAppName(lResult)
            If InStr(1, StrAppName, sApplicationCaption) Then
                iCount = iCount + 1
            End If
        End If
        lResult = GetWindow(lResult, 2)
    Loop
    
    GetCountOfWindows = iCount

GetCountOfWindows_Bye:
    Exit Function

GetCountOfWindows_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure GetCountOfWindows", vbCritical, "Error!"
    Resume GetCountOfWindows_Bye
End Function

Private Function GetAppName(lHwnd As Long) As String
Dim LngResult As Long
Dim StrWinText As String * 255
'--------------------------------------------------------------------
On Error GoTo GetAppName_Err
    LngResult = GetWindowText(lHwnd, StrWinText, 255)
    GetAppName = Left(StrWinText, LngResult)

GetAppName_Bye:
    Exit Function

GetAppName_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure GetAppName", vbCritical, "Error!"
    Resume GetAppName_Bye
End Function

Запрет на повторный запуск Приложения (Только одна копия) - MAUG

Ответил  Долгополов Роман в конференции на MAUG

Как определить открыто уже Приложение  на машине?
    Все достаточно просто решается с использованием Win API ....
    Здесь в конструкторе создается скрытое окно с уникальным заголовком, а в деструкторе оно уничтожается.
Теперь там, где хочешь проверить загружена твоя база или нет пиши
     Set g_objAccLoaded = New CCheckDBLoaded
Если это первая копия базы, то все пройдет нормально, но если вторая то вылетит ошибка E_DATABASE_ALREADYLOADED.
В обработчике ошибок выведи юзерам какое-нибудь злобное сообщение и завершай программу.
При завершении программы наш глобальный объект g_objAccLoaded будет разрушен и скрытое окно следовательно то-же.
    Вся эта стратегия позволяет запускать несколько копий Access, но только одну копию каждой базы. Для каждой базы нужно только
задать уникальное значение в константу UNIQUE_CAPTION. В принципе можно писать любую ахинею в эту константу, я же люблю использовать для таких вещей GUID.
    Его можно создать программой GUIDGEN из Visual Studio.
    Вроде все.
С уважением Долгополов Роман.

'Все достаточно просто решается с использованием Win API
'В каком - нибудь стандартном модуле объявляем константу
    Public Const E_DATABASE_ALREADYLOADED = vbObjectError + 1000
'и переменную 
    Public g_objAccLoaded AS CCheckDBLoaded

Делаем модуль класса c названием: "CCheckDBLoaded"

Это его текст:

'--------------------------------------------------------------------
' Module    : CCheckDBLoaded
' Author    : Долгополов Роман
' Purpose   : Проверка не открыта ли уже база данных на машине (только одна копия)
'--------------------------------------------------------------------

Option Compare Database
Option Explicit

Private Const UNIQUE_CAPTION = "{DE427338-F933-4cf7-9D9F-B15999D7FF66}"
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Const GWL_HINSTANCE = (-6)

Dim hWnd As Long

Private Sub Class_Initialize()
Dim bLoaded As Boolean
Dim hInstance As Long
     
     If FindWindow(vbNullString, UNIQUE_CAPTION) <> 0 Then
         Err.Raise E_DATABASE_ALREADYLOADED, "", "База данных уже загружена"
     End If
  
     hInstance = GetWindowLong(Application.hWndAccessApp, GWL_HINSTANCE)
     hWnd = CreateWindowEx(0, "BUTTON", UNIQUE_CAPTION, 0, 0, 0, 1, 1, 0, 0, hInstance, 0)
End Sub

Private Sub Class_Terminate()
If hWnd <> 0 Then
     DestroyWindow hWnd
End If
End Sub