Code:
Option Explicit
Private btn As Integer
Private Sub cboDocket_Change()
EvaluateCalendar
If Not IsNull(cboPeriod) Then
ActivateCalendar
EvaluatePrevNext
RequeryListBoxes
lstClient.Requery
lstClient = Null
End If
End Sub
Private Sub cboPeriod_Exit(Cancel As Integer)
If IsNull(cboPeriod.Column(1)) Then
MsgBox "No Period was chosen, going to most recent period for this docket.", vbOKOnly, "No Selected Period"
EvaluateCalendar
End If
ActivateCalendar
EvaluatePrevNext
RequeryListBoxes
End Sub
Private Sub Cmd_Create_Click()
CreateNewSpan
EvaluateCalendar
ActivateCalendar
EvaluatePrevNext
RequeryListBoxes
lstClient.Requery
lstClient = Null
End Sub
Private Sub Cmd_CreateSched_Click()
CreateNewSpan
EvaluateCalendar
ActivateCalendar
EvaluatePrevNext
RequeryListBoxes
lstClient.Requery
lstClient = Null
ScheduleAll
End Sub
Private Sub cmd_Next_Click()
Dim dNextDate As Date
dNextDate = DMin("ds_startdate", "tblDocketSpan", "[D_ID] = " & cboDocket & " AND [DS_StartDate] > #" & cboPeriod.Column(2) & "#")
cboPeriod = DLookup("DS_ID", "tblDocketSpan", "[D_ID] = " & cboDocket & " AND [DS_StartDate] = #" & dNextDate & "#")
ActivateCalendar
EvaluatePrevNext
RequeryListBoxes
lstClient.Requery
lstClient = Null
End Sub
Private Sub cmd_Prev_Click()
Dim dPrevDate As Date
dPrevDate = DMax("ds_startdate", "tblDocketSpan", "[D_ID] = " & cboDocket & " AND [DS_StartDate] < #" & cboPeriod.Column(2) & "#")
cboPeriod = DLookup("DS_ID", "tblDocketSpan", "[D_ID] = " & cboDocket & " AND [DS_StartDate] = #" & dPrevDate & "#")
ActivateCalendar
EvaluatePrevNext
RequeryListBoxes
lstClient.Requery
lstClient = Null
End Sub
Private Sub Cmd_Schedule_Click()
ScheduleAll
End Sub
Private Sub cmdClearSelection_Click()
ClearLists
lstClient = Null
End Sub
Private Sub cmdInitialSpan_Click()
DoCmd.OpenForm "frmDocketSpan"
End Sub
Private Sub Form_Activate()
EvaluateCalendar
If Not IsNull(cboPeriod) Then
lstClient.Requery
ActivateCalendar
EvaluatePrevNext
SetListBoxes
End If
End Sub
Private Sub Form_Load()
cboDocket = DLookup("D_ID", "tblDocket", "not isnull([Opt_ID_Default])")
End Sub
Function SetListBoxes()
Dim ctl As Control
Dim sSQL As String
For Each ctl In Me.Controls
If InStr(ctl.Tag, "CALL") > 0 Then
sSQL = "SELECT tblClientScreen.CS_ID, "
sSQL = sSQL & "[c_ln] & "", "" & [c_fn] AS Participant,"
sSQL = sSQL & "Left([CS_Status],1) AS Stat "
sSQL = sSQL & "FROM (tblClientScreen LEFT JOIN tblClientDocket ON tblClientScreen.CD_ID = tblClientDocket.CD_ID) LEFT JOIN tblClient ON tblClientDocket.C_ID = tblClient.C_ID "
sSQL = sSQL & "WHERE CS_Date = [forms]![frmcalendar]![" & Replace(ctl.Name, "lst", "fld") & "]"
sSQL = sSQL & "AND ((tblClientDocket.D_ID)= " & [Forms]![frmcalendar]![cboDocket] & ")"
ctl.RowSource = sSQL
ctl.Requery
End If
Next ctl
End Function
Function RequeryListBoxes()
Dim ctl As Control
For Each ctl In Me.Controls
If InStr(ctl.Tag, "CALL") > 0 Then
ctl.Value = Null
ctl.Requery
End If
Next ctl
End Function
Function EvaluateCalendar()
Dim ctl As Control
Dim MRStart As Date
DoCmd.GoToControl ("cbodocket")
If DCount("*", "tblDocketSpan", "[D_ID] = " & cboDocket) > 0 Then
cboPeriod.Requery
cboPeriod.Enabled = True
cboPeriod = DMax("DS_ID", "tblDocketspan", "[D_ID] = " & cboDocket)
cmdInitialSpan.Visible = False
Else
cboPeriod.Requery
cboPeriod.Enabled = False
cboPeriod = Null
cmdInitialSpan.Visible = True
For Each ctl In Me.Controls
If InStr(ctl.Tag, "CAL") > 0 Then
ctl.Visible = False
End If
Next ctl
End If
End Function
Function ActivateCalendar()
Dim StartDate As Date
Dim EndDate As Date
Dim sChangeCtl As String
Dim irow As Integer
Dim icol As Integer
Dim FormName As String
Dim ControlName As String
Dim DateName As String
Dim iactivate
Dim CmdName As String
StartDate = cboPeriod.Column(2)
EndDate = cboPeriod.Column(3)
FormName = "frmcalendar"
Dim ctl As Control
For Each ctl In Me.Controls
If InStr(ctl.Tag, "CAL") > 0 Then
ctl.Visible = False
End If
Next ctl
irow = 1
sChangeCtl = "lst_0" & irow & "0" & icol
Do Until StartDate > EndDate
icol = Weekday(StartDate)
If icol = 1 Then
If cboDocket.Column(3) = -1 Then
iactivate = 1
Else
iactivate = 0
End If
ElseIf icol = 7 Then
If cboDocket.Column(2) = -1 Then
iactivate = 1
Else
iactivate = 0
End If
Else
iactivate = 1
End If
ControlName = "lst_0" & irow & "0" & icol
If iactivate = 1 Then
Forms(Me.Name).Controls(ControlName).Visible = True
End If
DateName = "fld_0" & irow & "0" & icol
Forms(Me.Name).Controls(DateName).Visible = True
Forms(Me.Name).Controls(DateName) = StartDate
'Forms(FormName).Controls(ControlName).Requery
StartDate = DateAdd("d", 1, StartDate)
If icol = 7 Then
irow = irow + 1
End If
Loop
End Function
Function EvaluatePrevNext()
If cboPeriod.Enabled = True Then
DoCmd.GoToControl ("cboPeriod")
Else
DoCmd.GoToControl ("cboDocket")
End If
If DCount("*", "tblDocketSpan", "[D_ID] = " & cboDocket) <= 1 Then
cmd_Prev.Enabled = False
cmd_Next.Enabled = False
Else
If CDate(cboPeriod.Column(2)) = CDate(DMax("[ds_startdate]", "tbldocketspan", "[D_ID] = " & cboDocket)) Then
cmd_Prev.Enabled = True
cmd_Next.Enabled = False
ElseIf CDate(cboPeriod.Column(2)) = CDate(DMin("[ds_startdate]", "tbldocketspan", "[D_ID] = " & cboDocket)) Then
cmd_Prev.Enabled = False
cmd_Next.Enabled = True
Else
cmd_Prev.Enabled = True
cmd_Next.Enabled = True
End If
End If
End Function
Function CreateNewSpan()
Dim db As Database
Dim sSQL As String
Dim dNextDate As Date
dNextDate = DateAdd("d", 1, DMax("DS_EndDate", "tblDocketSpan", "[D_ID] = " & cboDocket))
sSQL = "INSERT INTO tblDocketSpan ("
sSQL = sSQL & "D_ID, "
sSQL = sSQL & "DS_StartDate, "
sSQL = sSQL & "DS_EndDate"
sSQL = sSQL & ") VALUES ("
sSQL = sSQL & cboDocket & ", "
sSQL = sSQL & "#" & dNextDate & "#, "
sSQL = sSQL & "#" & DateAdd("d", (cboDocket.Column(4) * 7) - 1, dNextDate) & "#"
sSQL = sSQL & ")"
Set db = CurrentDb
db.Execute sSQL
Set db = Nothing
End Function
Function CreateCustMenu()
Dim sMenuName As String
Dim cmb As Office.CommandBar
Dim cmbItem
Dim dDate As Date
sMenuName = "ListBoxRightClickMenu"
On Error Resume Next
CommandBars(sMenuName).Delete
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
dDate = Forms(Me.Name).Controls(Replace(Screen.ActiveControl.Name, "lst", "fld")).Value
Set cmb = CommandBars.Add(sMenuName, msoBarPopup, False, False)
Set cmbItem = cmb.Controls.Add(msoControlButton, , , , True)
With cmbItem
.Caption = "Cancel"
End With
If Not IsNull(lstClient) Then
Set cmbItem = cmb.Controls.Add(msoControlButton, , , , True)
With cmbItem
.Caption = "Add " & lstClient.Column(1) & " to " & dDate
If IsNull(lstClient) Then
.Enabled = False
Else
If EvaluateAdd < CInt(lstClient.Column(5)) Then
If DCount("*", "tblClientScreen", "[CD_ID] = " & lstClient & " AND [CS_Date] = #" & Me.Controls(Replace(Screen.ActiveControl.Name, "lst", "fld")) & "#") = 0 Then
.Enabled = True
Else
.Enabled = False
End If
Else
.Enabled = False
End If
End If
.OnAction = "=addsingle()"
End With
End If
If Not IsNull(Me.Controls(Screen.ActiveControl.Name).Value) Then
Set cmbItem = cmb.Controls.Add(msoControlButton, , , , True)
With cmbItem
.Caption = "Remove " & Me.Controls(Screen.ActiveControl.Name).Column(1) & " from " & dDate
If IsNull((Screen.ActiveControl.Value)) Then
.Enabled = False
Else
If Me.Controls(Screen.ActiveControl.Name).Column(2) <> "I" Then
.Enabled = False
Else
.Enabled = True
End If
End If
.OnAction = "=deletesingle()"
End With
End If
End Function
Function CreateCustClientMenu(strCap As String)
Dim sMenuName As String
Dim cmb As Office.CommandBar
Dim cmbItem
Dim dDate As Date
sMenuName = "ClientRightClickMenu"
On Error Resume Next
CommandBars(sMenuName).Delete
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
Set cmb = CommandBars.Add(sMenuName, msoBarPopup, False, False)
Set cmbItem = cmb.Controls.Add(msoControlButton, , , , True)
With cmbItem
.Caption = "Find all Screens for " & strCap
If IsNull(lstClient) Then
.Enabled = False
Else
.Enabled = True
End If
.OnAction = "=findscreens()"
End With
Set cmbItem = cmb.Controls.Add(msoControlButton, , , , True)
With cmbItem
.Caption = "Cancel"
End With
End Function
Function FindScreens()
Dim CD_ID As Long
Dim DS_ID As Long
Dim rst As Recordset
Dim db As Database
Dim ctl As Control
ClearLists
CD_ID = lstClient
DS_ID = cboPeriod
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT * FROM tblClientScreen WHERE CD_ID = " & CD_ID & " AND DS_ID = " & DS_ID)
For Each ctl In Me.Controls
If InStr(ctl.Tag, "CALD") > 0 Then
If ctl.Visible = True Then
rst.MoveFirst
Do While rst.EOF <> True
If rst!CS_Date = ctl.Value Then
Me.Controls(Replace(ctl.Name, "fld", "lst")).Value = rst!cs_id
End If
rst.MoveNext
Loop
End If
End If
Next ctl
rst.Close
Set rst = Nothing
Set db = Nothing
End Function
Function EvaluateAdd()
Dim iScreens As Integer
Dim iSpan As Integer
Dim dEventDate As Date
Dim dSpanStart As Date
Dim dSpanEnd As Date
iScreens = lstClient.Column(5)
iSpan = lstClient.Column(6)
dEventDate = Me.Controls(Replace(Screen.ActiveControl.Name, "lst", "fld")).Value
If iSpan * 7 < DateDiff("d", fld_PeriodStart, fld_PeriodEnd) + 1 Then
' Debug.Print "span within span"
dSpanStart = fld_PeriodStart
Do While dSpanStart < fld_PeriodEnd
dSpanEnd = DateAdd("d", 6, dSpanStart)
If dEventDate >= dSpanStart And dEventDate <= dSpanEnd Then
GoTo EXITLOOP
End If
dSpanStart = dSpanEnd + 1
Loop
ElseIf iSpan * 7 = DateDiff("d", fld_PeriodStart, fld_PeriodEnd) + 1 Then
dSpanStart = fld_PeriodStart
dSpanEnd = fld_PeriodEnd
GoTo EXITLOOP
Else
' Debug.Print "WTF"
End If
EXITLOOP:
'Debug.Print dSpanStart
'Debug.Print dSpanEnd
'Debug.Print DCount("*", "tblclientscreen", "CD_ID = " & lstClient & " AND (CS_Date Between #" & dSpanStart & "# AND #" & dSpanEnd & "#)")
EvaluateAdd = CInt(DCount("*", "tblclientscreen", "CD_ID = " & lstClient & " AND (CS_Date Between #" & dSpanStart & "# AND #" & dSpanEnd & "#)"))
End Function
Function AddSingle()
Dim db As Database
Dim sSQL As String
sSQL = "INSERT INTO tblClientScreen ("
sSQL = sSQL & "CD_ID, "
sSQL = sSQL & "DS_ID, "
sSQL = sSQL & "CS_Date"
sSQL = sSQL & ") VALUES ("
sSQL = sSQL & lstClient & ", "
sSQL = sSQL & cboPeriod & ", "
sSQL = sSQL & "#" & Me.Controls(Replace(Screen.ActiveControl.Name, "lst", "fld")).Value & "#"
sSQL = sSQL & ")"
Set db = CurrentDb
db.Execute sSQL
Set db = Nothing
Me.Controls(Screen.ActiveControl.Name).Requery
Me.Controls(Screen.ActiveControl.Name).Value = Null
End Function
Function DeleteSingle()
Dim db As Database
Dim sSQL As String
sSQL = "DELETE * FROM tblClientScreen WHERE CS_ID = " & Screen.ActiveControl.Value
Set db = CurrentDb
db.Execute sSQL
Set db = Nothing
DoEvents
Me.Controls(Screen.ActiveControl.Name).Requery
Me.Controls(Screen.ActiveControl.Name).Value = Null
End Function
Function ClickMenu(Button, scontrolname)
DoEvents
If Button = acRightButton Then
CreateCustMenu
CommandBars("ListBoxRightClickMenu").ShowPopup
Else
End If
End Function
Function ClickMenuClient(btn, scontrolname, strCap As String)
DoEvents
If btn = acRightButton Then
CreateCustClientMenu (strCap)
CommandBars("ClientRightClickMenu").ShowPopup
Else
End If
End Function
Function ClearLists()
Dim ctl As Control
For Each ctl In Me.Controls
If InStr(ctl.Tag, "CALL") > 0 Then
ctl.Value = Null
End If
Next ctl
End Function
Private Sub lst_0101_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0102_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0103_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0104_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0105_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0106_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0107_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_021_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0202_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0203_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0204_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0205_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0206_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0207_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0301_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0302_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0303_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0304_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0305_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0306_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0307_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0401_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0402_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0403_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0404_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0405_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0406_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0407_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0501_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0502_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0503_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0504_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0505_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0506_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0507_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0601_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lst_0602_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ClickMenu(Button, Screen.ActiveControl.Name)
End Sub
Private Sub lstClient_Click()
Call ClickMenuClient(btn, Screen.ActiveControl.Name, Me.lstClient.Column(1))
End Sub
Private Sub lstClient_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
btn = Button
End Sub
Private Sub lstClient_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Call ClickMenuClient(button, Screen.ActiveControl.Name)
End Sub
Function ScheduleAll()
Dim Response
Dim db As Database
Dim sSQL As String
Dim ListCtl As Control
Dim i As Long
Dim iPeriodLength As Long
Dim CD_ID As Long
Dim iSubTests As Long
Dim iSubLength As Long
Dim iSubLoops As Long
Dim w As Long
Dim dPerStart As Date 'period start
Dim dPerEnd As Date 'period end
Dim dCSPStart As Date 'current sub period
Dim dCSPEnd As Date 'current sub period end
Dim iRandomDays 'generates a random number between 0 and the upper bound of number of days in the sub period
Dim t As Long
Dim iTestSat As Long
Dim iTestSun As Long
Dim dTestDate As Date
Set db = CurrentDb
If DCount("*", "tblClientScreen", "DS_ID = " & cboPeriod) > 0 Then
Response = MsgBox("WARNING:" & vbCrLf & vbCrLf & "Scheduled screens exist for this period for this docket" & vbCrLf & vbCrLf & "Do you want to reschedule existing NON PENDING screens?" & vbCrLf & vbCrLf & "YES = Remove existing NON PENDING screens and reschedule every participant" & vbCrLf & vbCrLf & "NO = Keep existing schedule and add any new participants to schedule", vbYesNo, "Confirm Scheduling/Rescheduling")
Else
Response = vbNo
End If
If Response = vbYes Then
'set the value of all calendar lists to null
ClearLists
'remove all existing incomplete screens
db.Execute ("DELETE * FROM tblClientScreen WHERE DS_ID = " & cboPeriod & " AND CS_Status = 'INCOMPLETE'")
End If
'set docket variables
dPerStart = Me.fld_PeriodStart
dPerEnd = Me.fld_PeriodEnd
iPeriodLength = cboDocket.Column(4) 'Maximum length of the period
iTestSat = cboDocket.Column(2) 'Test saturday indicator
iTestSun = cboDocket.Column(3) 'test sunday indicaator
'cycle through people in list box
Set ListCtl = Me.lstClient
With ListCtl
For i = 1 To .ListCount - 1
CD_ID = .Column(0, i) 'ClientDocketID - unique identifier of client within a docket
iSubTests = .Column(5, i) 'Number of tests required in sub period
iSubLength = .Column(6, i) 'number of weeks in the sub period
iSubLoops = iPeriodLength / iSubLength 'number of times to cycle through scheduling
dCSPStart = dPerStart
' Debug.Print CD_ID & ", " & .Column(1, i) & " " & iSubTests & ", " & iSubLength
For w = 1 To iSubLoops
'increment testing sub period end date
dCSPEnd = DateAdd("d", (iSubLength * 7) - 1, dCSPStart)
't = 1
t = DCount("*", "tblClientScreen", "CD_ID = " & CD_ID & " AND (CS_Date Between #" & dCSPStart & "# AND #" & dCSPEnd & "#)")
' Debug.Print " Week " & w & " - " & dCSPStart & " through " & dCSPEnd
Do While t < iSubTests
dTestDate = #1/1/1900#
'DO LOOP generates random day within the sub period
Do Until dTestDate > #1/1/1900#
Randomize
iRandomDays = Int((((iSubLength * 7) - 1) - 0 + 1) * Rnd + 0)
dTestDate = DateAdd("d", iRandomDays, dCSPStart)
'Debug.Print " " & dTestDate
If Weekday(dTestDate) = 1 And iTestSun <> -1 Then
'Debug.Print " invalid sunday date " & dTestDate
dTestDate = #1/1/1900#
ElseIf Weekday(dTestDate) = 7 And iTestSat <> -1 Then
'Debug.Print " invalid saturday date " & dTestDate
dTestDate = #1/1/1900#
Else
If DCount("*", "tblClientScreen", "CD_ID = " & CD_ID & " AND CS_Date = #" & dTestDate & "#") > 0 Then
'Debug.Print " test already exists on this date" & dTestDate
dTestDate = #1/1/1900#
End If
End If
If dTestDate > #1/1/1900# Then 'schedule screens
sSQL = "INSERT INTO tblClientScreen ("
sSQL = sSQL & "CD_ID, "
sSQL = sSQL & "DS_ID, "
sSQL = sSQL & "CS_Date"
sSQL = sSQL & ") VALUES ("
sSQL = sSQL & CD_ID & ", "
sSQL = sSQL & cboPeriod & ", "
sSQL = sSQL & "#" & dTestDate & "#"
sSQL = sSQL & ")"
'Debug.Print " Adding test on " & dTestDate
'Debug.Print sSQL
db.Execute sSQL
t = t + 1 'increment number of tests scheduled
End If
Loop
Loop
'increment testing sub period start date
dCSPStart = DateAdd("d", 1, dCSPEnd)
Next w
Next i
End With
'requery listboxes
RequeryListBoxes
Set db = Nothing
End Function