Hello, Database now added later in message
I have converted from 97 to 2003, amd the following code fails at the place where I have placed bold comments. It ran well in 97 so I can't understand why there is a mismatch. Hopefully brains greater than mine can see the error. So that will be most of you by the looks of
Thanks in advance
------------------------------------------------------------
Private Sub Form_Load()
Dim dteCurMax As Date 'Current maximum date
Dim intCurMax As Integer
Dim intNewMax As Integer
DoCmd.Maximize 'maximise the form
MaximizeAccess 'maximise the application
DoCmd.Hourglass True
'Runs Honestey Macro
'DoCmd.RunMacro "mcrHonest"
'set the trap to stop the form being closed other than via the Exit button
mOKToClose = False
' Check using a linked table name to see if database is available.
If CheckLinks("tblDutyDate") = False Then
' Try to relink the tables to the existing link path; if it fails, shut down.
If RelinkTables() = False Then
DoCmd.Close 'This form
CloseCurrentDatabase
Else
'Refresh the form originating this action
Forms![frmMainMenu].Refresh
End If
End If
'Check to see if the DB has some dates and make sure there are at least
'31 from today.
If IsNull(DMax("DutyDate", "[tblDutyDate]")) Then 'tblDutyDate is empty
dteCurMax = Format(Now() - 1, "dd/mm/yyyy")
Else
dteCurMax = DMax("DutyDate", "[tblDutyDate]")
End If
intCurMax = DateDiff("d", Now(), dteCurMax)
Select Case intCurMax
Case Is < 0
intNewMax = ((intCurMax * -1) + 31)
Case Is = 0
intNewMax = intCurMax + 31
Case Is > 0
intNewMax = 31 - intCurMax
End Select
If intNewMax > 0 Then
AddDates (intNewMax) The error is linked in here see further down
End If
'Create a Temp DB and link to it
CreateTempDB
DoCmd.Hourglass False
End Sub
---------------------------------------------------------------------
Function AddDates() '(pDaysToAdd As Integer) this I moved down
On Error GoTo Err_Add_Dates_Click
'This procedure will add dates to the "tblDutyDate" table.
Dim Criteria1 As String
Dim StartDate As String
Dim pDaysToAdd As Integer
Dim EndDate As String
Dim AddDate As String
Dim DayNum As Single ' To allow for the Friday value of 1.5
Dim intI As Integer
Dim intQ As Integer
'Declare an array to hold day values
Dim DayValues(1 To 7) As Single
Dim dbs As DAO.Database
Dim rsDay As DAO.Recordset
Dim rsDate As DAO.Recordset
Dim rsRoster As DAO.Recordset
Set dbs = DBEngine.Workspaces(0).Databases(0)
'Fill the array with the daily values
Set rsDay = dbs.OpenRecordset("tblDayValues", dbOpenSnapshot) ' Open table.
For intI = 1 To 7
Criteria1 = "ID = " & intI
rsDay.FindFirst Criteria1
If Not rsDay.NoMatch Then
DayValues(intI) = rsDay![Value]
Else
DayValues(intI) = 1
End If
Next intI
rsDay.Close
'Get the last date in the database table
'???If IsNull(DMax("DutyDate", "[tblDutyDate]")) Then 'tblDutyDate is empty
If IsNull(DMax("DutyDate", "[tblDutyDate]")) Then 'tblDutyDate is empty
StartDate = Now - 62
Else
StartDate = DMax("DutyDate", "[tblDutyDate]")
End If
If Not pDaysToAdd > 0 Then
' "Don't need to add days prior to Now"
Exit Function
This leads to Run Error 13 TYPE MISMATCH
End If
EndDate = Format((StartDate + pDaysToAdd), "dd/mm/yyyy")
MsgBox "EndDate"
'EndDate = StartDate = pDaysToAdd
Set rsRoster = dbs.OpenRecordset("tblRoster", dbOpenDynaset) ' Open table.
Set rsDate = dbs.OpenRecordset("tblDutyDate", dbOpenDynaset) ' Open table.
Do Until rsRoster.EOF ' Until end of file.
'Add the required days to the database
AddDate = Format((StartDate + 1), "dd/mm/yyyy")
'Do this until all dates are added
intI = 0
Do Until intI >= pDaysToAdd
DayNum = WeekDay(AddDate)
intQ = 1
'Do this until an entry has been made for each post in a Roster
'Do Until intQ > rsRoster.Qty old
Do Until intQ > rsRoster!Qty
rsDate.AddNew ' Create new record.
rsDate("DutyDate") = AddDate ' Set Date
rsDate("DutyID") = rsRoster!DutyID ' Set Roster ID
rsDate("Value") = DayValues(DayNum) ' Set days value
rsDate("Post") = intQ ' Set post number
rsDate.Update
'More than one person reqd for the duty
intQ = intQ + 1
Loop
' Increment dates
AddDate = DateValue(AddDate) + 1
intI = intI + 1
Loop
rsRoster.MoveNext 'Move onto the next roster
Loop
rsDate.Close ' Close table.
rsRoster.Close
Exit_Add_Dates_Click:
Exit Function
Err_Add_Dates_Click:
MsgBox Error$
Resume Exit_Add_Dates_Click
End Function
I have converted from 97 to 2003, amd the following code fails at the place where I have placed bold comments. It ran well in 97 so I can't understand why there is a mismatch. Hopefully brains greater than mine can see the error. So that will be most of you by the looks of
Thanks in advance
------------------------------------------------------------
Private Sub Form_Load()
Dim dteCurMax As Date 'Current maximum date
Dim intCurMax As Integer
Dim intNewMax As Integer
DoCmd.Maximize 'maximise the form
MaximizeAccess 'maximise the application
DoCmd.Hourglass True
'Runs Honestey Macro
'DoCmd.RunMacro "mcrHonest"
'set the trap to stop the form being closed other than via the Exit button
mOKToClose = False
' Check using a linked table name to see if database is available.
If CheckLinks("tblDutyDate") = False Then
' Try to relink the tables to the existing link path; if it fails, shut down.
If RelinkTables() = False Then
DoCmd.Close 'This form
CloseCurrentDatabase
Else
'Refresh the form originating this action
Forms![frmMainMenu].Refresh
End If
End If
'Check to see if the DB has some dates and make sure there are at least
'31 from today.
If IsNull(DMax("DutyDate", "[tblDutyDate]")) Then 'tblDutyDate is empty
dteCurMax = Format(Now() - 1, "dd/mm/yyyy")
Else
dteCurMax = DMax("DutyDate", "[tblDutyDate]")
End If
intCurMax = DateDiff("d", Now(), dteCurMax)
Select Case intCurMax
Case Is < 0
intNewMax = ((intCurMax * -1) + 31)
Case Is = 0
intNewMax = intCurMax + 31
Case Is > 0
intNewMax = 31 - intCurMax
End Select
If intNewMax > 0 Then
AddDates (intNewMax) The error is linked in here see further down
End If
'Create a Temp DB and link to it
CreateTempDB
DoCmd.Hourglass False
End Sub
---------------------------------------------------------------------
Function AddDates() '(pDaysToAdd As Integer) this I moved down
On Error GoTo Err_Add_Dates_Click
'This procedure will add dates to the "tblDutyDate" table.
Dim Criteria1 As String
Dim StartDate As String
Dim pDaysToAdd As Integer
Dim EndDate As String
Dim AddDate As String
Dim DayNum As Single ' To allow for the Friday value of 1.5
Dim intI As Integer
Dim intQ As Integer
'Declare an array to hold day values
Dim DayValues(1 To 7) As Single
Dim dbs As DAO.Database
Dim rsDay As DAO.Recordset
Dim rsDate As DAO.Recordset
Dim rsRoster As DAO.Recordset
Set dbs = DBEngine.Workspaces(0).Databases(0)
'Fill the array with the daily values
Set rsDay = dbs.OpenRecordset("tblDayValues", dbOpenSnapshot) ' Open table.
For intI = 1 To 7
Criteria1 = "ID = " & intI
rsDay.FindFirst Criteria1
If Not rsDay.NoMatch Then
DayValues(intI) = rsDay![Value]
Else
DayValues(intI) = 1
End If
Next intI
rsDay.Close
'Get the last date in the database table
'???If IsNull(DMax("DutyDate", "[tblDutyDate]")) Then 'tblDutyDate is empty
If IsNull(DMax("DutyDate", "[tblDutyDate]")) Then 'tblDutyDate is empty
StartDate = Now - 62
Else
StartDate = DMax("DutyDate", "[tblDutyDate]")
End If
If Not pDaysToAdd > 0 Then
' "Don't need to add days prior to Now"
Exit Function
This leads to Run Error 13 TYPE MISMATCH
End If
EndDate = Format((StartDate + pDaysToAdd), "dd/mm/yyyy")
MsgBox "EndDate"
'EndDate = StartDate = pDaysToAdd
Set rsRoster = dbs.OpenRecordset("tblRoster", dbOpenDynaset) ' Open table.
Set rsDate = dbs.OpenRecordset("tblDutyDate", dbOpenDynaset) ' Open table.
Do Until rsRoster.EOF ' Until end of file.
'Add the required days to the database
AddDate = Format((StartDate + 1), "dd/mm/yyyy")
'Do this until all dates are added
intI = 0
Do Until intI >= pDaysToAdd
DayNum = WeekDay(AddDate)
intQ = 1
'Do this until an entry has been made for each post in a Roster
'Do Until intQ > rsRoster.Qty old
Do Until intQ > rsRoster!Qty
rsDate.AddNew ' Create new record.
rsDate("DutyDate") = AddDate ' Set Date
rsDate("DutyID") = rsRoster!DutyID ' Set Roster ID
rsDate("Value") = DayValues(DayNum) ' Set days value
rsDate("Post") = intQ ' Set post number
rsDate.Update
'More than one person reqd for the duty
intQ = intQ + 1
Loop
' Increment dates
AddDate = DateValue(AddDate) + 1
intI = intI + 1
Loop
rsRoster.MoveNext 'Move onto the next roster
Loop
rsDate.Close ' Close table.
rsRoster.Close
Exit_Add_Dates_Click:
Exit Function
Err_Add_Dates_Click:
MsgBox Error$
Resume Exit_Add_Dates_Click
End Function
Last edited:
