Rambler's Top100
Форум: MS ACCESSVBVBA MS OfficeMS SQL server
Новые сообщения: 0000

Форум: MS ACCESS

Вопросы связанные с MS ACCESS

Обновить визитку
Участники «Online»
Все участники

 
 

Доброго времени суток, Посетитель!

вид форума:
Линейный форум Структурный форум

тема: Узнать кто из пользователей работает в базе....
 
 автор: seluvan   (26.11.2010 в 13:22)   личное сообщение
 
 

Вообщем смысл такой:
есть таблица, к ней прикреплены клиенты.
Как можно выудить из базы, кто именно сейчас "прикреплён" к базе.
Где то видел, а не помню именно где.....

  Ответить  
 
 автор: kot_k_k   (26.11.2010 в 13:57)   личное сообщение
 
 

создается файл имя_базы.LDB в том же каталоге эт для непосредствеено файлового подключения

  Ответить  
 
 автор: Amer   (26.11.2010 в 14:35)   личное сообщение
27 Кб.
 
 

  Ответить  
 
 автор: Amer   (26.11.2010 в 14:32)   личное сообщение
 
 

LDBView.exe

  Ответить  
 
 автор: Amer   (26.11.2010 в 14:33)   личное сообщение
27 Кб.
 
 

LDBView.exe

  Ответить  
 
 автор: Amer   (26.11.2010 в 14:34)   личное сообщение
27 Кб.
 
 

  Ответить  
 
 автор: Amer   (26.11.2010 в 14:38)   личное сообщение
27 Кб.
 
 

  Ответить  
 
 автор: seluvan   (26.11.2010 в 14:44)   личное сообщение
 
 

Amer спс за ответ.
Вижу..показывает.
А есть что нибудь из программного кода, чтоби внутрь админ базы всунуть и оттуда видеть кто сидит в ней?

  Ответить  
 
 автор: DeBob   (26.11.2010 в 15:39)   личное сообщение
 
 

Спёрто не помню откуда, но во многих местах лежит этот код:

Option Compare Database
Option Explicit


Private Declare Function apiGetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'Это в раздел описаний модуля
Type UserRec
bMach(1 To 32) As String * 1 '1-е 32 байта для имени машины
bUser(1 To 32) As String * 1 '2-е 32 байта для имени пользователя
End Type

'Это сама функция
Public Function WhosOn() As String
Dim iLDBFile As Integer
Dim i As Integer
Dim sLogStr As String, sLogins As String
Dim sMach As String, sUser As String
Dim rUser As UserRec ' Defined in General
Dim spath
Dim db As Database
On Error GoTo Err_WhosOn
'получаем ссылку на текщую БД
Set db = DBEngine.Workspaces(0).Databases(0)
' определяем путь и имя текущей базы
spath = db.Name
' получаем незанятый номера файла для использования инструкцией OPEN
iLDBFile = FreeFile
'формируем имя ldb-файла
spath = Left(spath, Len(spath) - 5) & "ldb"
'проверяем наличие ldb-файла
If Dir(spath) = "" Then WhosOn = "ldb-файл отсутствует": GoTo Exit_WhosOn
'открываем ldb-файл для чтения
Open spath For Binary Access Read Shared As iLDBFile
'пока не встречен конец ldb-файла
Do While Not EOF(iLDBFile)
'считываем из файла данные в переменную rUser 32 байта
'в rUser.bMach и 32 байта в rUser.bUser
Get iLDBFile, , rUser
i = 1: sMach = ""
'пока код i-го символа в переменной rUser.bMach <> 0
'добавляем i-й символ rUser.bMach к переменной sMach
'по окончании цикла в переменной sMach будет
'сетевое имя подключенной машины
While Asc(rUser.bMach(i)) <> 0
sMach = sMach & rUser.bMach(i)
i = i + 1
Wend
i = 1: sUser = ""
'пока код i-го символа в переменной rUser.bUser <> 0
'добавляем i-й символ rUser.bUser к переменной sUser
'по окончании цикла в переменной sUser будет имя пользователя
While Asc(rUser.bUser(i)) <> 0
sUser = sUser & rUser.bUser(i)
i = i + 1
Wend
'формируем строку с именем машины и пользователя
'(переменные sMach и sUser)
sLogStr = sMach & " -- " & sUser
'если такой пары машина-пользователь нет в результирующей
'добавляем в результирующую строку и разделитель (";")
If InStr(sLogins, sLogStr) = 0 Then sLogins = sLogins & sLogStr & ";"
Loop
'закрываем ldb-файл
Close iLDBFile
'присваиваем функции сформированную строку
WhosOn = sLogins
MsgBox sLogins
Exit_WhosOn:
Set db = Nothing
Exit Function

Err_WhosOn:
If Err = 68 Then
MsgBox "Нет доступа к laccdb файлу.", 48, "Ошибка"
Else
MsgBox "Ошибка #" & Err & Chr(13) + Chr(10) & Error(Err), 48, "Ошибка"
Close iLDBFile
End If
Resume Exit_WhosOn
End Function

  Ответить  
 
 автор: seluvan   (26.11.2010 в 16:00)   личное сообщение
 
 

