• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 583
  • Last Modified:

vba multi select listbox bug

I have 4 multi-select listboxes on a form. There is a random issue that causes the Listbox change event to fire 2 or 3 times when an item is clicked. This only happens on the first item and then it leaves that item unselected. Has anyone experienced this or have any workarounds. I only want the event to fire once when I select an item.
0
rdmstrs1
Asked:
rdmstrs1
  • 4
  • 3
1 Solution
 
Rick_RickardsCommented:
There are several things that could cause this.  First, are these list boxes on one form or in parent and sub forms?

Could you post the code and events that you use to update the list boxes when they are selected.
0
 
rdmstrs1VP, TechnologyAuthor Commented:
They are on one form.
Here is the change event for one of the listboxes that has this issue as well as the sub's that are called within the event(s):
Private Sub DiagLB_Change()
    Dim pos As Integer
    pos = CPDdlg.DiagLB.ListIndex
If pos <> DiagLBPrevIndex Or (Now() - LBBugTime) > 0.5 Then
    Dim dpd As New ProcPopupDLG
    Call OtherCheck(DiagLB, UBound(diagListA), "Diagnosis", diagListA, SelDiagLevA, DiagLevelA)
    If OtherFlag = False Then
        Call dpd.Popup(DiagLevelA(pos), SelDiagLevA(pos), Empty, Empty)
        DiagLevelA(pos) = dpd.mItemListA
        SelDiagLevA(pos) = dpd.mSelListA
    End If
Else
    MsgBox ("Bug Occured")
    Debug.Print "Bug occured in DiagLB, pos = " & pos & "; PrevIndex = " & DiagLBPrevIndex
End If
LBBugTime = Now()
DiagLBPrevIndex = pos
    'MsgBox (CStr(BugTime))
End Sub
Sub OtherCheck(LB, OtherIndex, Desc, ItemArr, subSelArr, subItemArr)
Dim i As Integer
OtherFlag = False
'Loop thru to find listindex of other
    For i = 0 To LB.ListCount - 1
        If LB.List(i) = "Other" Then
            OtherIndex = i
        End If
    Next
If LB.ListIndex >= OtherIndex And LB.Selected(LB.ListIndex) Then
    Dim var1 As String
    If LB.List(LB.ListIndex) = "Other" Then
       var1 = InputBox("Other " & Desc & ":", Desc, "")
       OtherFlag = True
        If var1 <> "" Then
            LB.List(LB.ListIndex) = var1
            LB.AddItem "Other"
            Call addOthertoArr(ItemArr, var1, subItemArr, subSelArr)
        Else
        End If
    End If
End If
End Sub
 
Sub addOthertoArr(ItemArr, OtherString, subItemArr, subSelArr)
Dim TopofArr As Integer
 
If Not IsEmpty(ItemArr) Then
TopofArr = UBound(ItemArr)
ReDim Preserve ItemArr(TopofArr + 1)
ItemArr(TopofArr) = OtherString
ReDim Preserve subSelArr(UBound(ItemArr))
subSelArr(UBound(subSelArr)) = Empty
ReDim Preserve subItemArr(UBound(ItemArr))
subItemArr(UBound(subItemArr)) = Empty
End If
End Sub
 
Public Sub Popup(ItemListA As Variant, SelListA As Variant, _
                subListA As Variant, subSelListA As Variant)
    Me.testInt = Me.testInt + 1
    Dim n As Integer
    Me.mItemListA = Empty
    Me.mSelListA = Empty
    Me.mSubListA = Empty
    Me.mSubSelListA = Empty
    Me.mPreSelHackFlag = Now()
    If Not IsEmpty(ItemListA) Then
        Me.mItemListA = ItemListA
    End If
    If Not IsEmpty(SelListA) Then
        Me.mSelListA = SelListA
    End If
    If Not IsEmpty(subListA) Then
        Me.mSubListA = subListA
    End If
    If Not IsEmpty(subSelListA) Then
        Me.mSubSelListA = subSelListA
    End If
    ' verify a1 and s1 have same bounds
    If Not IsEmpty(SelListA) Then
    If UBound(Me.mItemListA) > -1 And UBound(Me.mItemListA) = UBound(Me.mSelListA) Then
        Me.mInitializing = True
        'check for length of array
 
            If UBound(Me.mItemListA) >= ListMaxI Then
                'resize form and objects
                Me.Width = 375
                Me.Height = 480
                Me.ProcPopupLB1.Height = 400
                Me.ProcPopupOKBtn.Top = 420
                Me.ProcPopupOKBtn.Left = 160
                   With Me.ProcPopupLB2
                    .Left = 185
                    .Top = 6
                    .Width = 165
                    .Height = 400
                    .ListStyle = 1
                    .Font.Bold = True
                    .Visible = True
                   End With
                Dim i As Integer
                i = 0
                    For i = 0 To UBound(Me.mItemListA)
                    If i < ListMaxI Then
                    Me.ProcPopupLB1.AddItem Me.mItemListA(i)
                    Else
                    Me.ProcPopupLB2.AddItem Me.mItemListA(i)
                    End If
                    Next
            Else
                Select Case UBound(Me.mItemListA)
                 'hard coded re-size for immune workup
                 Case 5 To 10
                 Me.Width = 375
                 Me.Height = 380
                 Me.ProcPopupLB1.Width = 300
                 Me.ProcPopupOKBtn.Left = 160
                 Case 1 To 4
                 Me.Width = 375
                 Me.Height = 180
                 Me.ProcPopupLB1.Width = 300
                 Me.ProcPopupLB1.Height = 75
                 Me.ProcPopupOKBtn.Top = 100
                 Me.ProcPopupOKBtn.Left = 160
                 'for patch test
                 Case 22
                 Me.Width = 375
                 Me.Height = 480
                 Me.ProcPopupLB1.Width = 300
                 Me.ProcPopupLB1.Height = 400
                 Me.ProcPopupOKBtn.Top = 420
                 Me.ProcPopupOKBtn.Left = 160
                 Case Else
                End Select
               For i = 0 To UBound(Me.mItemListA)
                    Me.ProcPopupLB1.AddItem Me.mItemListA(i)
               Next
            End If
