VBA Help

A

alliandrina

Registered User.
Local time
Yesterday, 19:35
Joined
Mar 9, 2011
Messages
13
I have a db that I wasn't the one who wrote. I'm actually pretty much a noob at this. Up until recently one of the forms had a bound list box. When I changed it to an unbound list box, the selections stopped being recorded. I know its possible to record those selections still because there is another form with an unbound list box on it.
The code for that vba is;
Code: 
Option Compare Database
Option Explicit
 
Private Sub cmdCancelEval_Click()
    If MsgBox("Are you sure you want to cancel? You will have to completely " & _
              "re-enter ALL responses if you Cancel.", vbYesNo, "Confirm Cancellation...") = _
              vbYes Then
        booCancelEval = True
        DoCmd.Close
    End If
End Sub
 
Private Sub Form_Current()
    Me.lstChoices.Requery
End Sub
 
Private Sub Form_Open(Cancel As Integer)
    Me.lstChoices.Requery
End Sub
 
Private Sub cmdNextQuestion_Click()
    On Error GoTo Err_cmdNextQuestion_Click
 
    If SelectionMade() Then
        If CheckForOther() Then
            If Nz(Len(Me.txtOther), 0) = 0 Then
                MsgBox "If you select Other, you must make an entry for this category.", _
vbOKOnly , "No 'Other' Entry Made..."
                Me.txtOther.SetFocus
                Exit Sub
            Else
                Dim strSQL As String
                strSQL = "INSERT INTO tblTEMPSurveyLongResponse ( SurveyRespID, LongResponse ) "
                strSQL = strSQL & "SELECT tblTEMPSurveyResponses.SurveyRespID, '"
                strSQL = strSQL & Me.txtOther & "' AS Expr1 FROM tblTEMPSurveyResponses "
                strSQL = strSQL & "WHERE (((tblTEMPSurveyResponses.SubjChoiceID)=56));"
 
                DoCmd.SetWarnings False
                DoCmd.RunSQL strSQL
                DoCmd.SetWarnings True
 
                Me.txtOther = Null
                Me.txtOther.Visible = False
 
            End If
        End If
 
        DoCmd.GoToRecord , , acNext
 
        Dim i As Integer
        For i = 0 To Me.lstChoices.ListCount
            Me.lstChoices.Selected(i) = False
        Next i
 
        Me.txtOther = Null
 
    Else
        MsgBox "Each question must be completed first.", vbOKOnly, "Please Respond..."
    End If
 
Exit_cmdNextQuestion_Click:
    Exit Sub
Err_cmdNextQuestion_Click:
    If Err.Number = 2105 Then
 
        If MsgBox("Last question completed. Ready to move to the next section?", vbYesNo, _
                  "Section Complete...") = vbYes Then
 
            DoCmd.Close
 
        Else
            MsgBox "Click -> again to move to next section.", vbOKOnly, "Continue When Ready..."
        End If
 
    Else
        MsgBox Err.Descrption
    End If
 
    Resume Exit_cmdNextQuestion_Click
 
End Sub
 
 
Private Function SelectionMade() As Boolean
    Dim X As Integer
 
    For X = 0 To Me.lstChoices.ListCount
        If Me.lstChoices.Selected(X) = True Then
            SelectionMade = True
            Exit Function
        End If
    Next X
 
    SelectionMade = False
End Function
 
Private Sub lstChoices_Click()
    Call AddRemoveChoices
    Me.txtOther.Visible = CheckForOther()
    If CheckForOther() Then Me.txtOther.SetFocus
End Sub
 
