How to create a user table recording Windows logon

Posted on 2006-05-18
Medium Priority
Last Modified: 2008-06-16
I'd like to create a table with a list of users giving their Windows domain logons plus the time of their logon.

When a user logs on their logon name should go into the table as well as their machine name.  Also a flag should be set to Yes to show they are logged in.  When they exit the database the flag should be set to No (to enable checking if anyone exits and leaves the database in a suspect state), and the logoff time recorded.

Question by:looper8
  • 6
  • 3
  • 2
LVL 65

Expert Comment

ID: 16710369
ok, the initiial form that u use or perhaps a AutoExec macro

call this bit of code

dim sUser as String

sUser = Environ("Username")

sSql = "INSERT INTO tblLogon (UserName, LoggedOnDate) VALUES ('" & sUser & "','" & Now() & "')"

DoCmd.RunSql sSql

LVL 65

Expert Comment

ID: 16710389
ok, forgot the flag

sSql = "INSERT INTO tblLogon (UserName, LoggedOnDate, LogOnFlag) VALUES ('" & sUser & "','" & Now() & "','Y')"

then all u need to do when they logoff (put in form_close of the last form thats used - ideally your main menu or something)

sSql = "INSERT INTO tblLogon (UserName, LoggedOnDate, LogOnFlag) VALUES ('" & sUser & "','" & Now() & "','N')"

LVL 38

Expert Comment

by:Jim P.
ID: 16710397
Add the function below into your database then on whatever form you have open add the command
docmd.setwarnings false
Docmd.runsql "Insert into LoginHistoryTable (Users_Name, Login_Time) " & _
                    " Values( '" & GetUsersName() &"' , #" & Now() & "#)"
docmd.setwarnings true

Option Compare Database
Option Explicit

'From http://support.microsoft.com/default.aspx?scid=kb;en-us;161394
 ' Declare for call to mpr.dll.
   Declare Function WNetGetUser Lib "mpr.dll" _
      Alias "WNetGetUserA" (ByVal lpName As String, _
      ByVal lpUsersName As String, lpnLength As Long) As Long

   Const NoError = 0       'The Function call was successful

Public Function GetUsersName() As String

      ' Buffer size for the return string.
      Const lpnLength As Integer = 255

      ' Get return buffer space.
      Dim Status As Integer

      ' For getting user information.
      Dim lpName, lpUsersName As String

      ' Assign the buffer size constant to lpUsersName.
      lpUsersName = Space$(lpnLength + 1)

      ' Get the log-on name of the person using product.
      Status = WNetGetUser(lpName, lpUsersName, lpnLength)

      ' See whether error occurred.
      If Status = NoError Then
         ' This line removes the null character. Strings in C are null-
         ' terminated. Strings in Visual Basic are not null-terminated.
         ' The null character must be removed from the C strings to be used
         ' cleanly in Visual Basic.
         lpUsersName = Left$(lpUsersName, InStr(lpUsersName, Chr(0)) - 1)

         ' An error occurred.
         MsgBox "Unable to get the name."
      End If

      ' Display the name of the person logged on to the machine.
'      MsgBox "The person logged on this machine is: " & lpUsersName
    GetUsersName = lpUsersName
End Function
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

LVL 65

Expert Comment

ID: 16710419
Im not aware of any auto close macros like there is AutoExec (called when DB starts)
I think Word has one but not ms access
LVL 65

Expert Comment

ID: 16710435
Environ is one option, there is another which Ive just found the link to

LVL 65

Expert Comment

ID: 16710461
and the other bit of info I was going to provide, do u want to store their IP address as well? if so, that is also easily achieved.

Option Explicit

Private Const IP_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Long
    wMaxUDPDG As Long
    dwVendorInfo As Long
