[已解决]求助读取ACCESS数据库路径是否能变更路径。

qinhuan66

求助读取ACCESS数据库路径是否能变更路径。
意思是ACCESS数据库能否存放在个人信息文件夹内，不要存放在单位文件夹内）现在不存放在单位文件夹出错。
在此非常感谢hwc2ycy版主提供的全部代码。谢谢hwc2ycy老师
个人信息.rar (241.85 KB, 下载次数: 5)

2014-1-23 19:37 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-1-23 20:57

1. Const adUseClient = 3
   
2. Const adModeShareDenyWrite = 8
   
3. Const adModeReadWrite = 3
   
4. Const adModeRead = 1
   
5. 
   
6. Dim AdoConn As Object, AdoRst As Object
   
7. Dim strFullName$
   
8. Sub Main()
   
9.     Dim strSql$
   
10.     Dim strMsg$
    
11.     Dim i As Integer
    
12.     If Len(strFullName) = 0 Then
    
13.         With Application.FileDialog(msoFileDialogFilePicker)
    
14.             .AllowMultiSelect = False
    
15.             '.Filters.Add("Access数据库文件", ".mdb")
    
16.            ' .Filters.Add
    
17.             .InitialFileName = ThisWorkbook.Path
    
18.             If .Show Then
    
19.                 strFullName = .SelectedItems(1)
    
20.             Else
    
21.                 MsgBox "请选择要打开的数据库"
    
22.                 Exit Sub
    
23.             End If
    
24.         End With
    
25.     End If
    
26.     If Len(Dir(strFullName)) = 0 Then
    
27.         MsgBox strFullName & "不存在"
    
28.         Exit Sub
    
29.     End If
    
30.             
    
31.     If Len([c2].Value) = 0 Or Len([b3].Value) = 0 Then
    
32.         MsgBox "信息不完整"
    
33.         Exit Sub
    
34.     End If
    
35.     If Not OpenConnect(strFullName, "695360052") Then
    
36.         Exit Sub
    
37.     End If
    
38.     strSql = "select * from 个人信息 where 单位名称='" & [c2].Value & "' and 姓名='" & [b3].Value & "'"
    
39.     If Not RunSql(strSql) Then
    
40.         Exit Sub
    
41.     End If
    
42.     With AdoRst
    
43.         If .RecordCount < 1 Then
    
44.             MsgBox "无符合条件的记录"
    
45.             .Close
    
46.             Exit Sub
    
47.         End If
    
48.         Do
    
49.             i = i + 1
    
50.             Range("j2").Value = .Fields("单位性质").Value    '单位性质
    
51.             Range("n2").Value = .Fields("参保类别").Value   '参保类别
    
52.             Range("h3").Value = .Fields("身份证号").Value    '身份证号
    
53.             Range("q2").Value = .Fields("参保时间").Value    '时间
    
54.             Range("q3").Value = .Fields("参加工作时间").Value    '参加工作时间
    
55.             Range("t3").Value = .Fields("联系地址").Value    '地址
    
56.             strMsg = [b3].Value & " 一共有 " & .RecordCount & " 条记录"
    
57.             strMsg = strMsg & ",这是第 " & i & "  条记录" & vbCr
    
58.             strMsg = strMsg & "点击 是 显示下一条记录,否 退出"
    
59.             If MsgBox(strMsg, vbYesNo) = vbNo Then
    
60.                 Exit Sub
    
61.             End If
    
62.             .movenext
    
63.         Loop While Not .EOF
    
64.     End With
    
65.     MsgBox "已经到最后一条记录"
    
66.     Set AdoRst = Nothing
    
67. End Sub
    
68. 
    
69. Function OpenConnect(strFullName As String, Optional dbpasswd As String = "") As Boolean
    
70.     Dim StrConn$
    
71.     On Error GoTo ErrorHandler
    
72.     If AdoConn Is Nothing Then
    
73.         Set AdoConn = CreateObject("ADODB.Connection")
    
74.     Else
    
75.         OpenConnect = True
    
76.         Exit Function
    
77.     End If
    
78. 
    
79.     Select Case Application.Version
    
80.         Case "14.0", "12.0"
    
81.             StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
    
82.                       strFullName & "';Jet OLEDB:Database Password='" & dbpasswd & "';"
    
83.         Case Else
    
84.             StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
85.                       "Data Source='" & strFullName & "';Jet OLEDB:Database Password='" & dbpasswd & "';"
    
86.     End Select
    
87. 
    
88.     With AdoConn
    
89.         .CommandTimeout = 5
    
90.         .ConnectionTimeout = 5
    
91.         .CursorLocation = adUseClient
    
92.         .Mode = adModeRead
    
93.         .ConnectionString = StrConn
    
94.         .Open
    
95.     End With
    
96. 
    
97.     OpenConnect = True
    
98.     Exit Function
    
99. 
    
100. ErrorHandler:
     
101.     MsgBox Err.Number & vbCrLf & Err.Description
     
