Force Front End Shut Down

[acm007]

Hi,

I am using Front End and Back End functionalities of Access. I am operating with 10 front ends (10 users). I want to be able to force a Front End shut down so I can make any updates needed on the back end.

I have followed all the instructions on the website below that list how to do it:

http://peterssoftware.com/fsd.htm

I have followed step-by-step and I believe I am very close to getting it resolved. I have been able to use a Macro to open the front end "force shutdown file" but instead of opening the screen that it is supposed to open, I get the following error (picture).

Here is my current code (I have only updated the fields that were told to be updated). Any help is really appreciated:

Option Compare Database
Option Explicit
'  frmFSDForceShutDown v1.2 for MS Access from Peter's Software
'    v2.0 Optionally use the existence of a file on disk as a shut down signal
'    v1.2 Shuts down reports as well as forms at shut down time.
'    v1.1 Contains a fix for a problem that caused the gintForceShutDown variable to never get set.
'
'  Copyright: Peter's Software 2001-2010 :: http://www.peterssoftware.com
'
'  Description:
'    A form that automatically shuts down all copies of a multi-user application when a value in a
'    table is set.
'
'  This module was created by:
'
'    Peter's Software
'    info@peterssoftware.com
'    http://www.peterssoftware.com
'
'  Special thanks to
'    Stefano Sarasso
'
'  This form and associated code are distributed as freeware
'
'  Usage
'
'    Import the form frmFSDForceShutDown into your application and open it hidden at application startup.
'
'    Distribute your new front-end to all end users.
'
'    To shut down all applications, create a file with a special name (see constant 'conShutDownFileName' below)
'    in the same folder as your linked data back-end.
'
'    Optionally include the basFSDOptionalModule to take advantage of a global variable that is set
'    to True when a Force Shut Down event occurs.
'
'    Remember to delete the file with the special name when you are done with maintenance activities
'    so users can get back into the application.
'




'* Set this constant to True if you want the FSD form to pop up in front of other
'* application windows when a Force Shut Down event occurs.
Const conPopUpISDFormForeground = True


'pddxxx v2
'* Set this constant to True if you want to use a file in the back-end folder to signal
'* a force shut down to occur
Const conUseFileNameInBackEndFolder = True
Const ACMShutDown = "ACMShutDown.txt"
Const Active_Cosmetics_Data3 = "tblCustomers"


Const conSeconndsPerMinute = 60
Dim intForceShutDownFormHasAppeared As Integer
'pddxxx v2
Dim mstrBackendFolderName As String
Private Const SW_RESTORE = 9
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
#If VBA7 Then
    Private Declare PtrSafe Function SetForegroundWindow& Lib "user32" (ByVal hwnd As LongPtr)
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
    Private Declare Function SetForegroundWindow& Lib "user32" (ByVal hwnd As Long)
    Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
Dim intDummy As Integer
Private Function ForceShutDown() As Integer
Dim Marker As Integer
Dim i As Integer
Dim Rtn As Integer
Dim strBackendDBName As String


On Error GoTo Err_Section
Marker = 1
Rtn = False


If conUseFileNameInBackEndFolder Then
    If mstrBackendFolderName = "" Then
        '* Find the back-end database folder by looking at connect string for known table
        strBackendDBName = CurrentDb().TableDefs(Active_Cosmetics_Data3).Connect
        strBackendDBName = xg_ReplaceAllWith(strBackendDBName, ";Database=", "")
        mstrBackendFolderName = xg_GetFolderFromFilename(strBackendDBName)
        If right(mstrBackendFolderName, 1) = "\" Then
        Else
            mstrBackendFolderName = mstrBackendFolderName & "\"
        End If
    Else
    End If
    If Dir(mstrBackendFolderName & ACMShutDown) = "" Then
        Rtn = False
    Else
        Rtn = True
    End If
Else
    '* Read the value from the table
    Rtn = DLookup("ForceShutDown", "tblFSDControl")
End If




Exit_Section:
    On Error Resume Next
    ForceShutDown = Rtn
    On Error GoTo 0
    Exit Function
Err_Section:
    Select Case Err
    Case 52
    Case Else
        Beep
        MsgBox "Error in ForceShutDown (" & Marker & "), object " & Err.Source & ": " & Err.Number & " - " & Err.Description
    End Select
    Err.Clear
    Resume Exit_Section
    
End Function




Private Function xg_CallIfPresent(pstrFunctionNameAndParms As String) As Integer
'* Call a function using the Eval function.
'* This method allows us to call a function whether it exists or not.
'*
'* Returns
'*   1 - Function found, executed, and returns True
'*   2 - Function found, executed, and returns False
'*   3 - Function not found
'*   99 - Other error


