display users currently logged into the database? 2

[julius1]

Is there a way to display users currently logged into a DB?
It is secured, and all have user names, but not sure how to get all users logged into a db to show up. This would be to gather names for kicking people out of the DB for updates and db maintenance that I would either send a novell pop up or email to. I saw a post on it a long time ago but was incomplete. Anyone have any ideas as to how to extract it?
Basically I would direct a button to run a query or code that would identify them and display on a form or datasheet view, but I have no clue how to get the data together to start.

 

[hwkranger]

use the CurrentUser function, kick everyone except yourself... tada

Randall Vollen
National City Bank Corp.

Just because you have an answer - doesn't mean it's the best answer.

 

[DeanWilliams]

Hi,

Randall, I am not sure that you can kick users that way. CurrentUser will only return who is logged in to the current session.

Julius: I have done this with one of my databases, but it was a lot of work:

I created a user table and routines that tick/untick a yes/no field in that table once a user logs in or out. I created a form that is used for adding/removing users which accesses the workgroup file and when a user is added, it adds them to this table. I use that table to show who is logged in.

The only problem is if a user crashes out or just switches off their machine they will still appear to be logged in.

But this is overcome by a hidden form that runs in the background whilst a user is in the system. It checks a certain directory (backend directory) for the presence of a file at regular intervals. This file is just a hidden file acting as a flag whereby, if it exists, users are prompted to log out within 5 minutes. Otherwise they are kicked automatically.

So then when I want to do any maintenance I start a function that attempts to compact & repair the database and keeps trying until it succeeds. This only occurs when all users are logged out. Users cannot log back into the database until the logout flag file is deleted.

I could send you some of the code and forms, but unfortunately I haven't made them very generic, so it would probably need quite a bit of debugging and cleaning up.

Dean.

 

[julius1]

Basically I have set up the timer form and the log out function already, but an overall check as to who is in the DB would help a great deal. I have nver heard of the current user function.. can anyone elaborate on that one please?

 

[DrSimon]

Microsoft have the answer!!

http://support.microsoft.com/defaul...port/kb/articles/Q176/6/70.ASP&NoWebContent=1

Download and run jetutils.exe. It will extract a number of routines one of which is LDBView.exe. That's the one you want.
Simon Rouse

 

[julius1]

The only thing I could use is the viewer. That produces machine ID's. Is there anyway I can get the log in's that were created in teh secured db to show up in a query or form to be viewed?
Everything else in the jetutil download is for access 95 or 97, not 2000 or 2002. But I appreciate the effort.
I'd be happy to try and tweak the forms. I have a couple of test DB's I can make them fit with.

 

[DrSimon]

Sorry, I find find machine names useful for the same purpose. We know where the machines so we can call them and ask people to log off.
Simon Rouse

 

[julius1]

I can understand that. I don't have the novell resources available to me to id the machines. But again thanks for the help!

 

[Saanich]

Try this

' Constants
'
'The Microsoft Jet Provider defines a number of GUIDs
'and property values that are for provider-specific features
'and properties. Because they are provider-specific values,
'ADO does not expose them in enumeration values or constants
' for further info see:
'

http://www.microsoft.com/data/ado/adotechinfo/dao2ado_9.htm

'

http://msdn.microsoft.com/library/techart/daotoadoupdate_topic10.htm

'Remember to set reference to MS ADO 2.5 or higher

' Jet OLE DB Provider Defined Schema Rowsets Constants

Global Const JET_SCHEMA_USERROSTER = _
"{947bb102-5d43-11d1-bdbf-00c04fb92675}"
Global Const JET_SCHEMA_ISAMSTATS = _
"{8703b612-5d43-11d1-bdbf-00c04fb92675}"

' Microsoft Jet OLEDBatabase Locking Mode property values
Global Const JET_DATABASELOCKMODE_PAGE = 0
Global Const JET_DATABASELOCKMODE_ROW = 1
'Remember to set reference to MS ADO 2.5 or higher
' sample calls
'
'ADOUserRoster "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"
'ADOUserStats "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"


Function ADOUserRoster(strAccessMDBName As String) As String
Dim cnn As New ADODB.Connection
Dim rst As ADODB.Recordset
Dim varGetString As Variant

