作者微信
微

准时下班系列！Access合集之第7集—自定义多选组合框和VBA处理多值字段实例

小技术 7个月前 (08-26) 0 999+

关注

Hi，各位同学好！

前几天有个在读大学的Access学员提供了一个应用场景，他说他对祖国的传统文化很感兴趣，且颇有涉猎。他打算在大学创立一个国风社。

他需要一个系统，用以管理社团成员，但找别人做经济成本太高，且后期完善需求有巨大的时间和经济成本隐患，综合考虑，打算自己边学边做，自给自足。

在做录入社团报名人员窗体的时候，他遇到了一个Access的经典问题：报名表里有一个允许多选的查阅字段，在窗体里对应一个组合框控件，当组合框控件不绑定这个多值字段的时候，默认控件无法实现多选功能。

报名表中多值字段展示图

他需要能自由实现自定义效果的功能，不想使用控件绑定记录源字段的方式去实现组合框的多选。

虽然不精通但同样喜欢传统文化的我，必须鼎力相助。我为他做了一个自定义窗体的例子，实现了不绑定多值字段仍支持多选的组合框，且一并解决了多选组合框的值如何保存到表里的问题。

现将案例和实现方法都分享给大家，希望能帮助到有相似需求的同学，节省一些时间和精力。

示例效果图如下：

示例效果演示动态图

表结构和关系展示：

表关系展示图

窗体设计视图：

技艺类目窗体

社团报名入口窗体

VBA代码结构图：

VBA详细代码展示：

Form_国学技艺类目窗体内代码：

Option Compare Database
Option Explicit

'取消选择
Private Sub Btn_Cancel_Click()
    Me.Parent.Form.擅长技艺.SetFocus
    Me.Parent.Form.Child26.Visible = False
End Sub

'确定使用选择的值
Private Sub Btn_Ok_Click()
    Me.Parent.Form.擅长技艺.SetFocus
    '给擅长技艺赋值
    getAllCheckedValue
    
    Me.Parent.Form.Child26.Visible = False
End Sub

'窗体打开时初始化
Private Sub Form_Open(Cancel As Integer)
    
    Dim ctl As Control
    For Each ctl In Me.Controls
        If (VBA.TypeName(ctl) = "CheckBox" Or VBA.TypeName(ctl) = "Label") Then
            ctl.Visible = False
        End If
    Next ctl
    
    Dim db As Database, rs As Recordset
    Set db = Application.CurrentDb
    Set rs = db.OpenRecordset("国学技艺类目", dbOpenDynaset, dbSeeChanges)
    Dim i As Integer
    If (Not (rs.BOF And rs.EOF)) Then
        Do Until rs.EOF
            i = i + 1
            Dim cbx As CheckBox, cbxLabel As Label
            Set cbx = Me.Controls("Check" & i)
            cbx.DefaultValue = rs("ID").Value
            Set cbxLabel = cbx.Controls(0)
            Call intCbxValue(IIf(IsNull(Me.Parent.IDS), "", Me.Parent.IDS), cbx)
            cbx.Value = False
            cbxLabel.Caption = rs("名称")
            cbxLabel.Visible = True
            cbx.Visible = True
            rs.MoveNext
        Loop
    End If
    
End Sub


'将选择的所有给主窗体的擅长技艺控件
Private Function getAllCheckedValue()
    Dim ctl As Control
    Dim IDS As String, names As String
    For Each ctl In Me.Controls
        If (VBA.TypeName(ctl) = "CheckBox") Then
            If (ctl.Value = True) Then
                IDS = IDS & "," & ctl.DefaultValue
                names = names & "," & ctl.Controls(0).Caption
            End If
        End If
    Next ctl
    
    If (VBA.Len(IDS) > 0) Then
        IDS = VBA.Mid(IDS, 2)
        names = VBA.Mid(names, 2)
    End If
    Me.Parent.擅长技艺.Value = names
    Me.Parent.IDS.Value = IDS
End Function

Form_国学社报名入口：

Option Compare Database
Option Explicit

'关闭窗体按钮
Private Sub Btn_Close_Click()
    If (VBA.MsgBox("确定要退出吗？将会丢失未保存的值", vbOKCancel) = vbOK) Then
        DoCmd.Close acForm, Me.name
    End If
End Sub

'保存按钮
Private Sub Btn_save_Click()
    Dim db As Database
    Dim rs As Recordset, rs2 As Recordset2
    Set db = Application.CurrentDb
    Set rs = db.OpenRecordset("国学社报名表", dbOpenDynaset, dbSeeChanges)

    On Error GoTo errorhandler:
    rs.AddNew
    rs("姓名") = Me.姓名
    rs("性别") = Me.性别
    rs("出生日期") = Me.出生日期
    Set rs2 = rs("擅长技艺").Value
    initMultiValueRs rs2, Me.IDS
    rs.Update
    
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
    
    MsgBox "保存成功"
    resetControls
    
    Exit Sub
    
errorhandler:
    MsgBox "保存失败"
    
End Sub

'重置控件值
Private Function resetControls()
    Me.姓名 = ""
    Me.性别 = ""
    Me.出生日期 = ""
    Me.IDS = ""
    Me.擅长技艺 = ""
End Function

'用ids控件结果填充rs2值
Private Function initMultiValueRs(rs2 As Recordset2, vals As String)
    If (Not (rs2.BOF And rs2.EOF)) Then
        '此if结构是为了使此方法适合编辑值时初始化，本案例中没有编辑记录操作，故用不上
        Do Until rs2.BOF
            rs2.MoveLast
            rs2.Delete
        Loop
    End If

    If (VBA.Len(vals) > 0) Then
        '添加新值列表
        Dim arr As Variant
        arr = VBA.Split(vals, ",")
        Dim i As Integer
        For i = LBound(arr) To UBound(arr)
            rs2.AddNew
            rs2("value") = VBA.CLng(arr(i))
            rs2.Update
        Next i
    End If
   
End Function

'窗体加载时隐藏子窗体控件
Private Sub Form_Load()
    Me.Child26.Visible = False
End Sub

'双击打开多选框，且初始化多选框值
Private Sub 擅长技艺_DblClick(Cancel As Integer)
    Me.Child26.Visible = True
    
    Dim ctl As Control
    For Each ctl In Me.Child26.Form.Controls
        If (VBA.TypeName(ctl) = "CheckBox" And ctl.Visible = True) Then
            Call intCbxValue(IIf(IsNull(Me.IDS), "", Me.IDS), ctl)
        End If
    Next ctl
    
End Sub

CommonFunction模块内代码：

Option Compare Database
Option Explicit


'初始化多选框的值
Public Function intCbxValue(IDS As String, cbx As CheckBox)
    
    If (VBA.InStr(1, "," & IDS & ",", "," & cbx.DefaultValue & ",")) Then
        cbx.Value = True
    Else
        cbx.Value = False
    End If
End Function