Dim intRtn As Integer


On Error Resume Next
If Eval(pstrFunctionNameAndParms) Then
    If Err <> 0 Then
        Select Case Err
        Case 2425, 2426
            intRtn = 3     '* The function is not found
        Case Else
            MsgBox "Error in xg_CallIfPresent when calling '" & pstrFunctionNameAndParms & "': " & Err.Number & " - " & Err.Description
            intRtn = 99     '* Other error
        End Select
        Err.Clear
    Else
        intRtn = 1  '* Function evaluates to True
    End If
Else
    intRtn = 2  '* Function evaluates to False
End If


Exit_Section:
    On Error Resume Next
    xg_CallIfPresent = intRtn
    On Error GoTo 0
    Exit Function
Err_Section:
    Beep
    MsgBox "Error in xg_CallIfPresent: " & Err.Number & " - " & Err.Description
    Err.Clear
    Resume Exit_Section


End Function
Private Function xg_ReplaceAllWith(sMainString As String, _
sSubString As String, sReplaceString As String) As String
'* Recursive function to replace all occurences of sSubString
'* with sReplaceString in sMainString
'*
'* In Access 2000 (and later versions) you can use the "Replace" function
'* instead of this one.
Dim i As Integer
Dim ipos As Integer
Dim s As String
Dim s1 As String, s2 As String


On Error Resume Next


s = sMainString
ipos = InStr(1, sMainString, sSubString)
If ipos = 0 Then
    GoTo Exit_xg_ReplaceAllWith
End If
s1 = Mid(sMainString, 1, ipos - 1)
s2 = Mid(sMainString, ipos + Len(sSubString), Len(sMainString))
s = s1 & sReplaceString & _
    xg_ReplaceAllWith(s2, sSubString, sReplaceString)


Exit_xg_ReplaceAllWith:
    On Error Resume Next
    xg_ReplaceAllWith = s
    On Error GoTo 0
End Function
Private Function xg_GetFolderFromFilename(pstrFilename As String) As String
Dim Marker As Integer
Dim strRtn As String
Dim i As Integer


On Error GoTo Err_Section
Marker = 1


strRtn = ""


For i = Len(pstrFilename) To 1 Step -1
    If Mid(pstrFilename, i, 1) = "\" Then
        Exit For
    End If
Next i


If i = 1 Then
    If Mid(pstrFilename, i, 1) = "\" Then
        strRtn = "\"
    Else
    End If
Else
    strRtn = Mid(pstrFilename, 1, i)
End If


Exit_Section:
    On Error Resume Next
    xg_GetFolderFromFilename = strRtn
    On Error GoTo 0
    Exit Function
Err_Section:
    Beep
    MsgBox "Error in xg_GetFolderFromFilename (" & Marker & "): " & Err.Number & " - " & Err.Description
    Err.Clear
    Resume Exit_Section


End Function










Private Sub btnCloseWarning_Click()
Me.Visible = False
End Sub


Private Sub Form_Open(Cancel As Integer)
Dim Marker As Integer
Dim strMsg As String


On Error GoTo Err_Section
Marker = 1


intForceShutDownFormHasAppeared = False


If ForceShutDown() Then
    strMsg = ""
    strMsg = strMsg & "WARNING:"
    strMsg = strMsg & vbCrLf & vbCrLf
    strMsg = strMsg & "This application is not currently available due to maintenance activity. "
    strMsg = strMsg & "Please try again when the maintenance activity is completed. "
    Me.TimerInterval = 5000
    Me!Label0.Caption = strMsg
    Me.Visible = True
Else
    Me.Visible = False
End If


Exit_Section:
    On Error Resume Next
    On Error GoTo 0
    Exit Sub
Err_Section:
    Beep
    MsgBox "Error in xg_GetFolderFromFilename (" & Marker & "): " & Err.Number & " - " & Err.Description
    Err.Clear
    Resume Exit_Section
    
End Sub


Private Sub Form_Timer()
'**********************************************************************
'* This timer event procedure will shut down the application
'* if a field value in a table is set to true.
'**********************************************************************
Dim sngElapsedTime As Single
Dim ctlNew As Control
Dim i As Integer
Dim ObjName(20) As String
Dim intForceShutDown As Integer
Dim frm As Form
Dim rpt As Report
Dim strBackendDBName As String


On Error Resume Next


'pddxxx v2
'intForceShutDown = DLookup("ForceShutDown", "tblFSDControl")
intForceShutDown = ForceShutDown()


