'********************************************
'* Called from my startup routine to see if *
'* the database if up to the code level, *
'* and bring it to that level if necessary. *
'********************************************
Sub MakeUpToDate()
Dim DETAILS As DAO.Recordset, PROJNAMES As DAO.Recordset, _
PREFERENCES As DAO.Recordset
Dim strtest As String, prefv As String
Dim NF As Integer
NF = 0: On Error GoTo NoField
Set PREFERENCES = CurrentDb.OpenRecordset("Preferences")
prefv = PREFERENCES.Fields("Version")
On Error GoTo 0
PREFERENCES.Close: Set PREFERENCES = Nothing
' before version 1.1a the version field of PREFERENCES did not
' exist, so must be inferred from existance of other database
' fields.
' 1.0a is the designation for the first version in users hands. it
' lacked the PROJECT-REAL-BUDGET-CODE field of the PROJNAMES table
' 1.0b was the only other version in user hands that did not have
' the version field in PREFERENCES. It is recognized by having the
' above field 1.0a lacked, but not having the OLD-PROJ field of
' the DETAIL table.
' 1.1a has both the above fields and has the Version field of the
' PREFERENCES table. From 1.1a onward the contents of this field
' is supposed to be authoratative...
If NF = 3021 Then ' 1.1a or better, but version not given (fatal)
MsgBox "Unable to determine version of this database, " & vbCrLf & _
"even though 'version' is present!" & vbCrLf & _
"Possibly empty Preferences table?" & vbCrLf & _
"Please call support and report this problem.", vbCritical
Application.Quit
End If
If NF = 3265 Then ' version does not exist yet...
' check for PROJECT-REAL-BUDGET-CODE field added after 1.0a...
Set PROJNAMES = CurrentDb.OpenRecordset("Project Names")
NF = 0: On Error GoTo NoField
strtest = PROJNAMES.Fields("PROJECT-REAL-BUDGET-CODE")
On Error GoTo 0
PROJNAMES.Close: Set PROJNAMES = Nothing
If NF = 3265 Then
prefv = "1.0a"
Else
' check for OLD-PROJ field added after 1.0b...
Set DETAILS = CurrentDb.OpenRecordset("DETAIL")
NF = 0: On Error GoTo NoField
strtest = DETAILS.Fields("OLD-PROJ")
On Error GoTo 0
DETAILS.Close: Set DETAILS = Nothing
If NF = 3265 Then
prefv = "1.0b"
Else
' death - failed to find valid version...
MsgBox "Unable to determine version of this database, " & vbCrLf & _
"Please call support and report this problem.", vbCritical
Application.Quit
End If
End If
End If
' having determined the database version update if necessary...
' go from 1.0a to 1.b
If prefv = "1.0a" Then
DoUpdate10ato10b
prefv = "1.0b"
End If
' go from 1.0b to 1.1a
If prefv = "1.0b" Then
DoUpdate10bto11a
' update to version 1.1a added verion field, now fill it in...
NF = 0: On Error GoTo NoField
Set PREFERENCES = CurrentDb.OpenRecordset("Preferences")
PREFERENCES.MoveFirst
On Error GoTo 0
' No field system should have an empty PREFERENCES table,
' but it showed up in testing, so may as well try to handle it...
If NF = 0 Then PREFERENCES.Edit Else PREFERENCES.AddNew
PREFERENCES.Fields("Version") = "1.1a"
PREFERENCES.Update
PREFERENCES.Close: Set PREFERENCES = Nothing
prefv = "1.1a"
End If
' as a result of our efforts database should be 1.1a. if not
' something is terribly wrong - probably the database is past
' 1.1a and it's this code that is now obsolete, so IT should die...
If prefv <> "1.1a" Then
' death - unidentified version...
MsgBox "Version " & prefv & " of database is not known!" & vbCrLf & _
"Please call support and report this problem.", vbCritical
Application.Quit
End If
Exit Sub
NoField:
NF = Err
If NF = 3078 Then ' cant find table (fatal)!
MsgBox "Preferences table not found" & vbCrLf & _
"Please review the upgrade instuctions and LINK" & vbCrLf & _
" to the tables in the old database" & vbCrLf & _
"If that doesn't work" & vbCrLf & _
"Please call support and report this problem.", vbCritical
Application.Quit
End If
If NF = 3021 Then ' no current record (so field DOES exist)
Resume Next
End If
If NF = 3265 Then ' cant find field
Resume Next
End If
On Error GoTo 0
Resume
End Sub
'******************************************
'* UpgradeDB subroutine generated by *
'* Compare'EM *
'****************************************** OLD
'* C:\Documents and Settings\mike.LIANLI\ *
'* Desktop\mics\bkups\mics14\mics14.mdb *
'****************************************** NEW
'* C:\Documents and Settings\mike.LIANLI\ *
'* Desktop\mics\bkups\mics14b\mics.mdb *
'******************************************
'* Compare'EM version 0.4 *
'* Copyright © 2005, Mike Noel *
'******************************************
'Private Sub UpgradeDB()
Private Sub DoUpdate10ato10b()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim idx As DAO.Index
Dim rel As DAO.Relation
Dim Ret As String, LinkedDBName As String
'Set db = CurrentDb
Ret = CurrentDb.TableDefs("DETAIL").Connect
LinkedDBName = Right(Ret, Len(Ret) - (InStr(1, Ret, "DATABASE=") + 8))
Set db = DBEngine.Workspaces(0).OpenDatabase(LinkedDBName)
'
'********************************************
' Create new field PROJECT-REAL-BUDGET-CODE of table Project Names
Set tdf = db.TableDefs("Project Names")
Set fld = tdf.CreateField("PROJECT-REAL-BUDGET-CODE", dbText, 20)
SetPro fld, "Attributes", dbLong, 2
tdf.Fields.Append fld
SetPro fld, "Description", dbText, "real budget code associated with project"
SetPro fld, "AllowZeroLength", dbBoolean, True
SetPro fld, "DefaultValue", dbText, ""
SetPro fld, "OrdinalPosition", dbLong, 2
SetPro fld, "Required", dbBoolean, False
' change field ImportPause of table Preferences
Set fld = db.TableDefs("Preferences").Fields("ImportPause")
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "DefaultValue", dbText, "Yes"
SetPro fld, "Required", dbBoolean, False
' change field FTP other files also of table Preferences
Set fld = db.TableDefs("Preferences").Fields("FTP other files also")
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "DefaultValue", dbText, "Yes"
SetPro fld, "Required", dbBoolean, False
' create index PROJECT-REAL-BUDGET-CODE of table Project Names
'Set tdf = db.TableDefs("Project Names")
'Set idx = tdf.CreateIndex("PROJECT-REAL-BUDGET-CODE")
'Set fld = idx.CreateField("PROJECT-REAL-BUDGET-CODE")
'idx.Fields.Append fld
'tdf.Indexes.Append idx
End Sub
'******************************************
'* UpgradeDB subroutine generated by *
'* Compare'EM on 3/21/2005 *
'****************************************** OLD
'* C:\Documents and Settings\mike.LIANLI\ *
'* Desktop\mics\bkups\mics14b\mics.mdb *
'****************************************** NEW
'* C:\Documents and Settings\mike.LIANLI\ *
'* Desktop\mics\mics.mdb *
'******************************************
'* Compare'EM version 0.5b *
'* Copyright © 2005, Mike Noel *
'******************************************
'Private Sub UpgradeDB()
Private Sub DoUpdate10bto11a()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim idx As DAO.Index
Dim rel As DAO.Relation
Dim Ret As String, LinkedDBName As String
'********************************************
' GIVE SERIOUS THOUGHT! - is next line OK ??
' 'db' defines the database to which changes
' will be applied. Do you really want that
' to be the same as the one where this code
' will run??
'
'Set db = CurrentDb
Ret = CurrentDb.TableDefs("DETAIL").Connect
LinkedDBName = Right(Ret, Len(Ret) - (InStr(1, Ret, "DATABASE=") + 8))
Set db = DBEngine.Workspaces(0).OpenDatabase(LinkedDBName)
'
'********************************************
' Create new field OLD-PROJ of table DETAIL
Set tdf = db.TableDefs("DETAIL")
Set fld = tdf.CreateField("OLD-PROJ", dbText, 3)
SetPro fld, "Attributes", dbLong, 2
tdf.Fields.Append fld
SetPro fld, "AllowZeroLength", dbBoolean, True
SetPro fld, "DefaultValue", dbText, ""
SetPro fld, "OrdinalPosition", dbLong, 18
SetPro fld, "Required", dbBoolean, False
' Create new field LOGON-LDAP-locked of table Logon Names
Set tdf = db.TableDefs("Logon Names")
Set fld = tdf.CreateField("LOGON-LDAP-locked", dbBoolean)
SetPro fld, "Attributes", dbLong, 1
tdf.Fields.Append fld
SetPro fld, "Description", dbText, "LDAP value reviewed, should not be changed (by code)"
SetPro fld, "Format", dbText, "Yes/No"
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "DefaultValue", dbText, "No"
SetPro fld, "OrdinalPosition", dbLong, 3
SetPro fld, "Required", dbBoolean, False
' Create new field MONTHS-BILL-COST of table Months
Set tdf = db.TableDefs("Months")
Set fld = tdf.CreateField("MONTHS-BILL-COST", dbCurrency)
SetPro fld, "Attributes", dbLong, 1
tdf.Fields.Append fld
SetPro fld, "Description", dbText, "..Also to track discrepencies between detail and actual billing"
SetPro fld, "Format", dbText, "$#,##0.00;($#,##0.00)"
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "DefaultValue", dbText, "0"
SetPro fld, "OrdinalPosition", dbLong, 3
SetPro fld, "Required", dbBoolean, False
' Create new field FTP Server of table Preferences
Set tdf = db.TableDefs("Preferences")
Set fld = tdf.CreateField("FTP Server", dbText, 50)
SetPro fld, "Attributes", dbLong, 2
tdf.Fields.Append fld
SetPro fld, "Description", dbText, "dns name or ip address of ftp server"
SetPro fld, "AllowZeroLength", dbBoolean, True
SetPro fld, "DefaultValue", dbText, ""
SetPro fld, "OrdinalPosition", dbLong, 4
SetPro fld, "Required", dbBoolean, False
' Create new field Version of table Preferences
Set tdf = db.TableDefs("Preferences")
Set fld = tdf.CreateField("Version", dbText, 4)
SetPro fld, "Attributes", dbLong, 2
tdf.Fields.Append fld
SetPro fld, "Description", dbText, "software/database version"
SetPro fld, "AllowZeroLength", dbBoolean, True
SetPro fld, "DefaultValue", dbText, ""
SetPro fld, "OrdinalPosition", dbLong, 14
SetPro fld, "Required", dbBoolean, False
' change field LOGON-personal of table Logon Names
Set fld = db.TableDefs("Logon Names").Fields("LOGON-personal")
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "DefaultValue", dbText, "No"
SetPro fld, "Required", dbBoolean, False
' change field DETAIL-FILENO of table Months
Set fld = db.TableDefs("Months").Fields("DETAIL-FILENO")
SetPro fld, "Description", dbText, "No RI to DETAIL. Import functionality creates and deletes rows..."
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "Required", dbBoolean, False
' change field PROJECT-REAL-BUDGET-CODE of table Project Names
Set fld = db.TableDefs("Project Names").Fields("PROJECT-REAL-BUDGET-CODE")
SetPro fld, "Description", dbText, "real budget code associated with this project"
SetPro fld, "AllowZeroLength", dbBoolean, False
SetPro fld, "Required", dbBoolean, False
' create relation between tables Months and DETAIL
Set rel = db.CreateRelation("MonthsDETAIL")
rel.Table = "Months"
rel.ForeignTable = "DETAIL"
Set fld = rel.CreateField("DETAIL-FILENO")
fld.ForeignName = "DETAIL-FILENO"
rel.Fields.Append fld
rel.Attributes = 2
db.Relations.Append rel
End Sub
'******************************************
'* SetPro subroutine supporting VBA code *
'* generated by Compare'EM *
'******************************************
'* Compare'EM version 0.5b *
'* Copyright © 2005, Mike Noel *
'******************************************
Private Sub SetPro(o As Object, s As String, t As DataTypeEnum, v As Variant)
On Error GoTo Problems
o.Properties(s) = v
Exit Sub
Problems:
If Err = 3270 Then
o.Properties.Append o.CreateProperty(s, t, v)
Resume ProblemsX
End If
On Error GoTo 0
Resume
ProblemsX:
End Sub