I hadn't written an example of this before, so I took a moment now to do
it. Set your list box's RowSource property to this:
SELECT ElementID, ElementName, ElementOrder
FROM tblElements
ORDER BY tblElements.ElementOrder;
Name your "Up" and "Down" buttons "cmdMoveUp" and "cmdMoveDown",
respectively.
Now add the following event procedures to your form's class module:
'----- start of code -----
Private Sub cmdMoveDown_Click()
On Error GoTo Err_Handler
Dim lngCurrItem As Long
Dim lngCurrOrder As Long
Dim lngCurrRow As Long
Dim lngNextItem As Long
Dim lngNextOrder As Long
Dim lngNextRow As Long
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim fInTrans As Boolean
With Me.lboElement
If IsNull(.Value) Then
DoCmd.Beep
Exit Sub
End If
lngCurrRow = .ItemsSelected(0)
If lngCurrRow = (.ListCount - 1) Then
DoCmd.Beep
Exit Sub
End If
lngCurrItem = .Value
lngCurrOrder = .Column(2)
lngNextRow = lngCurrRow + 1
lngNextItem = .ItemData(lngNextRow)
lngNextOrder = .Column(2, lngNextRow)
Set ws = DBEngine.Workspaces(0)
Set db = ws.Databases(0)
ws.BeginTrans
fInTrans = True
db.Execute _
"UPDATE tblElements SET ElementOrder = " & lngNextOrder & _
" WHERE ElementID = " & lngCurrItem, _
dbFailOnError
db.Execute _
"UPDATE tblElements SET ElementOrder = " & lngCurrOrder & _
" WHERE ElementID = " & lngNextItem, _
dbFailOnError
ws.CommitTrans
.Requery
End With
Exit_Point:
On Error Resume Next
If fInTrans Then
ws.Rollback
End If
Set db = Nothing
Set ws = Nothing
Exit Sub
Err_Handler:
MsgBox Err.Description, vbExclamation, "Error " & Err.Number
Resume Exit_Point
End Sub
Private Sub cmdMoveUp_Click()
On Error GoTo Err_Handler
Dim lngCurrItem As Long
Dim lngCurrOrder As Long
Dim lngCurrRow As Long
Dim lngPrevItem As Long
Dim lngPrevOrder As Long
Dim lngPrevRow As Long
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim fInTrans As Boolean
With Me.lboElement
If IsNull(.Value) Then
DoCmd.Beep
Exit Sub
End If
lngCurrRow = .ItemsSelected(0)
If lngCurrRow = 0 Then
DoCmd.Beep
Exit Sub
End If
lngCurrItem = .Value
lngCurrOrder = .Column(2)
lngPrevRow = lngCurrRow - 1
lngPrevItem = .ItemData(lngPrevRow)
lngPrevOrder = .Column(2, lngPrevRow)
Set ws = DBEngine.Workspaces(0)
Set db = ws.Databases(0)
ws.BeginTrans
fInTrans = True
db.Execute _
"UPDATE tblElements SET ElementOrder = " & lngPrevOrder & _
" WHERE ElementID = " & lngCurrItem, _
dbFailOnError
db.Execute _
"UPDATE tblElements SET ElementOrder = " & lngCurrOrder & _
" WHERE ElementID = " & lngPrevItem, _
dbFailOnError
ws.CommitTrans
.Requery
End With
Exit_Point:
On Error Resume Next
If fInTrans Then
ws.Rollback
End If
Set db = Nothing
Set ws = Nothing
Exit Sub
Err_Handler:
MsgBox Err.Description, vbExclamation, "Error " & Err.Number
Resume Exit_Point
End Sub
'----- end of code -----
NOTE: the above code assumes that the list box has its ColumnHeads
property set to No. If you're displaying column heads in the list box,
a couple of minor changes have to be made to the code.
--
Dirk Goldgar, MS Access MVP
www.datagnostics.com
(please reply to the newsgroup)