【VBA研究】利用ADO实现VBA连接Oracle并执行存储过程
作者：iamlaosong
很多事情如果编写客户端程序比较麻烦，通过存储过程实现功能，利用excel调用并取回结果，非常方便，本程序就是调用存储过程完成总包清分功能，根据袋牌条码查找内件并清分到各个分公司，最后取回结果。
对于查询结果，有两种处理方法：
1、如本例所示，存入excel工作表中
Sheets(name).Range("a2").CopyFromRecordset rst
也可以写成：Sheets(name).Cells(2,1).CopyFromRecordset rst
2、直接使用：
Do While Not Rst.EOF
MsgBox ("城市：" & Rst("city") & " 所属县市" & Rst("county"))
Rst.MoveNext
Loop
其中city和county是查询结果中的字段名。
Private Sub CommandButton1_Click()
Dim cnn, rst, cmd As Object
Dim sqls As String
Dim OraOpen As Boolean
'---- CommandTypeEnum Values ----
'Const adCmdUnknown = &H8
'Const adCmdText = &H1
'Const adCmdTable = &H2
Const adCmdStoredProc = &H4
'Const adCmdFile = &H100
'Const adCmdTableDirect = &H200
On Error GoTo Err
If MsgBox("开始生成清分数据......", vbOKCancel, "iamlaosong") = vbCancel Then Exit Sub
FrameProgress.Visible = True
curdate = Date
modfile = TextBox1.Value '导出文件模板
datfile = TextBox2.Value '文件名称
qfxx = "清分信息"
pos_qsh = Int(TextBox3.Value)
pos_acc = Asc(TextBox4.Value) - 64
pos_lab = Asc(TextBox5.Value) - 64
pos_typ = Asc(TextBox6.Value) - 64
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
Set cmd = CreateObject("ADODB.Command")
sqls = "connect database"
cnn.Open "Provider=msdaora;Data Source=dl580;User Id=emssxjk;Password=emssxjk;"
OraOpen = True '成功执行后，数据库即被打开
If Not OraOpen Then Exit Sub
modFullName = ThisWorkbook.Path & "\" & modfile
If Dir(modFullName, vbNormal) <> vbNullString Then
Workbooks.Open Filename:=modFullName '打开订单文件
Else
MsgBox "模板文件不存在！", vbOKOnly, "iamlaosong"
Exit Sub
End If
datFullName = ThisWorkbook.Path & "\" & datfile
If Dir(datFullName, vbNormal) <> vbNullString Then
Workbooks.Open Filename:=datFullName '打开订单文件
Else
MsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"
Exit Sub
End If
unitno = Worksheets.Count
Set cmd.ActiveConnection = cnn
cmd.CommandText = "zfqf_bag2mail" '存储过程名称，有两个参数
cmd.CommandType = adCmdStoredProc
For unit_num = 1 To unitno '文件循环
sqls = "truncate table emsapp_zfqf_mail"
Set rst = cnn.Execute(sqls) '清表数据
Worksheets(unit_num).Select
lineno = [A65536].End(xlUp).Row ' Excel 2007 : lineno = [A1048576].End(xlUp).Row
Application.StatusBar = Sheets(unit_num).Name
For row1 = pos_qsh To lineno
If Cells(row1, pos_typ) <> "811" Then
cmd.Parameters(0).Value = Cells(row1, pos_acc)
cmd.Parameters(1).Value = Cells(row1, pos_lab)
cmd.Execute
End If
If row1 = Int(row1 / 10) * 10 Then
UpdateProgress (Round(row1 / lineno, 4))
End If
Next row1
Windows(modfile).Activate
Sheets("模板").Copy Before:=Sheets(1) '复制工作表
Sheets(1).Name = qfxx & unit_num '工作表名称带上序号，防止重名。
sqls = "select t.city,t.ssxs,t.zj_code,t.label_strip,t.mail_num,t.mail_no,t.acc_month,t.create_date from emsapp_zfqf_mail t"
Set rst = cnn.Execute(sqls)
sqls = "CopyFromRecordset"
'maxrow = Sheets(qfxx).[A65536].End(xlUp).Row
'If maxrow > 1 Then Sheets(qfxx).Range("a2:H" & maxrow).ClearContents
Sheets(1).Range("a2").CopyFromRecordset rst
Windows(datfile).Activate
Next unit_num
Windows(datfile).Close
Windows(modfile).Activate
expfile = ThisWorkbook.Path & "\" & curdate & datfile
ActiveWorkbook.SaveAs Filename:=expfile, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
cnn.Close
Set cnn = Nothing
MsgBox "清分信息生成完毕！", vbOKOnly, "iamlaosong"
Exit Sub
Err:
MsgBox "错误#" & Str(Err.Number) & Err.Description & "-位置： " & sqls, vbOKOnly + vbExclamation, "iamlaosong"
End Sub
Private Sub UpdateProgress(ByVal percent As Double)
FrameProgress.Caption = Format(percent, "0%")
Lblprogress.Width = percent * (FrameProgress.Width)
'Me.Repaint
DoEvents
End Sub
Private Sub CommandButton2_Click()
Application.DisplayAlerts = False
Application.Quit
End Sub
Private Sub FrameProgress_Click()
End Sub