102.     Set AdoRst = Nothing
     
103.     Set AdoConn = Nothing
     
104. 
     
105. End Function
     
106. 
     
107. Function RunSql(sql As String) As Boolean
     
108.     On Error GoTo ErrorHandler
     
109.     Set AdoRst = AdoConn.Execute(sql)
     
110.     RunSql = True
     
111.     Exit Function
     
112. ErrorHandler:
     
113.     MsgBox Err.Number & vbCrLf & Err.Description
     
114. End Function
     

复制代码

跳转到最佳答案楼层

qinhuan66

还发现一个问题，就是重复姓名和单位名称时只提取第一个人而已。没有选择性
例如 ;

hwc2ycy

这个选择性，你应该能做出来吧？
adorst有movenext,moveprevious方法。

hwc2ycy

文件的保存位置可以通过对话框来选择。

hwc2ycy

1. Const adUseClient = 3
   
2. Const adModeShareDenyWrite = 8
   
3. Const adModeReadWrite = 3
   
4. Const adModeRead = 1
   
5. 
   
6. Dim AdoConn As Object, AdoRst As Object
   
7. Dim strFullName$
   
8. Sub Main()
   
9.     Dim strSql$
   
10.     Dim strMsg$
    
11.     Dim i As Integer
    
12.     If Len(strFullName) = 0 Then
    
13.         With Application.FileDialog(msoFileDialogFilePicker)
    
14.             .AllowMultiSelect = False
    
15.             '.Filters.Add("Access数据库文件", ".mdb")
    
16.            ' .Filters.Add
    
17.             .InitialFileName = ThisWorkbook.Path
    
18.             If .Show Then
    
19.                 strFullName = .SelectedItems(1)
    
20.             Else
    
21.                 MsgBox "请选择要打开的数据库"
    
22.                 Exit Sub
    
23.             End If
    
24.         End With
    
25.     End If
    
26.     If Len(Dir(strFullName)) = 0 Then
    
27.         MsgBox strFullName & "不存在"
    
28.         Exit Sub
    
29.     End If
    
30.             
    
31.     If Len([c2].Value) = 0 Or Len([b3].Value) = 0 Then
    
32.         MsgBox "信息不完整"
    
33.         Exit Sub
    
34.     End If
    
35.     If Not OpenConnect(strFullName, "695360052") Then
    
36.         Exit Sub
    
37.     End If
    
38.     strSql = "select * from 个人信息 where 单位名称='" & [c2].Value & "' and 姓名='" & [b3].Value & "'"
    
39.     If Not RunSql(strSql) Then
    
40.         Exit Sub
    
41.     End If
    
42.     With AdoRst
    
43.         If .RecordCount < 1 Then
    
44.             MsgBox "无符合条件的记录"
    
45.             .Close
    
46.             Exit Sub
    
47.         End If
    
48.         Do
    
49.             i = i + 1
    
50.             Range("j2").Value = .Fields("单位性质").Value    '单位性质
    
51.             Range("n2").Value = .Fields("参保类别").Value   '参保类别
    
52.             Range("h3").Value = .Fields("身份证号").Value    '身份证号
    
53.             Range("q2").Value = .Fields("参保时间").Value    '时间
    
54.             Range("q3").Value = .Fields("参加工作时间").Value    '参加工作时间
    
55.             Range("t3").Value = .Fields("联系地址").Value    '地址
    
56.             strMsg = [b3].Value & " 一共有 " & .RecordCount & " 条记录"
    
57.             strMsg = strMsg & ",这是第 " & i & "  条记录" & vbCr
    
58.             strMsg = strMsg & "点击 是 显示下一条记录,否 退出"
    
59.             If MsgBox(strMsg, vbYesNo) = vbNo Then
    
60.                 Exit Sub
    
61.             End If
    
62.             .movenext
    
63.         Loop While Not .EOF
    
64.     End With
    
65.     MsgBox "已经到最后一条记录"
    
66.     Set AdoRst = Nothing
    
67. End Sub
    
68. 
    
69. Function OpenConnect(strFullName As String, Optional dbpasswd As String = "") As Boolean
    
70.     Dim StrConn$
    
71.     On Error GoTo ErrorHandler
    
72.     If AdoConn Is Nothing Then
    
73.         Set AdoConn = CreateObject("ADODB.Connection")
    
74.     Else
    
75.         OpenConnect = True
    
76.         Exit Function
    
77.     End If
    
78. 
    
79.     Select Case Application.Version
    
80.         Case "14.0", "12.0"
    
81.             StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
    
82.                       strFullName & "';Jet OLEDB:Database Password='" & dbpasswd & "';"
    
83.         Case Else
    
84.             StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
85.                       "Data Source='" & strFullName & "';Jet OLEDB:Database Password='" & dbpasswd & "';"
    
86.     End Select
    
87. 
    
88.     With AdoConn
    
89.         .CommandTimeout = 5
    
90.         .ConnectionTimeout = 5
    
91.         .CursorLocation = adUseClient
    
