VBA - Update Access Application Closes/Re-Opens New File

 
' Update ONE to the next version.

' Script Version 5/31/2006 


Dim WSHShell
Dim appAccess 				' Current Access application window
Dim fso 				' FileSystem object used to access files
Dim DesktopPath 			' Desktop folder, where shortcut is placed

const iButtonTypeOK = 0			' Popup controls
const iIconTypeStopMark = 16
const iIconTypeQuestionMark = 32
const iIconTypeExclamationMark = 48
const iIconTypeInformationMark = 64
dim intButton 
const iOKButtonClicked = 1
const iButtonsNotClicked = -1

const strONEfilename = "c:\program files\oicwcms\one"
const strONEfolder = "\\db1\one"

<font color="Red">Set WSHShell = WScript.CreateObject("WScript.Shell")</font>
DesktopPath = WSHShell.SpecialFolders("Desktop")
<font color="Red">Set fso = createobject("Scripting.FilesystemObject")</font>


' Warn the user that updating is about to occur.
' (A 10 second delay is added.  With a slow network connection, somehow this 
' helps to avoid the automatic update from being launched a second time.)

While intButton <> iButtonsNotClicked 

intButton = WSHShell.Popup( "W A I T !  Don't click the button!" & vbCrLf  & vbCrLf & "ONE is about to be automatically updated.  Please wait while the new version is loaded--then you will see another alert dialog.",10,"Automatic Update of ONE",iButtonTypeOK + iIconTypeStopMark )

Wend


' <font color="Red">First stop the current Access program</font>, then copy files from the 
' ONE folder to the C: drive, <font color="Red">then launch the new program in the same
' application window</font>.

on error resume next
' Detect if ONE is running (from the proper folder) by an indirect method:
' If the LDB file cannot be deleted then the MDB file is probably opened.
' Trap the error accordingly.
fso.DeleteFile strONEfilename & ".ldb" 

if Err.Number = 70 then 
    ' LDB file cannot be deleted, so ONE is running as expected.
    on error goto 0

    ' <font color="Red">Close down the instance that called this script</font>
    Set appAccess = Wscript.getObject(strONEfilename & ".mdb")
    appAccess.CloseCurrentDatabase 

    ' Update ONE
    on error resume next
    fso.CopyFile strONEfolder & "\one.mdb", strONEfilename & ".mdb"
    fso.CopyFile strONEfolder & "\one.hlp", strONEfilename & ".hlp"
    fso.CopyFile strONEfolder & "\one.lnk", DesktopPath & "\one.lnk"

    if Err.Number = 0 then

        ' Announce that ONE has been successfully updated

        WSHShell.Popup "Your ONE program has been updated." & vbCrLf & vbCrLf & "Click the button to launch ONE.",0,"Automatic Update of ONE",iButtonTypeOK + iIconTypeInformationMark 

        ' <font color="Red">Launch the updated program in the same Access window</font>

        appAccess.Opencurrentdatabase strONEfilename & ".mdb"

        ' Done !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!    !!!!

    elseif Err.Number = 76 then

        ' The ONE file server folder is not available.
        ' Leave Access open with no program running.

        WSHShell.Popup "The copy script cannot update your program, probably due to an intermittent network problem; it failed with error " & err.number & ": " & err.description & "  !!!",0,"Automatic Update Failure", iButtonTypeOK + iIconTypeInformationMark

        ' Done !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!    !!!!

    else

        ' Unexpected error

        WSHShell.Popup "The copy script failed with error " & err.number & ": " & err.description & "  !!!  Please report this error and do not continue using the program !!!",0,"Automatic Update Failure", iButtonTypeOK + iIconTypeExclamationMark 

        ' Done !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!    !!!!

    end if

else

    'Perhaps the script was launched in another way, 
    'or the user has already closed ONE.

    WSHShell.Popup "The copy script failed with error " & err.number & ": " & err.description & "  !!!  If this happens again then please report this error and do not continue using the program !!!",0,"Automatic Update Failure", iButtonTypeOK + iIconTypeExclamationMark 

end if  

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub Test()
'Open file
ShellExecute 0, "Open", "H:\reload.vbs", "", "", 1
End Sub