Donald, here is the code plus some instruction. If you need further elaboration
don't hesitate to post it here. Please note, in posting this I may have misplaced a
comment (') or a line-continuation character so you might want to review the
2 code modules I first pasted in and then edited to make fit.
First you'll have to do the following in your MS Access
database:
1. Create a table with one column defined as Number, type is Byte.
Mine is called tbl86.
2. Create a form. Mine is called fo86. Set the timer interval
to 120000 (2 minutes) or whatever you desire. Set the On_current
event to Forms!fo86.Visible = False. Set the On Timer event to
run sGetOut, a sub that resides in Modules.
3. Create an AutoExec macro to open the fo86 and set the window mode
in the macro to Hidden. This will cause the form and its timer to
always be running but not visible to the users.
4. Put the following code (sGetOut) in a module. This is the sub that checks to
see if you've put a '2' in the GetOut column of tbl86. This module
also calls the user-warning VB program in number 5.
See the notes in the code. You'll have to create this sGetOut
procedure as a Sub. Note all the code you see BEFORE sGetOut is present to
insure that programs called by the ExecCmd run asynchronously of the Access code
that called it.
Option Compare Database
Option Explicit
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Public Sub ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret&
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
' Wait for the shelled application to finish:
Do
ret& = WaitForSingleObject(proc.hProcess, 0)
DoEvents
Loop Until ret& <> 258
ret& = CloseHandle(proc.hProcess)
End Sub
Public Sub sGetOut()
Dim RS As Recordset, ret As Byte
' If you manually put a 2 in getout column of tbl86 they'll get a 2-minute warning.
' Also, a '1' will be inserted. The next time the timer passes 2 minutes, the
' application will shutdown, saving all data.
ret = DLookup("[getout]", "tbl86"
If ret = 2 Then
' (Donald, the line below is the network drive where I installed the WarnUser ' program)
ExecCmd "G:\WarnUsers\WarnUsers.exe"
Set RS = CurrentDb.OpenRecordset("tbl86", dbOpenTable)
On Error Resume Next
RS.Edit
RS![GetOut] = 1
RS.Update
RS.Close
Set RS = Nothing
Exit Sub
End If
If ret = 1 Then
Set RS = CurrentDb.OpenRecordset("tbl86", dbOpenTable)
On Error Resume Next
RS.Edit
RS![GetOut] = 3
RS.Update
RS.Close
Set RS = Nothing
DoCmd.Close acForm, "fo86"
Application.Quit 'shut down the applicantion with no data lost
End If
End Sub
5. This is the code to the excutable that warns the users. Written
in VB6 & placed in a separate folder on the network, you could put it most
anyplace you wish, however :
Private Sub Form_Load()
WarnMultipleUsers
End Sub
' Send a shutdown warning to current users of ' F:\YourNetworkFolder\YourAccessDB.mdb
' Your VB form must reference MS ActiveX Data Objects 2.x Library
' The user list feature provides a way of determining who is currently connected to a
' Microsoft Jet database. The list can be obtained via the ADO programming interface
' and returns the Name of the computer that the user is using.
' I then send a shutdown warning to these computer names via Net Send.
Sub WarnMultipleUsers()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
Dim retval
Dim Shellstr As String, sComputerName As String, sEdComputerName As String
Dim msg$
Dim EndPos As Byte
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=F:\YourNetworkFolder\YourAccessDB.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0; _
" Data Source=F:\YourNetworkFolder\YourAccess.MDB"
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
msg$ = " The Access DB will shutdown for maintenance in exactly 2 _ "
" minutes. Please X-out now."
While Not rs.EOF
sComputerName = rs.Fields(0)
EndPos = InStr(1, sComputerName, " ", 0)
sEdComputerName = Left(sComputerName, (EndPos - 2)) ' do this
' because name is followed by a non-ascii character
Shellstr = "net send " & sEdComputerName & " " & msg$
retval = Shell(Shellstr, vbHide) ' DOS Window (cmd prompt) is
' hidden and focus is passed to it
rs.MoveNext
Wend
End
End Sub