Private Sub Form_Timer()
AddToLog "LOGGED_ON" ' add event to log
DoCmd.OpenForm "Next_Form_Name" ' open next form
DoCmd.Close acForm, Me.Name
End SubPublic Sub AddToLog(ByRef logType As String)
Dim cnn As ADODB.Connection
Dim sysLog As ADODB.Recordset
Dim c As New cComputer
On Error Resume Next
Set cnn = CurrentProject.Connection ' set up database connection
Set sysLog = New ADODB.Recordset ' open the recordset
sysLog.Open "sysLog", cnn, adOpenForwardOnly, adLockOptimistic, adCmdTable
With sysLog
' add new record and values
.AddNew
.Fields(0) = Now()
.Fields(1) = c.Name ' computer name
.Fields(2) = c.UserName ' NT user named
.Fields(3) = logType ' as passed, string field
.Update ' update the record and close
.Close
End With
End SubOption Compare Database
Option Explicit
Private Declare Function WNetGetUser _
Lib "mpr.dll" Alias "WNetGetUserA" _
(ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Private Declare Function GetComputerName _
Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Property Get Name() As String
Name = GetName
End Property
Property Get UserName() As String
UserName = GetUserName
End Property
Private Function GetName() As String
' Function to return computer name
Dim returnValue As Long
Dim bufferSize As Long
Dim buffer As String
' Make the buffer big enough for the name plus a vbNullChar
bufferSize = 16
buffer = String$(bufferSize, vbNullChar)
returnValue = GetComputerName(buffer, bufferSize) ' call API
' if we've got the name then return as string
If CBool(returnValue) Then
GetName = Left(buffer, bufferSize)
End If
End Function
Private Function GetUserName() As String
' function to return user name
Dim nameLength As Long
Dim UserName As String
Dim returnValue As Long
Do ' no more data
UserName = String$(nameLength, vbNullChar)
returnValue = WNetGetUser(vbNullString, UserName, nameLength) ' call API
Loop Until returnValue <> 234
If returnValue = 0 Then
GetUserName = TrimNull(UserName)
End If
End Function
Private Function TrimNull(ByVal dodgyString As String) As String
Dim pos As Integer
pos = InStr(dodgyString, vbNullChar)
If pos > 1 Then
TrimNull = Left$(dodgyString, pos - 1)
Else
TrimNull = dodgyString
End If
End FunctionSub testEnviron()
Dim i As Integer
on error resume next ' cheat
For i = 1 To 100
If Len(Environ$(i)) > 0 Then Debug.Print i & " : " &Environ$(i)
Next i
End Sub
Public Sub Whois()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
Dim myDB As String
myDB = InputBox("Please enter the full path of a database", "Select Database")
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=" & myDB
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & myDB
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, "", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
rs.MoveNext
Wend
End Sub