92.         .Mode = adModeRead
    
93.         .ConnectionString = StrConn
    
94.         .Open
    
95.     End With
    
96. 
    
97.     OpenConnect = True
    
98.     Exit Function
    
99. 
    
100. ErrorHandler:
     
101.     MsgBox Err.Number & vbCrLf & Err.Description
     
102.     Set AdoRst = Nothing
     
103.     Set AdoConn = Nothing
     
104. 
     
105. End Function
     
106. 
     
107. Function RunSql(sql As String) As Boolean
     
108.     On Error GoTo ErrorHandler
     
109.     Set AdoRst = AdoConn.Execute(sql)
     
110.     RunSql = True
     
111.     Exit Function
     
112. ErrorHandler:
     
113.     MsgBox Err.Number & vbCrLf & Err.Description
     
114. End Function
     

复制代码

hwc2ycy

1. Sub Main()
   
2.     Dim strSql$
   
3.     Dim strMsg$
   
4.     Dim i As Integer
   
5.     If Len(strFullName) = 0 Then
   
6.         With Application.FileDialog(msoFileDialogFilePicker)
   
7.             .AllowMultiSelect = False
   
8.             '.Filters.Add("Access数据库文件", ".mdb")
   
9.             ' .Filters.Add
   
10.             .InitialFileName = ThisWorkbook.Path
    
11.             If .Show Then
    
12.                 strFullName = .SelectedItems(1)
    
13.             Else
    
14.                 MsgBox "请选择要打开的数据库"
    
15.                 Exit Sub
    
16.             End If
    
17.         End With
    
18.     Else
    
19. 
    
20.         If MsgBox("当前文件为" & strFullName & vbCr & "需要重新选择嘛？", vbYesNo) = vbYes Then
    
21.             Set AdoConn = Nothing
    
22.             With Application.FileDialog(msoFileDialogFilePicker)
    
23.                 .AllowMultiSelect = False
    
24.                 .InitialFileName = ThisWorkbook.Path
    
25.                 If .Show Then
    
26.                     strFullName = .SelectedItems(1)
    
27.                 Else
    
28.                     MsgBox "请选择要打开的数据库"
    
29.                     Exit Sub
    
30.                 End If
    
31.             End With
    
32.         End If
    
33.     End If
    
34. 
    
35. 
    
36.     If Len(Dir(strFullName)) = 0 Then
    
37.         MsgBox strFullName & "不存在"
    
38.         Exit Sub
    
39.     End If
    
40. 
    
41.     If Len([c2].Value) = 0 Or Len([b3].Value) = 0 Then
    
42.         MsgBox "信息不完整"
    
43.         Exit Sub
    
44.     End If
    
45.     If Not OpenConnect(strFullName, "695360052") Then
    
46.         Exit Sub
    
47.     End If
    
48.     strSql = "select * from 个人信息 where 单位名称='" & [c2].Value & "' and 姓名='" & [b3].Value & "'"
    
49.     'strSql = "select * from 个人信息 where 姓名='" & [b3].Value & "'"
    
50.     If Not RunSql(strSql) Then
    
51.         Exit Sub
    
52.     End If
    
53.     With AdoRst
    
54.         If .RecordCount < 1 Then
    
55.             MsgBox "无符合条件的记录"
    
56.             .Close
    
57.             Exit Sub
    
58.         End If
    
59.         Do
    
60.             i = i + 1
    
61.             Range("j2").Value = .Fields("单位性质").Value    '单位性质
    
62.             Range("n2").Value = .Fields("参保类别").Value   '参保类别
    
63.             Range("h3").Value = .Fields("身份证号").Value    '身份证号
    
64.             Range("q2").Value = .Fields("参保时间").Value    '时间
    
65.             Range("q3").Value = .Fields("参加工作时间").Value    '参加工作时间
    
66.             Range("t3").Value = .Fields("联系地址").Value    '地址
    
67.             strMsg = [b3].Value & " 一共有 " & .RecordCount & " 条记录"
    
68.             strMsg = strMsg & ",这是第 " & i & "  条记录" & vbCr
    
69.             strMsg = strMsg & "点击 是 显示下一条记录,否 退出"
    
70.             If MsgBox(strMsg, vbYesNo) = vbNo Then
    
71.                 Exit Sub
    
72.             End If
    
73.             .movenext
    
74.         Loop While Not .EOF
    
75.     End With
    
76.     MsgBox "已经到最后一条记录"
    
77.     Set AdoRst = Nothing
    
78. End Sub

复制代码

hwc2ycy

其余的代码不变，就换这一个主过程，另外，顶部加strFullName的声明。

hwc2ycy

可以做成是上一条，否下一条，取消退出。
这样机动更强。

qinhuan66

hwc2ycy 发表于 2014-1-23 21:23
可以做成是上一条，否下一条，取消退出。
这样机动更强。

唉老师就是专业，我怎么没有想到呢？我新开一个贴，你帮我弄弄行吗？谢谢了