'call for checking boolean value of selections
Call SelectItems(ProcPopupLB1, ProcPopupLB2, Me.mSelListA)
Debug.Print "Popup ran up until Pre-Show. LB1.Listcount = " & Me.ProcPopupLB1.ListCount
        Me.mInitializing = False
        Me.Show
    Else
    End If
    End If
End Sub
 
Sub SelectItems(LB1, LB2, selArr1)
        Dim n As Integer
        For n = 0 To UBound(selArr1)
            Dim b As Boolean
            b = selArr1(n)
        lInitializing = True
        If n >= ListMaxI Then
            LB2.Selected(n - ListMaxI) = b
            Else
            LB1.Selected(n) = b
            End If
        Next
        lInitializing = False
End Sub

Open in new window

0
 
Rick_RickardsCommented:
First off let me say I'm trying to help but there are so many issues within the code that really should be cleaned up it might be easier to take a few steps back.

Is it possible to avail the form with the list boxes and enough data to populate them and illustrate what you're trying to do.

There are much easier ways to do what I see being done here but I'll admit that not all of the objectives are clear.  Along with a sample of the form, list boxes, code, tables in the .mdb it would help to have a brief description of what you ultimately were trying to do.
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
rdmstrs1VP, TechnologyAuthor Commented:
Ok, let's see first let me give the description and then if you still want more attachments I can do that. It is a letter with 4 bookmarks. When it opens the form opens and their are 4 multi-select listboxes that populate the bookmarks based on what is selected. Each of these has an other that when selected opens an inputbox and then adds whatever is entered into the list and selects it. The arrays are hard coded on the initialize event not in a table or database. So when the other items are added it is not only added to the form but also to a matching array as well as a matching boolean array.

One of the initial listboxes also goes 3 layers deeper with choices that are attached to the initial choice thru an additional form and multi-select listbox. This also needs the same other input availability.
I hope that makes sense let me know if you need more info or to see more.
 
0
 
Rick_RickardsCommented:
The code leave so many unanswered questions I just don't know where tobegin.  I presume the 4 list boxes are named mItemListA, mSelListA, mSubListA, mSubSelListA but then I'd have to admit I'm still having to guess.  Even, to many unanswered questions remain.  The code doesn't expose any typical cookie cutter cause though I'd be shocked if the issue you're having is the only one.  There are so many things being done here that invite problems that I'd encourage you to take an offer to help if you can at all avail the materials required to help.

I'm sorry I can't offer more but I just can't take the time to rebuildwhat I think someone has at the other end knowing that when I'm done itwill most certainly not be a good replica.

Besides that, even if it was a simple as saying, fix this line, as it stands now you'd most likely end up posting another question with one of the many other issues (of which you may yet be unaware) that remain.

At the very least can you post the .mdb including the form containing the controls in questions and leave enough data for them to work as they do now.  I suggest importing only what you must into a blank database so as to minimize the distribution of anything proprietary.  As for the data, feel free to change it, data is data so what it says isn't that important for trouble shooting this issue.


0
 
rdmstrs1VP, TechnologyAuthor Commented:
OK Here is the .doc file all cleaned out. It is working, but still has the glitch that I mentioned at the top of the thread. Thanks for whatever help you are able to give on this I really appreciate it.
Letter.doc
0
 
rdmstrs1VP, TechnologyAuthor Commented:
It is a work around but essentially I added a flag and the following code to each of the listbox change events and it is now working and invisible to the user. I waited 6 days to see if there would be an attempt at another solution, but since there is not I will accept this work around as the solution.
Public ComplaintLBBugChange As Boolean
 
Private Sub ComplaintLB_Change()
Dim pos5 As Integer
    pos5 = CPDdlg.ComplaintLB.ListIndex
If pos5 <> CompLBPrevIndex Or (Now() - LBBugTime2) > 0.5 Then
Call OtherCheck(ComplaintLB, UBound(complaintListA), "Complaints", Empty, Empty, Empty)
Else
    'MsgBox ("Bug Occured")
 If ComplaintLBBugChange = False Then
    ComplaintLBBugChange = True
    ComplaintLB.Selected(pos5) = True
    ComplaintLBBugChange = False
    End If
End If

Open in new window

0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now