How to Check if a database is open and close it if it is? (1 Viewer)

Shell "cmd /c " & Chr(34) & DB & Chr(34), vbHide

    If Right(CurrentProject.Name, 3) = "mdb" Then
        sBak = "_bak.mdb"
        iLeng = 4
    Else
        sBak = "_bak.accde"
        iLeng = 6
    End If

   g_strFilePath = CurrentProject.Path
   g_strCopyLocation = PutYOurGLobalMasterLocationInHere

   sBak = g_strFilePath & "\Previous_Version_" & CurrentProject.Name



    ' sets the file name and location for the file to delete
    strKillFile = g_strFilePath & "\" & CurrentProject.Name
    ' sets the file name and location for the file to copy
    strReplFile = g_strCopyLocation & "\" & CurrentProject.Name
    sOldBack = g_strCopyLocation & "\" & "Previous_Version_" & CurrentProject.Name
    ' sets the file name of the backup file to create
    strBackUp = strKillFile
    strBackUp = Left(strBackUp, (Len(strKillFile) - iLeng)) & sBak
    strTarget = Left(CurrentProject.Name, (Len(CurrentProject.Name) - iLeng)) & sBak
    'debug.print strBackUp
    ' sets the file name of the batch file to create
    TestFile = CurrentProject.Path & "\UpdateDbFE.cmd"
    ' sets the restart file name
    strRestart = """" & strKillFile & """"
    ' creates the batch file        -- The 9 after the ping -n is the delay for FS it needs to be this large
    Open TestFile For Output As #1
    Print #1, "Echo Off"
    Print #1, "ECHO Deleting old file"
    Print #1, ""
    Print #1, "if exist """ & strBackUp & """ del """ & strBackUp & """"
    Print #1, ""
    Print #1, "ECHO Copying backup file"
    Print #1, "Echo Off"
    Print #1, "ping -n 14 127.0.0.1 > nul"
    Print #1, ""
    Print #1, ":Fileready1"
    Print #1, "DEL """ & strKillFile & """ "
    Print #1, "ECHO Copying New file"
    Print #1, "Echo Off"
    Print #1, "Copy /Y """ & strReplFile & """ """ & strKillFile & """"
    Print #1, ""
    Print #1, ":checkfilecreation"
    Print #1, "REM Now that a .mov file has been added to the folder check to see if the file has "
    Print #1, "REM completed the conversion or copying to the folder before starting the app "
    Print #1, "Copy /Y """ & sOldBack & """ """ & sBak & """"
    Print #1, ""
    Print #1, "CLS"
    Print #1, ""
    Print #1, "for %%I in (""" & strKillFile & """) do ( (call ) >>%%I ) 2>nul && (cls && set b=%%I && @echo !b! is completed and transfer is ready && GOTO :fileready"
    Print #1, ") || (cls && echo %%I is still being created"
    Print #1, ")"
    Print #1, ""
    Print #1, ":ContinueCheck"
    Print #1, "REM Go back to checkfilecreation module"
    Print #1, "GOTO :checkfilecreation"
    Print #1, ""
    Print #1, ":Fileready"
    Print #1, "Echo CLICK ANY KEY TO RESTART THE ACCESS PROGRAM"
    Print #1, "START /I " & """MSAccess.exe"" " & strRestart
    Close #1

Shell TestFIle

Application.Quit

Public Sub CheckForNewVersion(Optional ForceUpdate As Boolean = False)
    
    Dim CurrentVersion As String
    Dim LatestVersion As String
    
    Dim Msg As String
    Dim Style As String
    Dim ttl As String
    Dim Response As Integer
    
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String
    Dim fltr As String
    
    Dim Updates As String
    Dim MoreUpdates As String
    Dim Counter As Integer
    Dim DB As String
    
    Const ShowThisNoOfUpdates = 3
    Dim App As String
    Dim index as Integer
    
    App = GetAppName
    CurrentVersion = GetVersion
    fltr = "Release=1 AND " & App & "=1"
    ttl = CurrentVersion
    
    LatestVersion = ELookup("Version", "tblVersion", "Version_ID=" & DMax("Version_ID", "tblVersion", fltr))
    If DCount("*", "tblVersion", fltr & " AND Version>'" & CurrentVersion & "' And ForceUpdate=1") Then
        ForceUpdate = True
    End If
    
    ' since update is changed to be an automatic precedure, the following option is deleted
' =========================================================================
    ' version check is fun from startup. so if user has set not to check for versions at start up
    ' and there's no force option exit sub
'    If fGetOption("User", "CheckForNewVersion", False) = True _
'            And ForceUpdate = False 
'        Exit Sub
'    End If
' =========================================================================
    
    If Not CurrentVersion = LatestVersion 
        Set cn = CurrentProject.Connection
        rs.CursorLocation = adUseClient
        
        fltr = "Version>'" & CurrentVersion & "' AND " & App & "=1 AND Release=1"
        sql = "SELECT * FROM tblVersion WHERE " & fltr & " AND Release=1 ORDER BY Version_ID ASC"
        rs.Open sql, cn, adOpenDynamic, adLockOptimistic
        
        With rs
            If .EOF Then
                Msg = "Current Version is the latest version."
                Style = vbOKOnly + vbInformation
                MsgBox Msg, Style, ttl
                Exit Sub
            End If

            Counter = 0
            Updates = ""
            MoreUpdates = ""
            Msg = ""
            
            Msg = Msg & "Current Version：" & CurrentVersion
            Msg = Msg & vbCrLf & vbCrLf
            Msg = Msg & "A new version(" & LatestVersion & ") is available. "
            Msg = Msg & "Clicking OK button bellow will update your copy."
            Msg = Msg & "Changes and Updates are as following："
            Msg = Msg & vbCrLf
            
            Do
                Counter = Counter + 1
                If Counter <= ShowThisNoOfUpdates Then
                    Updates = Updates & "● " & !Updates
                    Updates = Updates & vbCrLf
                    
                Else
                    MoreUpdates = MoreUpdates & "● " & !Updates
                    MoreUpdates = MoreUpdates & vbCrLf

                End If
                
                .MoveNext
            Loop Until .EOF
        End With
        
' *****************************************************************************
' *****************************************************************************
        If DCount("Version", "tblVersion", "ForceUpdate=1 AND Release=1 AND " & App & "=1") > 0 Then
            Msg = Msg & Updates & "and several more changes."
            Style = vbOKOnly + vbInformation
            MsgBox Msg, Style, ttl  
        End If

            Msg = vbCrLf & vbCrLf
            Msg = Msg & "A complete list of changes and updates：" & vbCrLf & vbCrLf
            Msg = Msg & Updates & MoreUpdates
            CreateTextFile "temp", Msg
    
        DB = CurrentProject.Path & "\UpdateReceiption.accdb"
            If fFolderExists(DB) = False Then
                FormattedMsgBox "Update file not found.", "Contact your admin to update."
                Application.Quit
                End
            End If

            Shell "cmd /c " & Chr(34) & DB & Chr(34), vbHide
            WaitSeconds (3)
            DoCmd.Quit

End Sub

 DB = CurrentProject.Path & "\UpdateReceiption.accdb"