Good afternoon,
My dilemma has to do with getting a sort to “stick”.
Here’s what I have:
The code for the move up/down buttons: (FYI, I tried indenting the code below but keep getting a
The code for the checkbox control:
All of the above code works well. However, here’s the problem I have been trying to fix/find a work-around and cannot:
1 Bulb
2 Trim piece
3 Cup holder
5 Arm rest
I appreciate the consideration in reading this post and any feedback I absolutely welcome.
Many thanks.
My dilemma has to do with getting a sort to “stick”.
Here’s what I have:
- A table with 3 columns: ID/PK field – PRINTORDER – PART
- A form that displays the record for each part
- A Listbox control in the form with 3 columns (same as first bullet point) the ID field being hidden of course.
- Two command buttons next to the listbox: One, moves up the selected part and the other moves the selected part down.
- A checkbox control in the same form. When checked, it adds the name of that part to the listbox control.
The code for the move up/down buttons: (FYI, I tried indenting the code below but keep getting a
tag so I removed it)
Code:
Private Sub MoveDownBtn_Click()
On Error GoTo errHandler
Me.SelectedPartsList.SetFocus
Call MoveUpDown(1)
Exit Sub
errHandler:
MsgBox "The following error has occurred: " & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbCritical, "Error - " & APPNAME
End Sub
Code:
Private Sub MoveUpBtn_Click()
On Error GoTo errHandler
Me.SelectedPartsList.SetFocus
Call MoveUpDown(-1)
Exit Sub
errHandler:
MsgBox "The following error has occurred: " & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbCritical, "Error - " & APPNAME
End Sub
Code:
Private Sub MoveUpDown(value As Integer)
Dim newpos As Long
Dim oldpos As Long
Dim ok As Boolean
Dim index As Long
On Error GoTo errHandler
If Me.SelectedPartsList.ListIndex = -1 Then
'Do nothing. Nothing is selected.
Else
If value = -1 Then 'move up
If Me.SelectedPartsList.ListIndex <> 0 Then
index = Me.SelectedPartsList.ListIndex - 1
oldpos = Me.SelectedPartsList.Column(1, Me.SelectedPartsList.ListIndex)
newpos = Me.SelectedPartsList.Column(1, index)
ok = True
End If
Else 'move down
If Me.SelectedPartsList.ListIndex <> Me.SelectedPartsList.ListCount - 1 Then
index = Me.SelectedPartsList.ListIndex + 1
oldpos = Me.SelectedPartsList.Column(1, Me.SelectedPartsList.ListIndex)
newpos = Me.SelectedPartsList.Column(1, index)
ok = True
End If
End If
If ok Then
DBEngine(0)(0).Execute "UPDATE PARTS_T SET PrintOrder=9999 " & _
"WHERE PrintOrder = " & newpos & ";"
DBEngine(0)(0).Execute " UPDATE PARTS_T SET PrintOrder= " & newpos & " " & _
"WHERE PrintOrder = " & oldpos & ";"
DBEngine(0)(0).Execute " UPDATE PARTS_T SET PrintOrder= " & oldpos & " " & _
"WHERE PrintOrder = 9999" & ";"
Me.SelectedPartsList.Requery
Me.SelectedPartsList = Me.SelectedPartsList.ItemData(index)
End If
End If
Exit Sub
errHandler:
MsgBox "The following error has occurred: " & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbCritical, "Error - " & APPNAME
End Sub
The code for the checkbox control:
Code:
Private Sub ADDPART_AfterUpdate()
Dim dbs As DAO.Database, Rst As DAO.Recordset
Dim SQL As String
On Error GoTo errHandler
If Me.Dirty Then Me.Dirty = False
Set dbs = CurrentDb
'ADD PARTS CHECKED
If ADDPART.value = True Then
Set Rst = dbs.OpenRecordset("PARTS_T", dbOpenDynaset)
Rst.FindFirst "[PARTID] =" & Me![PARTID]
If Not Rst.NoMatch Then
Cancel = True
MsgBox "The part: " & Chr(34) & Me.PARTTITLE & Chr(34) & " is currently part of your list.", vbExclamation, "Duplicate Part"
ADDPART.value = False
Exit Sub
End If
Set rst = dbs.OpenRecordset("PARTS_T", dbOpenDynaset)
If Not Rst.EOF Then Rst.MoveLast
SQL = "INSERT INTO PARTS_T ([PRINTORDER], [PART_TITLE], [PARTID]) VALUES (" & Rst.RecordCount + 1 & "," & Chr(34) & Me.PARTTITLE & Chr(34) & "," & Me.PARTID & ");"
RunSQLCode SQL
'ADD PARTS UNCHECKED
Else
‘Delete the selected part from the listbox.
SQL = "DELETE FROM PARTS_T WHERE [PART_TITLE]=" & Chr(34) & Me.PARTTITLE & Chr(34) & " AND [PARTID]=" & Me.PARTID
RunSQLCode SQL
Set Rst = dbs.OpenRecordset("PARTS_T", dbOpenDynaset)
If Not rst.EOF Then
Do
Rst.Edit
Rst![PRINTORDER] = Rst.AbsolutePosition + 1
Rst.Update
Rst.MoveNext
Loop Until Rst.EOF
End If
End If
'Clean up
Set rs = Nothing
Set Rst = Nothing
Set dbs = Nothing
Me.SelectedPartsList.Requery
Exit Sub
errHandler:
MsgBox "The following error has occurred: " & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbCritical, "Error - " & APPNAME
End Sub
All of the above code works well. However, here’s the problem I have been trying to fix/find a work-around and cannot:
- As I use the up/down buttons to move my parts in the listbox control the above code also moves the parts accordingly in the PARTS_T table – all good. But;
- If I want to remove any part from the listbox control by UNchecking the checkbox control to that part, my list gets completely rearranged.
- Bulb
- Trim piece
- Cup holder
- Arm rest
- Head rest
- Cup holder
- Arm rest
- Bulb
- Trim piece
1 Bulb
2 Trim piece
3 Cup holder
5 Arm rest
I appreciate the consideration in reading this post and any feedback I absolutely welcome.
Many thanks.