DeBob - а у вас код тянет инфу.
У меня почему то пишет, что "ldb-файл отсутствует", хотя 100% он есть.
В чём может быть проблема?

  Ответить  
 
 автор: DeBob   (26.11.2010 в 16:11)   личное сообщение
 
 

формируем имя ldb-файла
spath = Left(spath, Len(spath) - 3) & "ldb"
'проверяем наличие ldb-файла
spath проверьте, у меня под 2007 заточена процедура была., там расширение accdb :)

  Ответить  
 
 автор: seluvan   (26.11.2010 в 16:31)   личное сообщение
 
 

DeBob - спасибо работает, обрезал под 2007 акс.
Спасибо ещё раз, всё идеально

  Ответить  
 
 автор: osmor   (26.11.2010 в 16:08)   личное сообщение
 
 

http://hiprog.com/index.php?option=com_content&task=view&id=358
http://hiprog.com/index.php?option=com_content&task=view&id=603
http://hiprog.com/index.php?option=com_content&task=view&id=168
и в догонку

Sub ListUsers()

    ' Lists the current users of the database to
    ' the debug window.
     
    ' From Access 2002 Enterprise Developer's Handbook
    ' by Litwin, Getz, and Gunderloy. (Sybex)
    ' Copyright 2001. All rights reserved.
    
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim intUser As Integer
    
    ' The user list schema information requires this magic
    ' number. Why isn't a constant predefined for this?
    ' Who knows.
    Const adhcUsers = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
    
    Set cnn = New ADODB.Connection
    Set cnn = CurrentProject.Connection
    
    Set rst = cnn.OpenSchema(adSchemaProviderSpecific, , adhcUsers)
    With rst
        Do Until .EOF
            intUser = intUser + 1
            Debug.Print "User # " & intUser
            For Each fld In .Fields
                Debug.Print "  " & fld.name & "=" & fld.Value
            Next
            .MoveNext
        Loop
    End With
End Sub

  Ответить  
 
 автор: Stanislav   (08.12.2010 в 04:41)   личное сообщение
 
 

Код
http://hiprog.com/index.php?option=com_content&task=view&id=358
переделанный для MSA 2007 (работает ):

'Это в раздел описаний модуля
Type UserRec
bMach(1 To 32) As String * 1 '1-е 32 байта для имени машины
bUser(1 To 32) As String * 1 '2-е 32 байта для имени пользователя
End Type

'Это сама функция
Function WhosOn() As String
Dim ilaccdbFile As Integer
Dim i As Integer
Dim sLogStr As String, sLogins As String
Dim sMach As String, sUser As String
Dim rUser As UserRec ' Defined in General
Dim spath
Dim db As Database
On Error GoTo Err_WhosOn
'получаем ссылку на текщую БД
Set db = DBEngine.Workspaces(0).Databases(0)
' определяем путь и имя текущей базы
spath = db.Name
' получаем незанятый номера файла для использования инструкцией OPEN
ilaccdbFile = FreeFile
'формируем имя laccdb-файла
spath = Left(spath, Len(spath) - 5) & "laccdb"
'проверяем наличие laccdb-файла
If Dir(spath) = "" Then WhosOn = "laccdb-файл отсутствует": GoTo Exit_WhosOn
'открываем laccdb-файл для чтения
Open spath For Binary Access Read Shared As ilaccdbFile
'пока не встречен конец laccdb-файла
Do While Not EOF(ilaccdbFile)
'считываем из файла данные в переменную rUser 32 байта
'в rUser.bMach и 32 байта в rUser.bUser
Get ilaccdbFile, , rUser
i = 1: sMach = ""
'пока код i-го символа в переменной rUser.bMach <> 0
'добавляем i-й символ rUser.bMach к переменной sMach
'по окончании цикла в переменной sMach будет
'сетевое имя подключенной машины
While Asc(rUser.bMach(i)) <> 0
sMach = sMach & rUser.bMach(i)
i = i + 1
Wend
i = 1: sUser = ""
'пока код i-го символа в переменной rUser.bUser <> 0
'добавляем i-й символ rUser.bUser к переменной sUser
'по окончании цикла в переменной sUser будет имя пользователя
While Asc(rUser.bUser(i)) <> 0
sUser = sUser & rUser.bUser(i)
i = i + 1
Wend
'формируем строку с именем машины и пользователя
'(переменные sMach и sUser)
sLogStr = sMach & " -- " & sUser
'если такой пары машина-пользователь нет в результирующей
'добавляем в результирующую строку и разделитель (";")
If InStr(sLogins, sLogStr) = 0 Then sLogins = sLogins & sLogStr _
& ";"
Loop
'закрываем laccdb-файл
Close ilaccdbFile
'присваиваем функции сформированную строку
WhosOn = sLogins

Exit_WhosOn:
Set db = Nothing
Exit Function

Err_WhosOn:
If Err = 68 Then
MsgBox "Нет доступа к laccdb файлу.", 48, "Ошибка"
Else
MsgBox "Ошибка #" & Err & Chr(13) & Chr(10) & Error(Err), 48, "Ошибка"
Close ilaccdbFile
End If
Resume Exit_WhosOn
End Function

  Ответить  
HiProg.com - Технологии программирования
Rambler's Top100 TopList