Solved

vba multi select listbox bug

Posted on 2008-06-25
7
555 Views
Last Modified: 2013-12-25
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
Comment
Question by:rdmstrs1
  • 4
  • 3
7 Comments
 
LVL 16

Expert Comment

by:Rick_Rickards
ID: 21950551
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
 

Author Comment

by:rdmstrs1
ID: 21953476
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
 
LVL 16

Expert Comment

by:Rick_Rickards
ID: 21955739
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
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:rdmstrs1
ID: 21956190
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
 
LVL 16

Expert Comment

by:Rick_Rickards
ID: 21960191
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
 

Author Comment

by:rdmstrs1
ID: 21974625
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
 

Accepted Solution

by:
rdmstrs1 earned 0 total points
ID: 22020099
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

Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

Join & Write a Comment

I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This Micro Tutorial well show you how to find and replace special characters in Microsoft Word. This is similar to carriage returns to convert columns of values from Microsoft Excel into comma separated lists.

707 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now