New Page 1
 本 书 经
典 内 容 赏 析 |
|
如何实现左右移动项目的列表框 |
如何实现通用的Office Xp按钮界面效果 |
|
如何编写传递多个参数给窗体和报表的函数 |
如何设计可定定义流程图的程序 |
|
如何读取使用插入对象插入的OLE字段的内容 |
通用的窗体页眉与页脚 |
|
书中其它经典内容 |
|
|
|
|
|
67
|
如何实现左右移动项目的列表框 |
适用版本：97、2000、2002、2003 |
| 人气 95％ |
难度系数 **** |
|
|
问题详述 |
| 在挑选字段、挑选人员、挑选部门、挑选地区等进行查询或打印时，都需要用到一个挑选项目的窗体，一般的习惯是从一个列表框中将项目挑选到另一个列表框中。可以进行单选、多选，可以一次挑选、全部挑选、一次移除及全部移除甚至上下移动选择项目的顺序，那么如何实现这样的功能呢？ |
|
专家解答(详细代码请参见本书内容) |
当挑选的项目数量比较多时，一般将项目储存在表中，而两个列表框的行来源分别来源两个表，而两个列表框项目的移动实际上是项目在数据表中的移动，在这里，以一个挑选人员的例子来讲解这个例子。
首先创建一个人员数据表，用来存放人员的ID、人员编码及人员名称，接着再创建两个临时数据表tblEmpListall和tblEmpList，再在窗体上创建两个列表框lstAll和lstSet，分别用来显示未选的项目和已选的项目，他们的行来源分别是来源于两个临时表tblEmpListall和tblEmpList。然后在窗体添加四个标签lblAdd、lblRemove、lblAddAll和lblRemoveAll，分别用来实现添加、删除、添加所有、删除所有的功能。最后，为窗体添加下列程序代码。 |
Option Compare Database
Option Explicit |
| '从未选列表框中添加选定项目到已选列表框中 |
Private Sub lblAdd_Click()
On Error Resume Next
Dim iCnt As Integer
Dim i As Integer
Dim varItem As Variant
Dim rstTemp As New ADODB.Recordset
Dim intMax As Integer
rstTemp.Open "select max(FSeqNo) as MaxSeqNo from tblEmpList", CodeProject.Connection, adOpenStatic, adLockReadOnly
intMax = Nz(rstTemp.Fields("MaxSeqNo")) + 1
rstTemp.Close
For Each varItem In lstAll.ItemsSelected
CodeDb.Execute "insert into tblEmpList (FEmpId, FEmpCode, FEmpName,FSeqNo) VALUES
(" & lstAll.ItemData(varItem) & ",'" & lstAll.Column(1, varItem) & "','" & lstAll.Column(2, varItem) & "'," & intMax & ")"
CodeDb.Execute "delete from tblEmpListall where FEmpId=" & lstAll.ItemData(varItem)
lstAll.Selected(varItem) = False
intMax = intMax + 1
Next
Me.Painting = False
lstSel.Requery
lstAll.Requery
iCnt = lstSel.ListCount
Me.Painting = True
End Sub |
| '从未选列表框中添加所有项目到已选列表框中 |
Private Sub lblAddAll_Click()
'On Error Resume Next
Dim iCnt As Integer
Dim i As Integer
Dim varItem As Variant
iCnt = lstAll.ListCount
Dim intMax As Integer
Dim rstTemp As New ADODB.Recordset
rstTemp.Open "select max(FSeqNo) as MaxSeqNo from tblEmpList", CodeProject.Connection, adOpenStatic, adLockReadOnly
intMax = Nz(rstTemp.Fields("MaxSeqNo")) + 1
rstTemp.Close
For i = 0 To iCnt - 1 Step 1
CodeDb.Execute "insert into tblEmpList (FEmpId, FEmpCode, FEmpName,FSeqNo) VALUES (" & lstAll.ItemData(i) & ",'" & lstAll.Column(1, i) & "','" & lstAll.Column(2, i) & "'," & intMax & ")"
CodeDb.Execute "delete from tblEmpListall where FEmpId=" & lstAll.ItemData(i)
'lstAll.Selected(i) = False
intMax = intMax + 1
Next
Me.Painting = False
lstSel.Requery
lstAll.Requery
Me.Painting = True
End Sub |
|
'从已选列表框中移除指定项目到未选列表框中 |
Private Sub lblRemove_Click()
On Error Resume Next
Dim iCnt As Integer
Dim i As Integer
Dim varItem As Variant
For Each varItem In lstSel.ItemsSelected
CodeDb.Execute "insert into tblEmpListall (FEmpId, FEmpCode, FEmpName) VALUES (" & lstSel.ItemData(varItem) & ",'" & lstSel.Column(1, varItem) & "','" & lstSel.Column(2, varItem) & "')"
CodeDb.Execute "delete from tblEmpList where FEmpId=" & lstSel.ItemData(varItem)
lstSel.Selected(varItem) = False
Next
Me.Painting = False
lstSel.Requery
lstAll.Requery
Me.Painting = True
End Sub |
|
'从已选列表框中移除所有项目到未选列表框中 |
Private Sub lblRemoveAll_Click()
'On Error Resume Next
Dim iCnt As Integer
Dim i As Integer
Dim varItem As Variant
iCnt = lstSel.ListCount
For i = 0 To iCnt - 1 Step 1
CodeDb.Execute "insert into tblEmpListall (FEmpId, FEmpCode, FEmpName) VALUES (" & lstSel.ItemData(i) & ",'" & lstSel.Column(1, i) & "','" & lstSel.Column(2, i) & "')"
CodeDb.Execute "delete from tblEmpList where FEmpId=" & lstSel.ItemData(i)
Next
Me.Painting = False
lstSel.Requery
lstAll.Requery
Me.Painting = True
End Sub |
|
'将已选项目的顺序上移 |
Private Sub lblUp_Click()
Dim preSeq As Long
Dim preId As String
Dim curSeq As Integer
Dim strid As String
Dim iCnt, i, j As Integer
Me.Painting = False
iCnt = lstSel.ListCount
For i = 0 To iCnt - 1
If lstSel.Selected(i) = True Then
If j = 0 Then
preSeq = i - 1
preId = Nz(lstSel.Column(0, preSeq))
End If
strid = strid & "" & lstSel.Column(0, i) & ","
j = j + 1
End If
Next
If strid <> "" Then
strid = Left(strid, Len(strid) - 1)
End If
If preSeq < 0 Or j < 1 Then
If j < 1 Then
MsgBox "必须先选择要移动的条件", vbExclamation, "天鸣"
lstSel.SetFocus
End If
Me.Painting = True
Exit Sub
End If
CodeDb.Execute "update tblEmpList set FSeqNo=FSeqNo-1 where FEmpId in (" & IIf(strid = "", 0, strid) & ")"
CodeDb.Execute "update tblEmpList set FSeqNo=FSeqNo+" & j & " where FEmpId =" & Nz(preId, "") & ""
lstSel.Requery
For i = 0 To iCnt - 1
lstSel.Selected(i) = False
Next
For i = 0 To j - 1
lstSel.Selected(preSeq + i) = True
Next
Me.Painting = True
lstSel.SetFocus
End Sub |
|
'将已选项目的顺序下移 |
Private Sub lblDown_Click()
Dim nextSeq As Long
Dim nextId As String
Dim curSeq As Integer
Dim strid As String
Dim iCnt, i, j As Integer
Me.Painting = False
iCnt = lstSel.ListCount
For i = 0 To iCnt - 1
If lstSel.Selected(i) = True Then
strid = strid & "" & lstSel.Column(0, i) & ","
nextSeq = i + 1
j = j + 1
End If
Next
If nextSeq > lstSel.ListCount - 1 Or j < 1 Then
If j < 1 Then
MsgBox "必须先选择要移动的条件", vbExclamation, "天鸣"
lstSel.SetFocus
End If
Me.Painting = True
Exit Sub
End If
If nextSeq <> 0 Then
nextId = lstSel.Column(0, nextSeq)
End If
If strid <> "" Then
strid = Left(strid, Len(strid) - 1)
End If
此处代码详见书中内容
..........
...........
............
..............
lstSel.Requery
If nextSeq > lstSel.ListCount - 1 Then
nextSeq = lstSel.ListCount - 1
End If
For i = 0 To iCnt - 1
lstSel.Selected(i) = False
Next
For i = 0 To j - 1
lstSel.Selected(nextSeq - i) = True
Next
Me.Painting = True
lstSel.SetFocus
End Sub
|
|
'关闭退出项目挑选窗体 |
Private Sub lblOk_Click()
If lstSel.ListCount < 1 Then
' glmessagebox "没有选择栏位, 报表将没有内容", 0
End If
DoCmd.Close
End Sub |
|
'窗体加载时设置两个列表框的内容 |
Private Sub Form_Load()
Dim strField(30) As String
Dim strLField(30, 2) As String
Dim strFldName As String
Dim strFldCaption As String
Dim strFldSource As String
Dim dblFldWidth As Double
Dim adata(30) As String
Dim bdata(30) As String
Dim dblWidth(30), dblHeight As Double
Dim ldata(30, 2) As String
Dim ctlLabel As Control, ctlText As Control
Dim ncnt As Integer
Dim i, j, k As Integer
Dim ttlWidth, Width1, firstleft As Double
Dim cYear, cMonth As String
Dim ctrTxt, ctrLbl, ctrLblB, ctrtTxt As Control
Dim sfm As Form
Dim strproce_code As String
Dim dblDiff As Double
dblDiff = 0
Me.Painting = False
On Error Resume Next
'首先清除临时表中内容
CodeDb.Execute "delete from tblEmpListall"
CodeDb.Execute "delete from tblEmpList"
Me.Caption = "选择项目"
dblHeight = sfm.RowHeight
Dim rptWidth As Double
ncnt = 0
j = 0
k = 0
此处代码详见书中内容
..........
...........
............
..............
lstAll.Requery
lstSel.Requery
Me.Painting = True
End Sub |
Private Sub lstAll_DblClick(cancel As Integer)
'在未选项目列表框中双击将激活添加项目事件
lblAdd_Click
End Sub
Private Sub lstSel_DblClick(cancel As Integer)
'在已选项目列表框中双击将激活移除项目事件
lblRemove_Click
End Sub |
|
打开窗体到“窗体视图”状态，试着从左边列表框挑选项目到右边，然后再删除项目，窗体效果如图4-31所示。
|
|
|
|
图4-31 左右移动项目的列表框 |
|
专家点评
|
| 在Access 2002版本中，列表框已经开始支持AddItem和RemoveItem方法，可以使用这两个方法来实现上面的效果。不过，当列表框的数据量比较大时，使用上面这种绑定数据表的方法其速度会更快一些，而且这种方法能够适应各种Access版本。 |
|
|
|
|
|
|
|
|
|
|
|
|
|
网友评论：（只显示最新10条。评论内容只代表网友观点，与本站立场无关！）