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

'--------------------------------------------------------------------

' 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