【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