|
用VBA连接SQL数据库写入数据并处理,但是代码无法连接数据库,提示错误不能连接(红色字体处报错)。但是用客户端又能访问,系统是WIN10.相关代码及系统配置如图,找了两天了没有找到原因,请各位大神帮忙指点指点,谢谢!
Sub 读取数据并写入()
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False '关闭屏幕
Application.DisplayAlerts = False
Dim ss As Workbook
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, k As Long
Dim bt, nm As String
With Application.FileDialog(msoFileDialogOpen) '打开对话框对象
.AllowMultiSelect = True '多选文件
If .Show = -1 Then '打开操作
MsgBox "被选定导入的文件共 " & .SelectedItems.Count & " 个 !", , "导入数据"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To .SelectedItems.Count '从选定的第1个文件循环到选定的最后一个文件
x = InStrRev(.SelectedItems(i), "\") '计算具有路径的文件名中最后一个分隔符\的位置
y = Len(.SelectedItems(i)) '计算具有路径的文件名长度
TQ = Right(.SelectedItems(i), y - x) '提取文件名称(含拓展名)
Set ss = Workbooks.Open(.SelectedItems(i), , ReadOnly) '打开文件并赋值给变量ss
mc = ss.Name '打开的文件名称
With Workbooks(mc).Sheets("sheet")
hs = Application.WorksheetFunction.Max(.Range("a1048576").End(xlUp).Row(), 2) '加max函数是为了防止复制标题行
sz = .Range(Cells(2, 1).Address & ":" & Cells(hs, 15).Address) '
End With
cnn.Open "Provider=sqloledb;Server=LAPTOP-BETRGNKJ\SQLEXPRESS;Database=zhtc;Integrated Security=SSPI;Persist Security Info=False;"
rs.Open "进出记录", cnn, adOpenDynamic, adLockPessimistic
For k = 1 To UBound(sz, 1)
On Error Resume Next '以为关键字,即判断数据添加重复,则退出工程
With rs
.AddNew
.Fields("停车场名称").Value = sz(k, 1) '
.Fields("停车位").Value = sz(k, 2)
.Fields("进场时间").Value = sz(k, 3)
.Fields("出场时间").Value = sz(k, 6)
.Fields("停车时长").Value = sz(k, 9)
.Fields("应付金额").Value = sz(k, 10)
.Fields("车牌号").Value = sz(k, 11)
.Fields("状态").Value = sz(k, 15)
.Update
End With
Next k
rs.Close
cnn.Close
Erase sz '清空数组SZ1释放内存
Next i
Else
MsgBox "没有指定打开的文件!", , "导入数据"
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True '屏幕刷新
End Sub
|
|