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

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

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