End Type
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
                                       (ByVal hostname As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
                               Alias "RtlMoveMemory" _
                               (xDest As Any, _
                                xSource As Any, _
                                ByVal nbytes As Long)
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
                                    (ByVal wVersionRequired As Long, _
                                     lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
                                   (ByVal s As String) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
                                         (ByVal Buffer As String, _
                                          Size As Long) As Long

Public Function GetIPFromHostName(ByVal sHostName As String) As String
'converts a host name to an IP address.
    Dim nbytes As Long
    Dim ptrHosent As Long  'address of hostent structure
    Dim ptrName As Long    'address of name pointer
    Dim ptrAddress As Long    'address of address pointer
    Dim ptrIPAddress As Long
    Dim sAddress As String
    sAddress = Space$(4)
    ptrHosent = gethostbyname(sHostName & vbNullChar)
    If ptrHosent <> 0 Then
        ptrName = ptrHosent
        ptrAddress = ptrHosent + 12
        'get the IP address
        CopyMemory ptrName, ByVal ptrName, 4
        CopyMemory ptrAddress, ByVal ptrAddress, 4
        CopyMemory ptrIPAddress, ByVal ptrAddress, 4
        CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
        GetIPFromHostName = IPToText(sAddress)
    End If
End Function

Private Function IPToText(ByVal IPAddress As String) As String
    IPToText = CStr(Asc(IPAddress)) & "." & _
               CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
               CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
               CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function

Public Sub SocketsCleanup()
    If WSACleanup() <> 0 Then
        MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
    End If
End Sub

Public Function SocketsInitialize() As Boolean
    SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function

then to get the info,

Sub TestingFunction()
    Dim sHost as String

    If SocketsInitialize() Then
        sHost = GetPcName
        MsgBox sHost & vbcrlf & GetIPFromHostName(sHost)
    End If
End Sub

Author Comment

ID: 16716776
Thanks guys.  I'll test this out this afternoon and let you know.

But a question ... if you can use Environ("UserName") why would you go the the trouble of writing a whole sub to get the logon?  Are there drawbacks to Environ?

Author Comment

ID: 16716929
OK, rockiroads ... I had to replace your Y and N with -1 and 0 but then it worked fine.

Tried the IP function, but can't get it to work.  Pasted the main code into a new module, the other code into another module and ran testingfunction in the Immediate Window ... but GetPcName doesn't seem to exist!
LVL 38

Expert Comment

by:Jim P.
ID: 16717330
>>  if you can use Environ("UserName") why would

It is fairly easy to spoof the  Environ("UserName") variable
LVL 65

Accepted Solution

rockiroads earned 2000 total points
ID: 16719742
Sorry,. forgot one method to post

Public Function GetPcName() As String
    Dim strBuf As String * 16, strPcName As String, lngPc As Long
    lngPc = GetComputerName(strBuf, Len(strBuf))
    If lngPc <> 0 Then
        strPcName = Left(strBuf, InStr(strBuf, vbNullChar) - 1)
        GetPcName = strPcName
        GetPcName = vbNullString
    End If
End Function

Environ uses environment variables. It was just one method of getting it.
I prefer the use of API, like jimpen as shown and that link I gave u - points to this
http://www.mvps.org/access/api/api0008.htm (use of api)

I would recommend u use the API call. The one in my link isnt that big - here is the code

Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
    "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
    strUserName = String$(254, 0)
    lngLen = 255
    lngX = apiGetUserName(strUserName, lngLen)
    If ( lngX > 0 ) Then
        fOSUserName = Left$(strUserName, lngLen - 1)
        fOSUserName = vbNullString
    End If
End Function


Author Comment

ID: 16733035
The whole thing works very well: I'm recording the user's logon (via the API call), IP address, PC name, time of database open/close.  The API stuff is rather over my head [:-), but hey it works!  Thanks very much esp rockiroads for your help.

Featured Post


Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Access is a place to store data within tables and represent this stored data using multiple database objects such as in form of macros, forms, reports, etc. After a MS Access database is created there is need to improve the performance and…
Windows Explorer let you handle zip folders nearly as any other folder: Copy, move, change, and delete, etc. In VBA you can also handle normal files and folders, but zip folders takes a little more - and that you'll find here.
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.
Suggested Courses

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question