Private Sub AddRemoveChoices()
    Dim X As Integer
    Dim strSQL As String
    Dim strwhere As String
    Dim strIDs As String
 
    strSQL = "DELETE tblTEMPSurveyResponses.*, tblTEMPSurveyResponses.SurveySubjID, "
    strSQL = strSQL & "tblTEMPSurveyResponses.SubjChoiceID FROM tblTEMPSurveyResponses "
 
    strwhere = "WHERE tblTEMPSurveyResponses.SurveySubjID=" & Me.SurveySubjID
    strwhere = strwhere & " AND tblTEMPSurveyResponses.SubjChoiceID In ("
 
    For X = 0 To Me.lstChoices.ListCount
        If Me.lstChoices.Selected(X) = False And Nz(Len(Me.lstChoices.Column(0, X)), 0) > 0 Then
            strIDs = strIDs & Me.lstChoices.Column(0, X) & ","
        End If
    Next X
 
    If Nz(Len(strIDs), 0) > 0 Then
        strIDs = Left(strIDs, Len(strIDs) - 1)
    End If
 
    If Nz(Len(strIDs), 0) > 0 Then
        DoCmd.SetWarnings False
        DoCmd.RunSQL strSQL & strwhere & strIDs & ");"
        DoCmd.SetWarnings True
    End If
 
    strSQL = "INSERT INTO tblTEMPSurveyResponses ( ClassID, SurveySubjID, SurveyID, ParticipantTypeID, StudentID, "
    strSQL = strSQL & "SchooliD, SubjChoiceID ) SELECT " & Forms!TeacherSurvey.cboClass & " AS "
    strSQL = strSQL & "Expr2, " & Me.SurveySubjID & " AS Expr1, " & Forms!TeacherSurvey.cboSurveys & " AS "
    strSQL = strSQL & "Expr3, " & Forms!TeacherSurvey.cboPt & " AS Expr4, " & Forms!TeacherSurvey.cboStudent & " AS "
    strSQL = strSQL & "Expr5, " & Forms!TeacherSurvey.cboSchool & " As Expr6, SubjectChoiceID FROM tblSubjectChoices "
 
 
    strwhere = "WHERE tblSubjectChoices.SubjectChoiceID In ("
 
    strIDs = ""
 
    For X = 0 To Me.lstChoices.ListCount
        If Me.lstChoices.Selected(X) = True And Nz(Len(Me.lstChoices.Column(0, X)), 0) > 0 Then
            strIDs = strIDs & Me.lstChoices.Column(0, X) & ","
        End If
    Next X
 
    If Nz(Len(strIDs), 0) > 0 Then
        strIDs = Left(strIDs, Len(strIDs) - 1)
    End If
 
    If Nz(Len(strIDs), 0) > 0 Then
        DoCmd.SetWarnings False
        DoCmd.RunSQL strSQL & strwhere & strIDs & ");"
        DoCmd.SetWarnings True
    End If
 
End Sub
 
Private Function CheckForOther() As Boolean
    Dim X As Integer
    For X = 0 To Me.lstChoices.ListCount
        If Left(Me.lstChoices.Column(1, X), 7) = "Other (" And Me.lstChoices.Selected(X) Then
            CheckForOther = True
            Exit Function
        End If
    Next X
    CheckForOther = False
End Function
 
I think its the part in blue that causes it to be read and stored, but I could be wrong. i have tried to change the other list box    's vba using this as a basis and here it is:
 
Option Compare Database
Option Explicit
 
Private Sub cmdCancelEval_Click()
    If MsgBox("Are you sure you want to cancel? You will have to completely " & _
              "re-enter ALL responses if you Cancel.", vbYesNo, "Confirm Cancellation...") = _
              vbYes Then
        booCancelEval = True
        DoCmd.Close
    End If
End Sub
 
Private Sub Form_Current()
    Me.SubjChoiceID.Requery
End Sub
 
Private Sub Form_Open(Cancel As Integer)
    Me.SubjChoiceID.Requery
End Sub
 
Private Sub cmdPreviousQuestion_Click()
    On Error GoTo Err_cmdPreviousQuestion_Click
 
    DoCmd.GoToRecord , , acPrevious
 
Exit_cmdPreviousQuestion_Click:
    Exit Sub
 
Err_cmdPreviousQuestion_Click:
    If Err.Number = 2105 Then
        MsgBox "First question. Can't move to the previous one.", vbOKOnly, _
"Beginning of survey..."
    Else
        MsgBox Err.Description
    End If
 
    Resume Exit_cmdPreviousQuestion_Click
 
End Sub
 
Private Sub cmdNextQuestion_Click()
    On Error GoTo Err_cmdNextQuestion_Click
 
    If SelectionMade() Then
 
        DoCmd.GoToRecord , , acNext
 
        Dim i As Integer
        For i = 0 To Me.SubjChoiceID
            Me.SubjChoiceID.Selected(i) = True
        Next i
 
    Else
        MsgBox "Each question must be completed first.", vbOKOnly, "Please Respond..."
    End If
 
Exit_cmdNextQuestion_Click:
    Exit Sub
 
