|
本帖最后由 hwc2ycy 于 2013-6-5 23:30 编辑
- Sub 提交到Access数据库()
- Dim AccessFile As String, Database As String, sql As String
- Dim StrConn$, strSql$
- Dim lLastRow&
- Dim arr, i&, j As Byte
- Dim AdoxCat As Object
- Dim AdoCmd As Object
- Dim AdoConn As Object
- Dim AdoRst As Object
- On Error GoTo Errcheck
- AccessFile = ThisWorkbook.Path & "\gkzp.mdb"
- Database = "gkzp"
- If Dir(AccessFile) = "" Then
- '检测文件是否存在,不存在则创建数据库
- Set AdoxCat = CreateObject("adox.catalog")
- AdoxCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile & ";Jet OLEDB:Database Password=695360052;"
- Set AdoConn = AdoxCat.ActiveConnection
- Set AdoCmd = CreateObject("ADODB.Command")
- Set AdoCmd.ActiveConnection = AdoConn
- AdoCmd.CommandText = "CREATE TABLE " & Database & _
- " (报名序号 text(3),报名时间 datetime ,报考类型 text(30),操作员 text(6),姓名 text(8),性别 text(2),出生日期 datetime ,籍贯 text(30),民族 text(10)," & _
- "政治面貌 text(20),健康状况 text(20),参加工作时间 datetime ,最高学历毕业时间 datetime ,移动电话 text(12),固定电话 text(11),身份证号 text(18),电子邮箱 text(20)," & _
- "工作单位及职务(或家庭住址) text(50),报考职位 text(50),全日制教育 text(50),全日制教育毕业院校及专业 text(50),在职教育 text(50),在职教育毕业院校及专业 text(50),学习工作简历 text(50),提供材料 text(120),资格审查情况 text(10))"
- AdoCmd.Execute
- Set AdoCmd = Nothing
- Set AdoxCat = Nothing
- Set AdoConn = Nothing
- End If
- If Len([B3]) = 0 Or Len([F3]) = 0 Or Len([J3]) = 0 Or Len([B4]) = 0 Or Len([F4]) = 0 Or Len([J4]) = 0 Or Len([B5]) = 0 Or Len([F5]) = 0 Or Len([J5]) = 0 Or Len([C6]) = 0 Or Len([J6]) = 0 Or Len([C7]) = 0 Or Len([J7]) = 0 Or Len([E8]) = 0 Or Len([E9]) = 0 Or Len([D10]) = 0 Or Len([I10]) = 0 Or Len([D11]) = 0 Or Len([I11]) = 0 Or Len([B12]) = 0 Then
- MsgBox "对不起!黄色区域数据输入不完整,请先填好数据再进行提交。"
- Exit Sub
- End If
- StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
- "Data Source='" & AccessFile & "';jet oledb:Database Password=695360052"
- Set AdoConn = CreateObject("ADODB.Connection")
- AdoConn.CursorLocation = 3
- AdoConn.Mode = 3
- AdoConn.CommandTimeout = 5
- AdoConn.connectionTimeout = 5
- AdoConn.Open StrConn
- If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub
- strSql = "select * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 姓名 like '" & [B3] & "' and 身份证号='" & [C7] & "'"
- Dim strTGCL[ DISCUZ_CODE_1 ]nbsp; '提供材料
- Dim strZGSCQK[ DISCUZ_CODE_1 ]nbsp; '资格审查情况
- Dim item1
- With Sheet1
- For Each item1 In .OLEObjects '控件遍历
- With item1
- If .Name Like "CheckBox*" Then '过滤非CHECKBOX
- Select Case True
- Case .Object.Value And .TopLeftCell.Row = 17 '17行的数据
- strTGCL = strTGCL & .Object.Caption & ","
- Case .Object.Value And .TopLeftCell.Row = 22 '22行的数据
- strZGSCQK = strZGSCQK & item1.Object.Caption & ","
- End Select
- End If
- End With
- Next
- End With
- If Len(strTGCL) Then
- strTGCL = Left(strTGCL, Len(strTGCL) - 1) '过滤最后的","
- Else
- strTGCL = "无"
- End If
- If Len(strZGSCQK) Then
- strZGSCQK = Left(strZGSCQK, Len(strZGSCQK) - 1) '过滤最后的","
- Else
- strZGSCQK = "无"
- End If
- Set AdoRst = AdoConn.Execute(strSql)
- If AdoRst.RecordCount = 0 Then '
- strSql = " insert into " & Database & " values('" & [L3] & "',#" & [L4] & "#,'" & [L5] & "','" & [L6] & "','" & [B3] & "','" & [F3] & "',#" & [J3] & "#,'" & [B4] & "','" & [F4] & "','" & _
- [J4] & "','" & [B5] & "',#" & [F5] & "#,'" & [J5] & "','" & [C6] & "','" & [J6] & "','" & [C7] & "','" & [J7] & "','" & _
- [E8] & "','" & [E9] & "','" & [D10] & "','" & [I10] & "','" & [D11] & "','" & [I11] & "','" & [B12] & "','" & strTGCL & "','" & strZGSCQK & "')"
- AdoConn.Execute strSql
- MsgBox "呵呵!本次数据已成功添加的数据库"
- [B3:C3,F3:G3,J3,L3,B4:C4,F4:G4,J4,L4,B5:C5,F5:G5,J5,L5,C6:G6,J6,L6,C7:G7,J7:L7,E8:L8,E9:L9,D10:F10,I10:L10,D11:F11,I11:L11,B12:L16] = ""
- [f2] = [f2] + 1
- '清除单选框
- With Sheet1
- For Each item1 In .OLEObjects '控件遍历
- With item1
- Select Case TypeName(.Object)
- Case "CheckBox"
- .Object.Value = False
- End Select
- End With
- Next
- End With
- Else
- MsgBox "呵呵!请注意:记录已经存在,不能重复添加!"
- End If
- AdoConn.Close
- Set AdoConn = Nothing
- Exit Sub
- Errcheck:
- MsgBox Err.Number & vbNewLine & _
- Err.Description
- End Sub
复制代码 |
评分
-
查看全部评分
|