If intForceShutDownFormHasAppeared And intForceShutDown Then
    '* Set global timeout variable, then shut down each form
    '* This code can be used if there is code in the form's BeforeUpdate,
    '* or OnClose event procedure that requires user input.
    '* The variable "gintForceShutDown" can be checked in the form events
    '* and can be used to prevent the user prompt code from executing.
    
    '* Set the global variable "gintForceShutDown" to True if the basFSDOptionalModule is included
    Select Case xg_CallIfPresent("fsd_SetForceShutDownVar(True)")
    Case 1, 2, 3, 99
        '* We'll accept the results regardless of the return code
    Case Else
    End Select
    
    '* Close all forms
    For i = 0 To 20
        ObjName(i) = ""
    Next i
    i = 0
    '* Find all open form names
    For Each frm In Forms
        If i > 20 Then
            Exit For
        End If
        If frm.Name = "frmFSDForceShutDown" Then
        Else
            ObjName(i) = frm.Name
            i = i + 1
        End If
    Next frm
    '* Now close them all
    For i = 0 To 20
        If ObjName(i) = "" Then
        Else
            DoCmd.Close acForm, ObjName(i), acSaveYes
        End If
    Next i
    
    '* Close all reports
    For i = 0 To 20
        ObjName(i) = ""
    Next i
    i = 0
    '* Find all open report names
    For Each rpt In Reports
        If i > 20 Then
            Exit For
        End If
        ObjName(i) = frm.Name
        i = i + 1
    Next rpt
    '* Now close them all
    For i = 0 To 20
        If ObjName(i) = "" Then
        Else
            DoCmd.Close acReport, ObjName(i), acSaveYes
        End If
    Next i
    
    '* Set the global variable "gintForceShutDown" to False if the basFSDOptionalModule is included
    Select Case xg_CallIfPresent("fsd_SetForceShutDownVar(False)")
    Case 1, 2, 3, 99
        '* We'll accept the results regardless of the return code
    Case Else
    End Select
    
    Set frm = Nothing
    Set rpt = Nothing
    
    DoCmd.Quit acQuitSaveAll
ElseIf intForceShutDownFormHasAppeared And Not intForceShutDown Then
    Me.Visible = False
    intForceShutDownFormHasAppeared = False
ElseIf Not intForceShutDownFormHasAppeared And intForceShutDown Then
    '* Make the warning form visible if it is not already visible.
    If Me.Visible Then
    Else
        Me.Visible = True
        
        If conPopUpISDFormForeground Then
            '* Un-minimize Access application if it is minimized
            If IsIconic(Application.hWndAccessApp) Then
                ShowWindow Application.hWndAccessApp, SW_RESTORE
            End If
            '* Make it the foreground window - open it in front of other application windows.
            SetForegroundWindow (Me.hwnd)
        End If
        
        '* Open it on top of other modal windows.
        SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
    End If
    intForceShutDownFormHasAppeared = True
ElseIf Not intForceShutDownFormHasAppeared And Not intForceShutDown Then
    '* Do nothing
End If


Exit_Section:
    On Error Resume Next
    On Error GoTo 0
End Sub

[ssanfu]

The error indicates that the table is not found in the BE.

Why are you changing constant names?

The original lines

Const conShutDownFileName = "ShutDownTheDemo.txt"
Const conExistingBackEndTableName = "tblCustomers"

You changed them to

Const ACMShutDown = "ACMShutDown.txt"
Const Active_Cosmetics_Data3 = "tblCustomers"

Do you have a table named "tblCustomers" in the BE?
What is "Active_Cosmetics_Data3"?

If you have a table name "Active_Cosmetics_Data3" in the BE, you should try using

Const conShutDownFileName = "ACMShutDown.txt"
Const conExistingBackEndTableName = "Active_Cosmetics_Data3"

Which means you will need to change these two lines back to the original lines:
FROM

            strBackendDBName = CurrentDb().TableDefs(Active_Cosmetics_Data3).Connect

        If Dir(mstrBackendFolderName & ACMShutDown) = "" Then

TO

            strBackendDBName = CurrentDb().TableDefs(conExistingBackEndTableName).Connect

        If Dir(mstrBackendFolderName & conShutDownFileName) = "" Then

The point being: Don't go changing program variable/constant names.
OK to change the VALUES assigned to those variables/constants

[acm007]

Thank you very much Ssanfu!!!! It corrected the error I had created. I am not too experienced with VBA so I changed the constant by mistake. Also, the "Active_Cosmetics_Data3" was the name of the actual database (back-end). I updated the code so it has the name of a table in the back end, not the name of the actual back end file itself. Thank you again!!