' Use before ADO calls

On Error GoTo AdoError

' Open the connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strAccessMDBName & ";"


' Open the user roster schema rowset
Set rst = cnn.OpenSchema(adSchemaProviderSpecific, , _
JET_SCHEMA_USERROSTER)

' Print the results to the debug window
'Column Description
'COMPUTER_NAME The name of the workstation as specified using
' the Network icon in Control Panel.
'LOGIN_NAME The name of the user used to log on to the database
' if the database has been secured; otherwise,
' the default value will be Admin.
'CONNECTED True, if there is a corresponding user lock
' in the .ldb file.
'SUSPECTED_STATE True, if the user has left the database
' in a suspect state; otherwise, Null.

Debug.Print "Computer Name Login Name" & _
" Connected Suspected State"
'can only grab once
'Use all defaults: get all rows, TAB column delimiter, CARRIAGE RETURN
'row delimiter, empty-string null delimiter

varGetString = rst.GetString(adClipString, , ",", ";", "?&quot

'computer name string has a couple of nulls in so remove
Dim ab() As Byte
Dim i As Long
Dim lstrlen As Long
lstrlen = (Len(varGetString) - 1) * 2

ab = varGetString
For i = 0 To lstrlen Step 2

Debug.Print Chr(ab(i)); ab(i); i
If ab(i) = 0 Then
ab(i) = 32
End If
Next i
' Format string for text box
varGetString = ab
varGetString = Replace(varGetString, ",0,", ", False ,&quot
varGetString = Replace(varGetString, ",-1,", ", True ,&quot
varGetString = Replace(varGetString, ",?", ", ?? ,&quot
varGetString = Replace(varGetString, ",", " &quot
varGetString = Replace(varGetString, ";", vbCrLf)

Debug.Print varGetString

ADOUserRoster = "Computer Name Login Name" & _
" Connected Suspected State" & vbCrLf & _
varGetString


cnn.Close
Set cnn = Nothing
Exit Function
' ADO Error/Exception Handler
AdoError:
Dim ErrNumber As Long
Dim ErrSource As String
Dim ErrDescription As String

ErrNumber = Err.Number
ErrSource = Err.Source
ErrDescription = Err.Description

AdoErrorExpanded cnn
cnn.Close
Set cnn = Nothing
'where Cnn is Connection Object

End Function
Sub AdoErrorExpanded(Conn1 As ADODB.Connection)
' ADO Error/Exception Handler Expanded
Dim Errs1 As ADODB.Errors
Dim errLoop As ADODB.Error
Dim i As Long
Dim strMsgErr As String

i = 1
On Error Resume Next

' For any error condition, show results in debug
' Enumerate Errors collection and display properties
' of each Error object.
Set Errs1 = Conn1.Errors
For Each errLoop In Errs1

With errLoop
Debug.Print " Error #" & i & ":"
Debug.Print " ADO Error #" & .Number
Debug.Print " Description " & .Description
Debug.Print " Source " & .Source
Debug.Print " HelpFile " & .HelpFile
Debug.Print " HelpContext " & .HelpContext
Debug.Print " NativeError " & .NativeError
Debug.Print " SQLState " & .SQLState

strMsgErr = " Error #" & i & ":"
strMsgErr = strMsgErr & vbCrLf & " ADO Error #" & .Number
strMsgErr = strMsgErr & vbCrLf & " Description " & .Description
strMsgErr = strMsgErr & vbCrLf & " Source " & .Source
strMsgErr = strMsgErr & vbCrLf & " HelpFile " & .HelpFile
strMsgErr = strMsgErr & vbCrLf & " HelpContext " & .HelpContext
strMsgErr = strMsgErr & vbCrLf & " NativeError " & .NativeError
strMsgErr = strMsgErr & vbCrLf & " SQLState " & .SQLState
MsgBox strMsgErr

i = i + 1
End With

Next
With Conn1
Debug.Print "ADO Version: " & .Version & vbCrLf & _
"DBMS Name: " & .Properties("DBMS Name&quot & vbCrLf & _
"DBMS Version: " & .Properties("DBMS Version&quot & vbCrLf & _
"OLE DB Version: " & .Properties("OLE DB Version&quot & vbCrLf & _
"Provider Name: " & .Properties("Provider Name&quot & vbCrLf & _
"Provider Version: " & .Properties("Provider Version&quot & vbCrLf

Debug.Print "ADO Version: " & .Version & vbCrLf & _
"DBMS Name: " & .Properties("DBMS Name&quot & vbCrLf & _
"DBMS Version: " & .Properties("DBMS Version&quot & vbCrLf & _
"OLE DB Version: " & .Properties("OLE DB Version&quot & vbCrLf & _
"Provider Name: " & .Properties("Provider Name&quot & vbCrLf & _
"Provider Version: " & .Properties("Provider Version&quot & vbCrLf & _
"Driver Name: " & .Properties("Driver Name&quot & vbCrLf & _
"Driver Version: " & .Properties("Driver Version&quot & vbCrLf & _
"Driver ODBC Version: " & .Properties("Driver ODBC Version&quot
End With
End Sub

 

[julius1]

wow.

Ok, I have absolutely no clue how to plug that into the DB.
I am learning VB as I go, and I don't think I am that far yet. Can you kind of walk me thru what or where I need to add that to the DB for the function? I am guessing that from what I read it will display the users, with either the log in's provided or maching name and or just as admin. I think??

 

[Saanich]

Just open up a new module. Copy and Plop this code into it
Now just press CTRL-G. This brings up the intermediate debug window. Then type in
?ADOUserRoster "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"

Replace with the path and name of your mdb
and you will see a list of users in the mdb
You may have to fiddle with the formatting.
If you don't know the path to your current mdb
in debug window type in
?currentdb.name

If you still need help: here is an Access97 mdb that works
just put your mdb path and name in the table

http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=28652&lngWId=1

 

[julius1]

Cool, I can do that, quick question will this work on access 2000 or is for 97?

 

[julius1]

The sample DB works great, I added my DB's to the table and it works like a champ!!!

 

[CGill]

Saanich

Code looks like it will do the job but having set the reference I am still recieving a compile error relating to the use of 'replace' as per below

varGetString = Replace(varGetString, ",0,", ", False ,")
varGetString = Replace(varGetString, ",-1,", ", True ,")
varGetString = Replace(varGetString, ",?", ", ?? ,")
varGetString = Replace(varGetString, ",", " ")
varGetString = Replace(varGetString, ";", vbCrLf)

'Sub or Function not defined'

Any ideas presumably this is a reference issue ?

 

[Saanich]

Replace is an intrinsic function added in Access 2000 and VB6. There are lots of examples that exist on net to maintain backwards compatibility with VB5.
Here are some
See also

http://www.mvps.org/access

Function Split(ByVal Expression As String, Optional Delimiter = " ", _
Optional limit As Long = -1, Optional Compare As Integer = vbBinaryCompare _
) As Variant
'*******************************************
'Name: Split (Function)
'Purpose: Emulates the A2k/A2k2 Split function
'Author: Terry Kreft
'Date: December 13, 2001, 02:47:07
'Called by: Any
'Calls: None
'Inputs:
' Expression - The string to split
' Delimiter - The delimiter to split on
' limit - How many terms to return
' (Default -1 return all terms)
' Compare - How to make the string comparison
' for the delimiter
' This should be
' vbBinaryCompare = 0 (Default)
' vbTextCompare = 1
' vbDatabaseCompare = 2
'Output:
'*******************************************

Dim varValues As Variant
Dim lngCount As Long
Dim intInstr As Integer
Dim intLenDelim As Integer
Const ARRAY_LOW_BOUND = 0

On Error GoTo Split_err

varValues = Array()
If limit <> 0 Then
lngCount = 0
intLenDelim = Len(Delimiter)
intInstr = InStr(1, Expression, Delimiter, Compare)
Do While intInstr <> 0 And lngCount - limit + 1 <> 0
ReDim Preserve varValues(ARRAY_LOW_BOUND To lngCount)
varValues(lngCount) = Left(Expression, intInstr - 1)
Expression = Mid(Expression, intInstr + intLenDelim)
intInstr = InStr(1, Expression, Delimiter, Compare)
lngCount = lngCount + 1
Loop
If Len(Expression) <> 0 Then
ReDim Preserve varValues(ARRAY_LOW_BOUND To lngCount)
varValues(lngCount) = Expression
End If
End If
Split = varValues
Split_end:
Exit Function
Split_err:
With Err
MsgBox .Number & ": " & .Description, vbExclamation, .Source
End With
Resume Split_end
End Function

http://support.microsoft.com/default.aspx?scid=kb;en-us;188007

Option Explicit

Public Function Join(source() As String, Optional _
sDelim As String = " ") As String
Dim sOut As String, iC As Integer
On Error GoTo errh:
For iC = LBound(source) To UBound(source) - 1
sOut = sOut & source(iC) & sDelim
Next
sOut = sOut & source(iC)
Join = sOut
Exit Function
errh:
Err.Raise Err.Number
End Function

Public Function Split(ByVal sIn As String, Optional sDelim As _
String, Optional nLimit As Long = -1, Optional bCompare As _
VbCompareMethod = vbBinaryCompare) As Variant
Dim sRead As String, sOut() As String, nC As Integer
If sDelim = "" Then
Split = sIn
End If
sRead = ReadUntil(sIn, sDelim, bCompare)
Do
ReDim Preserve sOut(nC)
sOut(nC) = sRead
nC = nC + 1
If nLimit <> -1 And nC >= nLimit Then Exit Do
sRead = ReadUntil(sIn, sDelim)
Loop While sRead <> ""
ReDim Preserve sOut(nC)
sOut(nC) = sIn
Split = sOut
End Function

Public Function ReadUntil(ByRef sIn As String, _
sDelim As String, Optional bCompare As VbCompareMethod _
= vbBinaryCompare) As String
Dim nPos As String
nPos = InStr(1, sIn, sDelim, bCompare)
If nPos > 0 Then
ReadUntil = Left(sIn, nPos - 1)
sIn = Mid(sIn, nPos + Len(sDelim))
End If
End Function

Public Function StrReverse(ByVal sIn As String) As String
Dim nC As Integer, sOut As String
For nC = Len(sIn) To 1 Step -1
sOut = sOut & Mid(sIn, nC, 1)
Next
StrReverse = sOut
End Function

Public Function InStrRev(ByVal sIn As String, sFind As String, _
Optional nStart As Long = 1, Optional bCompare As _
VbCompareMethod = vbBinaryCompare) As Long
Dim nPos As Long
sIn = StrReverse(sIn)
sFind = StrReverse(sFind)
nPos = InStr(nStart, sIn, sFind, bCompare)
If nPos = 0 Then
InStrRev = 0
Else
InStrRev = Len(sIn) - nPos - Len(sFind) + 2
End If
End Function

Public Function Replace(sIn As String, sFind As String, _
sReplace As String, Optional nStart As Long = 1, _
Optional nCount As Long = -1, Optional bCompare As _
VbCompareMethod = vbBinaryCompare) As String

Dim nC As Long, nPos As Integer, sOut As String
sOut = sIn
nPos = InStr(nStart, sOut, sFind, bCompare)
If nPos = 0 Then GoTo EndFn:
Do
nC = nC + 1
sOut = Left(sOut, nPos - 1) & sReplace & _
Mid(sOut, nPos + Len(sFind))
If nCount <> -1 And nC >= nCount Then Exit Do
nPos = InStr(nStart, sOut, sFind, bCompare)
Loop While nPos > 0
EndFn:
Replace = sOut
End Function

 

[SiberBob]

copied the first code posting exactly and put it in a module all by itself. When I put
?ADOUserRoster "Y:\Databases\Dev Copy.mdb"
in the Immediate window I get:

Compile error:

Argument not optional

'OK' 'Help'

Any thoughts?

 

[SiberBob]

P.S. I am using Access 2000

 

[Saanich]

Oops that is an old comment when the routine was a subroutine now it is a function so parameter list should be in brackets
?ADOUserRoster ("C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb")

You can also get errors like this in Access if your subroutine has the same name as the entire saved module or the .mdb name