vb timetable scheduling

Posted on 2006-11-13
Last Modified: 2013-12-25
Hi all,

ive inhereted a system which works out appointments for students and uses vb in access to automatically schedule these appointments. (code pasted below).

it works on a token system - if a child wants to see a teacher you set a 'requested' field to 'yes' then copies that info linked to the teacher info into a timeslot in a new table.

what i need to do is amend it in one of the following two ways.

either i need to set it so more than one pupil can see a teacher at any one time- as it stands the pupils can only visit it one at a time for a five min slot- i wanna change that to up to 15 kids for a 20 minute slot....

or (and this is probably easier) program 1 minute appointments with 20 minute gaps- and the gaps must be inforced.

here's why- at the moment the code is taking the selected appointments and scheduling them in within the start and end times into 5 minute slots- the new event im running has 20 minute slots yet can have mutilple attendees so need to change the elements of the code to allow for this.

therefore i can either make the appointments have multiple attendees (don't know how!)- think this would involve a complete overhaul of the code

or make the appointments 1 minute long but increase the gap between them to 20 minutes- this means the appointments can only have one attendee but there will be 20 within 20 minutes- this is probably easier

hope this make sense- can anyone help?


Private Sub Autoshedule_Click()
Dim students As DAO.Recordset
Dim appointment As DAO.Recordset
Dim StudApps As DAO.Recordset
Dim TeacApps As DAO.Recordset
Dim StudentId As String
Dim teacherID As String
Dim sql As Variant
Dim Score As Long
Dim isfirst As Boolean
Dim i, c As Long
Dim Time As Double
Dim t1 As Long
Dim t2 As Long
Dim time1, time2 As Variant

'do demand fill
Call whoisindemand

sql = "SELECT txStudsForPEve.StudentID, txStudsForPEve.ReciveDate FROM txStudsForPEve ORDER BY txStudsForPEve.demand ,txStudsForPEve.ReciveDate"
Set students = DBEngine(0)(0).OpenRecordset(sql)
c = 1
isfirst = True
While Not students.EOF
StudentId = students.Fields("StudentID")
If StudentId = "1609" Then
StudentId = StudentId
End If
Me.Autoshedule.Caption = Str(c)
c = c + 1
'find all appointments requested by student
sql = "SELECT txAppointments.ID, txAppointments.StudentID, txAppointments.subject, txAppointments.Requested, txAppointments.Priority, txAppointments.Unacceptable, txAppointments.Set, txAppointments.Time, txAppointments.Demand FROM txAppointments WHERE (((txAppointments.StudentID)='" & StudentId & "') AND ((txAppointments.Requested)=True) AND ((txAppointments.Unacceptable)=False)) ORDER BY txAppointments.Demand;"
Set appointment = DBEngine(0)(0).OpenRecordset(sql)
While Not appointment.EOF
subject = appointment.Fields("subject")
sql = "SELECT txPapps.ID, txPapps.StudentID, txPapps.Available, txPapps.Time, txPapps.Score, txPapps.Link FROM txPapps WHERE (((txPapps.StudentID)='" & StudentId & "') AND ((txPapps.Available)=True)) ORDER BY txPapps.Time;"
Set StudApps = DBEngine(0)(0).OpenRecordset(sql)
t1 = StudApps.AbsolutePosition
If t1 <> -1 Then
t2 = StudApps.AbsolutePosition
End If
While Not StudApps.EOF
sql = "SELECT txTapps.ID, txTapps.subject, txTapps.Available, txTapps.Time, txTapps.score, txTapps.Link FROM txTapps WHERE (((txTapps.subject)= '" & subject & "') AND ((txTapps.Available) = True)) ORDER BY txTapps.Time;"
Set TeacApps = DBEngine(0)(0).OpenRecordset(sql)
While Not TeacApps.EOF

time1 = DateDiff("s", TeacApps.Fields("time"), StudApps.Fields("time"))
If time1 = 0 Then
StudApps.Fields("Available") = False
StudApps.Fields("Link") = appointment.Fields("ID")

TeacApps.Fields("Available") = False
TeacApps.Fields("Link") = appointment.Fields("ID")
TeacApps.Update 'move to the next teacher

appointment.Fields("set") = True
appointment.Fields("time") = StudApps.Fields("time")

End If
Me.Autoshedule.Caption = "AutoShed"
'select a student
'score his remaining appointments
'generate a list pf remaining teachers
'pick a teacher that fits his next best score
End Sub
'=================================================================================================== ====
'this sets up tokens for setting appointment, it bases itself on the studs and teachers table
'so set you limitations in this instance
Private Sub BuildApps_Click()
Dim source As DAO.Recordset
Dim dest As DAO.Recordset
Dim t1 As Double
Dim t2 As Double
Dim stuID As String
Dim onemin As Double
Dim debug1 As Variant
Dim debug2 As Variant
Dim i As Double

onemin = 20 / (24 * 60)

Set dest = DBEngine(0)(0).OpenRecordset("txPapps")
Set source = DBEngine(0)(0).OpenRecordset("txStudsForPEve")

DoCmd.SetWarnings False
Call DoCmd.RunSQL("DELETE * from txPapps")
DoCmd.SetWarnings True

While Not source.EOF
stuID = source.Fields("StudentID")
t1 = source.Fields("StartTime")
t2 = source.Fields("EndTime")
For i = t1 To t2 Step onemin
dest.Fields("StudentID") = stuID
dest.Fields("Time") = i
Next i

Set dest = DBEngine(0)(0).OpenRecordset("txTapps")
Set source = DBEngine(0)(0).OpenRecordset("txTeaForPEve")

DoCmd.SetWarnings False
Call DoCmd.RunSQL("DELETE * from txTapps")
DoCmd.SetWarnings True

While Not source.EOF
stuID = source.Fields("Subject")
t1 = source.Fields("StartTime")
t2 = source.Fields("EndTime")
For i = t1 To t2 Step onemin
dest.Fields("Subject") = stuID
dest.Fields("Time") = i
Next i
End Sub
'=================================================================================================== ========
'waps out all the appointmnts
Private Sub ClearAll_Click()
Dim ToClear As DAO.Recordset

Set ToClear = DBEngine(0)(0).OpenRecordset("txPapps")
While Not ToClear.EOF
ToClear.Fields("Link") = Null
ToClear.Fields("Available") = True
ToClear.Fields("Score") = 0

Set ToClear = DBEngine(0)(0).OpenRecordset("txTapps")
While Not ToClear.EOF
ToClear.Fields("Link") = Null
ToClear.Fields("Available") = True

Set ToClear = DBEngine(0)(0).OpenRecordset("txAppointments")
While Not ToClear.EOF
ToClear.Fields("Time") = Null
ToClear.Fields("Set") = False

End Sub


Question by:Dubs
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
LVL 29

Accepted Solution

leonstryker earned 25 total points
ID: 17930654

You are asking for someone to rewrite this application for you.  This not the way EE works. We are here to answer technical questions and to help you in writting code.


Author Comment

ID: 17930715
Yeah, ive looked at the code and realised that there isn't any easy way to insert a line of code to do this.

i though originally it may have been a case of introducing a new variable but realise it's more in depth than that.

ill get the q closed off.



Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction In a recent article ( for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

726 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question