PDA

Vollständige Version anzeigen : anzeigen wer aktuell in der Datenbank ist


Cuugan
13.06.2012, 13:07
Hi,

wir haben eine Datenbank in der mehrere Leute gleichzeitig arbeiten.
Gibt es die Möglichkeit, dass ich beim Start meines Frontends im Startformular angezeigt bekomme, wer aktuell Zugriff auf das Backend nimmt.
Hier reicht mir die IP, oder sonstige PC-Bezeichnungen.

Wäre toll wenn Ihr Tipps für mich habt.

Gruß
Hansi

Atrus2711
13.06.2012, 13:11
Früher ging das mal so:
http://www.ms-office-forum.de/forum/showthread.php?t=262152&highlight=userroster
Aber ob das heute noch geht...?!

Marsu65
13.06.2012, 14:54
Eine weitere Form bietet
http://www.kulpa-online.com/tutorial-ddl-103.html

Die mdb-spezifischen Teile auf accdb umschreiben.

Andre.Heisig
13.06.2012, 15:29
und hier noch ein Code-Schnipsel dazu von Sascha Trowitzsch, den ich irgendwo aus den Untiefen hier gezogen hab =>

Option Compare Database
Option Explicit

'mossSOFT 2007
'Sascha Trowitzsch

Private Const ERROR_MORE_DATA As Long = 234
Private Const ERROR_SUCCESS As Long = 0&
Private Const MAX_PREFERRED_LENGTH As Long = -1

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const OPEN_EXISTING = 3
Private Const FILE_BEGIN = 0

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Private Type SecInfo
bMachine(1 To 32) As Byte
bSecurity(1 To 32) As Byte
End Type

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type BY_HANDLE_FILE_INFORMATION
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
dwVolumeSerialNumber As Long
nFileSizeHigh As Long
nFileSizeLow As Long
nNumberOfLinks As Long
nFileIndexHigh As Long
nFileIndexLow As Long
End Type

Private Type WKSTA_USER_INFO_1
wkui1_username As Long
wkui1_logon_domain As Long
wkui1_oth_domains As Long
wkui1_logon_server As Long
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As _
SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal _
hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As _
Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal _
nNumberOfBytesToLockHigh As Long) As Long
Private Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As _
Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal _
nNumberOfBytesToUnlockHigh As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove _
As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function lRead Lib "kernel32" Alias "_lread" (ByVal hFile As Long, lpBuffer As Any, _
ByVal wBytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, _
ByVal Length As Long)
Private Declare Function NetApiBufferFree Lib "NETAPI32.dll" (ByRef Buffer As Any) As Long
Private Declare Function NetWkstaUserEnum Lib "Netapi32" (ByVal servername As Long, ByVal Level As _
Long, bufptr As Long, ByVal prefmaxlen As Long, entriesread As Long, totalentries As Long, _
resume_handle As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long




'Prozedur zum Testen der Funktion DBUsers
Public Sub TestThisDbUsers()
Dim strPath As String
Dim arrUserList As Variant
Dim n, i As Long

strPath = CurrentDb.Name
arrUserList = DBUsers(strPath)

i = -1
On Error Resume Next
i = UBound(arrUserList, 2)
On Error GoTo 0
If i > -1 Then
For n = 0 To i
Debug.Print "DBUser:", arrUserList(0, n)
Debug.Print "Rechner:", arrUserList(1, n)
Debug.Print "User Login:", arrUserList(2, n)
Debug.Print
Next n
End If
End Sub



'In eine Access-DB eingeloggte User ermitteln
'Gibt ein zwidimensionales String-Array zurück
'Erste Dimension: 0 = Name des Users, der die DB geöffnet hat
' 1 = Rechnername, von dem zugegriffen wird
' 2 = Name des Users, wie er sich auf jenem Rechner eingeloggt hat
'Zweite Dimension: Counter
Public Function DBUsers(ByVal sDBFile As String) As Variant
Dim sLDBFile
Dim mSecurity As SECURITY_ATTRIBUTES
Dim fHandle As Long
Dim LDBInfo As SecInfo
Dim arrUser(254, 2) As String
Dim i As Integer
Dim iOffset As Integer
Dim lBytesRead As Long
Dim lPos As Long
Dim lLock As Long
Dim arrResult() As String
Dim lngRet As Long
Dim nCount As Long
Dim sDB As String
Dim strExt As String

On Error Resume Next
sDB = Dir(sDBFile)

On Error GoTo Fehler
If Len(sDB) = 0 Then
Err.Raise 53, "DBUsers", "Datei nicht gefunden: " & sDBFile
End If

strExt = Mid(sDBFile, InStrRev(sDBFile, "."))
Select Case Left(strExt, 3)
Case ".ac" 'A2007
strExt = ".laccdb"
Case Else
strExt = ".ldb"
End Select
sLDBFile = Mid(sDBFile, 1, InStrRev(sDBFile, ".") - 1) & strExt

On Error Resume Next
sDB = ""
sDB = Dir(sLDBFile)
On Error GoTo Fehler
If Len(sDB) = 0 Then
Err.Raise 53, "DBUsers", "Datenbank " & sDBFile & " scheint nicht geöffnet zu sein." & _
vbCrLf & "(Es existiert keine zugehörige LDB-Datei)"
End If

With mSecurity
.nLength = Len(mSecurity)
.lpSecurityDescriptor = 0
.bInheritHandle = True
End With

fHandle = CreateFile(sLDBFile, _
GENERIC_READ Or GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
mSecurity, _
OPEN_EXISTING, _
FILE_FLAG_RANDOM_ACCESS Or FILE_ATTRIBUTE_NORMAL, 0)

If fHandle = 0 Then Err.Raise _
vbObjectError + 1, "DBUsers", "LDB kann nicht geöffnet werden"

SetFilePointer fHandle, 0, 0, FILE_BEGIN
iOffset = 0
i = 0

'Texte aus ldb auslesen
Do
lBytesRead = lRead(fHandle, LDBInfo, 64)
If lBytesRead = 0 Then Exit Do
If lBytesRead <> 64 Then Err.Raise _
vbObjectError + 2, "DBUsers", "Fehler beim Lesen der LDB bzw. LACCDB"
arrUser(i, 0) = BytesToString(LDBInfo.bSecurity)
arrUser(i, 1) = BytesToString(LDBInfo.bMachine)
arrUser(i, 2) = iOffset
i = i + 1
iOffset = iOffset + 64
Loop

'Locks ermitteln
i = 0
lPos = &H10000001
ReDim arrResult(2, 0)
Do Until lPos = &H100000FF
lLock = LockFile(fHandle, lPos, 0, 1, 0)
If lLock = 0 Then
iOffset = (lPos And &HFF) * 64 - 64
For i = 0 To 254
If Len(arrUser(i, 2)) = 0 Then Exit For
If arrUser(i, 2) = iOffset Then
ReDim Preserve arrResult(2, nCount)
arrResult(0, nCount) = arrUser(i, 0)
arrResult(1, nCount) = arrUser(i, 1)
arrResult(2, nCount) = GetConnectedUsers(arrResult(1, nCount))
nCount = nCount + 1
End If
Next i
Else
lLock = UnlockFile(fHandle, lPos, 0, 1, 0)
End If
lPos = lPos + 1
Loop

DBUsers = arrResult

Ende:
If fHandle > 0 Then CloseHandle (fHandle)
Exit Function

Fehler:
MsgBox Err.Description, vbCritical
DBUsers = Null
Resume Ende
End Function



'Usernamen ermitteln, die auf einem Rechner eingeloggt sind
'Mehrere User werden semikolonsepariert
'Bsp.: ? GetConnectedUsers("\\Zentralserver")
Public Function GetConnectedUsers(Optional sMachineName As String) As String
Dim lPtrBuf As Long
Dim lpServerName As Long
Dim lRead As Long
Dim lSum As Long
Dim lResume As Long
Dim nStatus As Long
Dim nSize As Long
Dim i As Long
Dim TUserInfo As WKSTA_USER_INFO_1
Dim strUsers As String
Dim strUser As String

On Error GoTo Fehler

lpServerName = StrPtr(sMachineName)
nSize = LenB(TUserInfo)
Do
nStatus = NetWkstaUserEnum(lpServerName, _
1, _
lPtrBuf, _
MAX_PREFERRED_LENGTH, _
lRead, _
lSum, _
lResume)
If nStatus = ERROR_SUCCESS Or nStatus = ERROR_MORE_DATA Then
If lRead > 0 Then
For i = 0 To lRead - 1
CopyMemory TUserInfo, ByVal lPtrBuf + (nSize * i), nSize
strUser = PointerToStringW(TUserInfo.wkui1_username)
'Administrative User ausfiltern
If InStr(1, strUser, "$") = 0 Then
strUsers = strUsers & strUser & "/"
End If
Next
End If
If Len(strUsers) > 0 Then GetConnectedUsers = Left(strUsers, Len(strUsers) - 1)
Else
Err.Raise nStatus, "GetConnectedUsers", "Netzwerkzugriff scheiterte"
End If
Loop While nStatus = ERROR_MORE_DATA

Ende:
If lPtrBuf <> 0 Then NetApiBufferFree lPtrBuf
Exit Function

Fehler:
' MsgBox Err.Description, vbCritical, "GetConnectedUsers"
Debug.Print "Fehler in Prozedur GetConnectedUsers für '" & _
sMachineName & "': " & Err.Description
Resume Ende
End Function




'--- Hilfsfunktionen -------------------------------------------

Private Function BytesToString(arrBytes() As Byte) As String
Dim sTemp As String
sTemp = StrConv(arrBytes(), vbUnicode)
BytesToString = Left$(sTemp, (InStr(1, sTemp, Chr(0))) - 1)
End Function

Private Function PointerToStringW(lpString As Long) As String
Dim buff() As Byte
Dim nSize As Long

If lpString Then
nSize = lstrlenW(lpString) * 2
If nSize > 0 Then
ReDim buff(0 To (nSize - 1)) As Byte
CopyMemory buff(0), ByVal lpString, nSize
PointerToStringW = buff
End If
End If

End Function