Err_cmdNextQuestion_Click:
    If Err.Number = 2105 Then
 
        If MsgBox("Last question completed. Ready to finish the survey?", vbYesNo, _
                  "Survey Complete...") = vbYes Then
            DoCmd.Close
 
            MsgBox "Thank you for your feedback!", vbOKOnly, "Thank You!!"
        Else
            MsgBox "Click -> again to move to finish.", vbOKOnly, "Finish When Ready..."
        End If
 
    Else
        MsgBox Err.Description
    End If
 
    Resume Exit_cmdNextQuestion_Click
 
End Sub
 
Private Function SelectionMade() As Boolean
    Dim X As Integer
 
    For X = 0 To Me.SubjChoiceID
        If Me.SubjChoiceID.Selected(X) = True Then
            SelectionMade = True
            Exit Function
        End If
    Next X
 
    SelectionMade = False
End Function
 
Private Sub SubjChoiceID_Click()
    Call AddRemoveChoices
    If SelectionMade() Then Me.SubjChoiceID.SetFocus
End Sub
 
Private Sub AddRemoveChoices()
    Dim X As Integer
    Dim strSQL As String
    Dim strwhere As String
    Dim strIDs As String
 
 
    strSQL = "INSERT INTO tblTEMPSurveyResponses ( ClassID, SurveySubjID, SurveyID, ParticipantTypeID, StudentID, "
    strSQL = strSQL & "SchooliD, SubjChoiceID ) SELECT " & Forms!TeacherSurvey.cboClass & " AS "
    strSQL = strSQL & "Expr2, " & Me.SurveySubjID & " AS Expr1, " & Forms!TeacherSurvey.cboSurveys & " AS "
    strSQL = strSQL & "Expr3, " & Forms!TeacherSurvey.cboPt & " AS Expr4, " & Forms!TeacherSurvey.cboStudent & " AS "
    strSQL = strSQL & "Expr5, " & Forms!TeacherSurvey.cboSchool & " As Expr6, SubjectChoiceID FROM tblSubjectChoices "
 
 
    strwhere = "WHERE tblSubjectChoices.SubjectChoiceID In ("
 
    strIDs = ""
 
    For X = 0 To Me.SubjChoiceID
        If Me.SubjChoiceID.Selected(X) = True And Nz(Len(Me.SubjChoiceID.Column(0, X)), 0) > 0 Then
            strIDs = strIDs & Me.SubjChoiceID(0, X) & ","
        End If
    Next X
 
    If Nz(Len(strIDs), 0) > 0 Then
        strIDs = Left(strIDs, Len(strIDs) - 1)
    End If
 
    If Nz(Len(strIDs), 0) > 0 Then
        DoCmd.SetWarnings False
        DoCmd.RunSQL strSQL & strwhere & strIDs & ");"
        DoCmd.SetWarnings True
    End If
 
End Sub

Of course it isn't working. And I was hoping that someone could give me some advice on how to get it to work. Thanks in advance.
 
Last edited by a moderator:
What I mean by that it isn't working, is that the code isn't save the selection code for the item in the list box. (I hope I made some sort of sense) I'll defnitely look at the link you suggested. Thanks
 
alliandrina said:
What I mean by that it isn't working, is that the code isn't save the selection code for the item in the list box.
Click to expand...

All right, then specifically there I would suggest...

Start by adding a break point just ahead of the control's value getting read. Make sure where ever the value needs to end up actually receives the value successfully.

A break point will allow you to do stepped execution of the code... line - by - line.

Then once that is verified, next trace the path of that value all the way to where it is suppose to be getting stored in a table.
 
Thanks mdlueck. I am guessing that anything that the breakpoint doesn't stop at is what is important or not working? if so it skipped the purpled lines....

If Me.SubjChoiceID.Selected(X) = True And Nz(Len(Me.SubjChoiceID.Column(0, X)), 0) > 0 Then
strIDs = strIDs & Me.SubjChoiceID(0, X) & ","
End If
Next X

If Nz(Len(strIDs), 0) > 0 Then
strIDs = Left(strIDs, Len(strIDs) - 1)
End If

If Nz(Len(strIDs), 0) > 0 Then
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL & strwhere & strIDs & ");"
DoCmd.SetWarnings True
End If
 
