【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