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_En
d_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_En
d_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