If it skipped the purple lines then all of the If/Then tests failed. Did you try hovering over them to see what value they contained? Or:

http://www.baldyweb.com/Debugging.htm

using the "?" technique in the Immediate window.
 
pbaldy- I'm not really sure if I used the immediate right, but I put in me.subjchoiceID and it came up with "variable not yet created in this context"

I finally got something to come up on the hovering bit too.
On "For x=0 to me.subjchoiceid" i got a pop window saying that subjchoiceid=15
at "if me.subjchoiceid.selected(x)" i got that subjchoiceid=0
me.subjchoiceid.column(0,x) came up with 15 one time and 2 another time.
the following me.subjchoiceid(0,x) came up with a type mismatch

the other lines show that strids = ""
 
alliandrina said:
but I put in me.subjchoiceID and it came up with "variable not yet created in this context"
Click to expand...

Perhaps you were not stopped in the correct "Me" context for subjchoiceID to be a valid variable name.

You may also find helpful the Watches window which will peek inside variables to show you the value. Be sure when setting up a watch to define the watch scope correctly. For example, if the variable is defined at the Form level, then set it to be watched on that Form (module) for all procedures.

To add a watch, select over the variable name in the code window you want to place the watch on, right click, and choose "Add Watch...".
 
To be honest, even with the watch, I'm not sure what to do with what I see. I did compare the newer code with the older code and found a couple things I missed and was able to get rid of the type mismatch. I ran breakpoints and compared the two to see if there was a any difference. The only thing I noticed is that me.subjChoice always retains the value of "15" while in the original code it tends to be null. I don't know that's important or not. Here is the slightly newer code

Private Sub AddRemoveChoices()
Dim X As Integer
Dim strSQL As String
Dim strwhere As String
Dim strIDs As String
For X = 0 To Me.SubjChoiceID.ListCount
If Me.SubjChoiceID.Selected(X) = False And Nz(Len(Me.SubjChoiceID.Column(0, X)), 0) > 0 Then
strIDs = strIDs & Me.SubjChoiceID.Column(0, X) & ","
End If
Next X
If Nz(Len(strIDs), 0) > 0 Then
strIDs = Left(strIDs, Len(strIDs) - 1)
End If
If Nz(Len(strIDs), 0) > 0 Then
DoCmd.SetWarnings False
DoCmd.SetWarnings True
End If
strSQL = "INSERT INTO tblTEMPSurveyResponses ( ClassID, SurveySubjID, SurveyID, ParticipantTypeID, StudentID, "
strSQL = strSQL & "SchooliD, SubjChoiceID ) SELECT " & Forms!TeacherSurvey.cboClass & " AS "
strSQL = strSQL & "Expr2, " & Me.SurveySubjID & " AS Expr1, " & Forms!TeacherSurvey.cboSurveys & " AS "
strSQL = strSQL & "Expr3, " & Forms!TeacherSurvey.cboPt & " AS Expr4, " & Forms!TeacherSurvey.cboStudent & " AS "
strSQL = strSQL & "Expr5, " & Forms!TeacherSurvey.cboSchool & " As Expr6, SubjectChoiceID FROM tblSubjectChoices "

strwhere = "WHERE tblSubjectChoices.SubjectChoiceID In ("
strIDs = ""
For X = 0 To Me.SubjChoiceID.ListCount
If Me.SubjChoiceID.Selected(X) = True And Nz(Len(Me.SubjChoiceID.Column(0, X)), 0) > 0 Then
strIDs = strIDs & Me.SubjChoiceID.Column(0, X) & ","
End If
Next X
If Nz(Len(strIDs), 0) > 0 Then
strIDs = Left(strIDs, Len(strIDs) - 1)
End If
If Nz(Len(strIDs), 0) > 0 Then
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL & strwhere & strIDs & ");"
DoCmd.SetWarnings True
End If
 
You must log in or register to reply here.

Similar threads

mike60smart
Syntax
Replies
8
Views
439
Mark_
M
C
Problem with 'Like' SQL filter
Replies
6
Views
195
Josef P.
J
C
Module variable
Replies
9
Views
464
Pat Hartman
P
N
Solved How to update a currentstock control in the subform after a requery from the parent form
Replies
16
Views
761
Mark_
M
T
Can someone please assist with the VBA code Below - Error Message 3075
Replies
16
Views
989
CJ_London
C

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom