Database Update

Option Compare Database
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Const ERROR_SUCCESS As Long = 0
Public Const CSIDL_DESKTOP As Long = &H0
Public Const CSIDL_PROGRAMS As Long = &H2
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10

Public Const FO_COPY As Long = &H2
Public Const FOF_SILENT As Long = &H4
Public Const FOF_RENAMEONCOLLISION As Long = &H8
Public Const FOF_NOCONFIRMATION As Long = &H10

Public Type SHFILEOPSTRUCT
  hwnd      As Long
  wFunc      As Long
  pFrom      As String
  pTo        As String
  fFlags     As Integer
  fAborted   As Boolean
  hNameMaps  As Long
  sProgress  As String
End Type


Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type


Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHFileOperation Lib "Shell32" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Dim appAccess As Access.Application, BlankHolder

Public Function CompareVersion()
On Error GoTo Err_CompareVersion

Select Case GetMasterVersion
    Case GetCurrentVersion
    Case Else: CopySwap
End Select

Exit_CompareVersion:
    Exit Function
    
Err_CompareVersion:
    errMessage Err
    Resume Exit_CompareVersion

End Function

Public Function GetMasterVersion() As String
    Dim wrkJet As Workspace
    Dim dbs As DAO.Database, cnt As Container
    Dim doc As Document, prp As Property

    ' Property not found error.
    Const conPropertyNotFound = 3270
    On Error GoTo GetSummary_Err
    
    Set wrkJet = CreateWorkspace("", "User", "")
    Set dbs = wrkJet.OpenDatabase("\\PW\engineering\wpdata\reports\Databases\Front_End_Databases\Template.mdb")
    Set doc = dbs.Containers("Databases")!UserDefined
        GetMasterVersion = doc.Properties("MasterVersion")
        dbs.Close
        wrkJet.Close
    Set doc = Nothing
    Set dbs = Nothing

GetSummary_Bye:
    Exit Function

GetSummary_Err:
    If Err = conPropertyNotFound Then
            MsgBox "There is no Master Version number assigned."
        Resume
    Else
        ' Unknown error.
        MsgBox Err.Description
        Resume GetSummary_Bye
    End If
End Function

Public Function GetCurrentVersion() As String
    Dim dbs As DAO.Database, cnt As Container, GetTemplateLocation As String
    Dim doc1 As Document, doc2 As Document, prp As Property
    
    ' Property not found error.
    Const conPropertyNotFound = 3270
    On Error GoTo GetSummary_Err
    
    Set dbs = CurrentDb
    Set cnt = dbs.Containers!Databases
    Set doc1 = cnt.Documents!UserDefined
    doc1.Properties.Refresh
    GetCurrentVersion = doc1.Properties("MasterVersion")

GetSummary_Bye:
    Exit Function

GetSummary_Err:
    If Err = conPropertyNotFound Then
            MsgBox "There is no Replica Version number assigned."
        Resume
    Else
        ' Unknown error.
        Resume GetSummary_Bye
    End If
End Function

Public Function CopySwap()
Dim fs
On Error GoTo Err_CopySwap

'   Create a target that points to where the new version should go.
'   TrgtLoc = "C:\WINNT\Profiles\" & GetNTUser & "\Desktop\ProjectStatus.mdb"
'   Start up the COPY FUNCTION.
    Set fs = CreateObject("Scripting.FileSystemObject")
'   Get the original Template and copy it to where new versions go. (True means to overwrite if a copy exists.)
    fs.CopyFile "\\PW\engineering\wpdata\reports\Databases\Front_End_Databases\Template.mdb", TNmLoc, True
'   Start up the OPEN DATABASE FUNCTION.
    Set appAccess = CreateObject("Access.Application")
'   Open the new database that was just copied from the Template.
    appAccess.OpenCurrentDatabase TNmLoc, False
'   Close the old version of the database.
    DoCmd.Quit acQuitSaveNone

Exit_CopySwap:
    Call CompareVersion
    Exit Function

Err_CopySwap:
    MsgBox Err.Description
    Resume Exit_CopySwap

End Function

Public Sub CreateDesktopLink(sSource As String, sDestination As String)
'working variables
Dim sFiles As String, SHFileOp As SHFILEOPSTRUCT

'terminate passed strings with a null
sSource = sSource & Chr$(0)
sDestination = sDestination & Chr$(0)

'set up the options
With SHFileOp
    .wFunc = FO_COPY
    .pFrom = sSource
    .pTo = sDestination
    .fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
End With

'and perform the copy
Call SHFileOperation(SHFileOp)
  
End Sub


Public Function GetSpecialFolder(hwnd As Long, CSIDL As Long) As String
Dim pidl As Long, pos As Long, sPath As String

'fill the pidl with the specified folder item
If SHGetSpecialFolderLocation(hwnd, CSIDL, pidl) = ERROR_SUCCESS Then
'initialize & get the path
    sPath = Space$(260)
    If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then
        'has a null?
        pos = InStr(sPath, Chr$(0))
        'strip it
        If pos Then
            'return folder
            GetSpecialFolder = Left$(sPath, pos - 1)
        End If
    End If
End If
Call CoTaskMemFree(pidl)
End Function

Public Function TNmLoc() As String
On Error GoTo Err_TNmLoc

Dim DskTp As String, DbNm As String
DskTp = GetSpecialFolder(0&, CSIDL_DESKTOPDIRECTORY)
DbNm = "\Midwest Customer Application.mdb"

TNmLoc = DskTp & DbNm

Exit_TNmLoc:
Exit Function

Err_TNmLoc:
MsgBox Err.Description
Resume Exit_TNmLoc

End Function

Public Function GetNTUser() As String
On Error GoTo Err_GetNTUser
'Returns the network login name
Dim strUserName As String
'Create a buffer
strUserName = String(100, Chr$(0))
'Get user name
GetUserName strUserName, 100
'Strip the rest of the buffer
strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
GetNTUser = LCase(strUserName)

Exit_GetNtUser:
Exit Function

Err_GetNTUser:
MsgBox Err.Description
Resume Exit_GetNtUser

' SAMPLE USAGE:
' Me!<insert field name here> = GetNTUser

End Function