Results 1 to 9 of 9
  1. #1
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,442

    right click context menu

    I've mucked around with right click context menus in the past but this time I've been stumped, I'm still looking for an answer but so far no luck.



    Here's a stripped down version:

    RandomScreener.zip

    Open the form frmCalendar.

    Right click the list box on the far right hand side (lstClient)

    The correct context menu comes up (shows the name in the right click context menu)

    Right click any other item in that same list box and the correct context menu keeps coming up

    Now if you click 'Find all screens for XXX' where XXX is the name the scheduled items for that person will be highlighted in the calendar lists.

    now right click the lstClient on any other person and the context menu shows the last person clicked on the FIRST CLICK only, if you right click the same person two times in a row the correct context menu comes back up but for the life of me I'm not able to find out where I am screwing up in the code.

    Be my hero and find my error!

  2. #2
    June7's Avatar
    June7 is offline VIP
    Windows 7 64bit Access 2010 32bit
    Join Date
    May 2011
    Location
    The Great Land
    Posts
    52,815
    I have to ask - Why? Are you going to provide other options in the menu?

    Get the same behavior if click Cancel.

    In my test: right click P3Test > click menu > right click P1Test and menu still shows P3 > right click P2Test and shows P2Test
    Second click anywhere recovers the menu.

    When I set a breakpoint and step through the CreateCustClientMenu procedure it works properly.

    I tried a timer with DoEvents and that didn't help. Sorry, don't know how to fix.
    How to attach file: http://www.accessforums.net/showthread.php?t=70301 To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.

  3. #3
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,442
    there's going to be a double click event on the day list boxes, there's going to be a double click event on the lstclient list as well, I was trying to make this form as buttonless as possible but these context menus are giving me fits because I don't want them to be static.

    EDIT sorry, didn't answer your very first question, yes, there are going to be other options on the right click menu of the lstclient at the very least and quite possibly the daily list boxes as well.

  4. #4
    amrut is offline Expert
    Windows 7 64bit Access 2010 32bit
    Join Date
    Jun 2012
    Location
    Dubai
    Posts
    614
    Here is the solution -
    Use the click event of list box and add a parameter to provide the required caption
    Code:
    Private Sub lstClient_Click()
    Call ClickMenuClient(btn, Screen.ActiveControl.Name, Me.lstClient.Column(1))
    End Sub
    Declare a variable btn as integer and get its value from mousedownevent to detect rightclick
    Code:
    Private Sub lstClient_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    btn = Button
    
    End Sub
    
    
    
    Function ClickMenuClient(Button, scontrolname, strCAp As String)
    DoEvents
    If Button = acRightButton Then
        CreateCustClientMenu (strCAp)
        CommandBars("ClientRightClickMenu").ShowPopup
    Else
    
    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
    Does it work?

  5. #5
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,442
    No that didn't work here. I thought the part that might help was to force a doevents on the mousedown but that didn't help either.

    I'm curious if you got it working with the code you show amrut because I do not see how it works in passing the btn variable from the mousedown event to the lstClient_Click event.

    I think I understand what you're trying to say in that the value of lstClient isn't 'updated' for lack of a better word in either the mouse up or mouse down event and that if I want my context menu to reflect the current contents of lstClient I have to have it in the CLICK event.

    In your example code I think that's what you're trying to do with btn = Button but I don't see how you're making that a variable you can call in one of the other functions (the click event of lstClient).

  6. #6
    amrut is offline Expert
    Windows 7 64bit Access 2010 32bit
    Join Date
    Jun 2012
    Location
    Dubai
    Posts
    614
    I think I understand what you're trying to say in that the value of lstClient isn't 'updated' for lack of a better word in either the mouse up or mouse down event and that if I want my context menu to reflect the current contents of lstClient I have to have it in the CLICK event.
    I tested the listindex property which returned the correct row in case of OnClick event.
    There was a copy paste mistake with respect to the btn variable. Below is the form's complete module which is working in my case -
    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

  7. #7
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,442
    Amrut, you are a gem, thanks very much. This does exactly what I need.

  8. #8
    rpeare is offline VIP
    Windows XP Access 2003
    Join Date
    Jul 2011
    Posts
    5,442
    Amrut I have tried to apply this principle to the 'day' list boxes as well and it works fine if there is data in the list box already, however, if there is nothing the on click event of the list box never fires off. Is there a way to have the click event of a list box process even if there are no values in the list box to start?

    I can capture the control name and the button value on the mousedown of the 'day' listboxes but nothing happens in the on click event if there are no values in the list box (at least with the variations I have tried thus far).

  9. #9
    June7's Avatar
    June7 is offline VIP
    Windows 7 64bit Access 2010 32bit
    Join Date
    May 2011
    Location
    The Great Land
    Posts
    52,815
    Maybe have an empty string row in the listbox RowSource and have code select that row when the form opens.
    How to attach file: http://www.accessforums.net/showthread.php?t=70301 To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Simple right-click menu example
    By pkstormy in forum Code Repository
    Replies: 1
    Last Post: 02-03-2015, 06:49 PM
  2. Copy and Paste in right click menu
    By chriscardwell06 in forum Access
    Replies: 1
    Last Post: 12-27-2013, 09:15 AM
  3. Replies: 3
    Last Post: 04-19-2013, 07:09 AM
  4. On click menu items do not work
    By mrk68 in forum Access
    Replies: 1
    Last Post: 03-23-2009, 07:29 PM
  5. Click menu dish to show it's ingredients
    By elfsareus in forum Access
    Replies: 7
    Last Post: 12-16-2008, 10:10 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums