Excel VBA 自定義類(ADO)連線資料庫

阿新 • • 發佈：2020-10-07

1.首先Excel要引用相應的ActiveX庫

2.新增一個類模組

'class name: adosql for vba use
Option Explicit

Private ObjConnection As New ADODB.Connection
Private ObjCommand As New ADODB.Command
Public ObjRecordSet As New ADODB.Recordset
Private para(16) As New ADODB.Parameter
    
Private Sub class_initialize()  '建構函式
    ObjConnection.CommandTimeout = 15
    ObjConnection.ConnectionTimeout = 15
End Sub

Public Sub openDsn(strDSN As String)  '開啟資料庫連線
    If Len(strDSN) = 0 Then
        MsgBox "DSN不能為空."
        Exit Sub
    End If
    If Right(strDSN, 1) = ";" Then
        ObjConnection.Open strDSN
    Else
        ObjConnection.Open strDSN & ";"
    End If
End Sub

Public Sub setCmd(strQUERY As String, cmdTYPE As Integer) '設定命令
    ObjCommand.ActiveConnection = ObjConnection
    ObjCommand.CommandText = strQUERY
    ObjCommand.CommandType = cmdTYPE  '1-語句 4-儲存過程
    ObjConnection.CursorLocation = 3  '本地遊標庫提供的客戶端遊標
    ObjRecordSet.CursorType = 3  '靜態遊標
End Sub

Public Sub inpara(s As Integer, paname As String, paformat As String, palen As String, pavalue As String)  '引數個數   引數名  字元型別 長度  值
    Set para(s) = ObjCommand.CreateParameter(paname, paformat, 1, palen, pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub inparastr(s As Integer, paname As String, palen As String, pavalue As String)  '引數個數   引數名  長度  值
    Set para(s) = ObjCommand.CreateParameter(paname, "202", 1, palen, pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub inparaint(s As Integer, paname As String, pavalue As String)  '引數個數   引數名  值
    Set para(s) = ObjCommand.CreateParameter(paname, "3", 1, "8", pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub inparadate(s As Integer, paname As String, pavalue As String)  '引數個數   引數名  值
    Set para(s) = ObjCommand.CreateParameter(paname, "7", 1, "10", pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub inparabool(s As Integer, paname As String, pavalue As String)  '引數個數   引數名  值
    Set para(s) = ObjCommand.CreateParameter(paname, "11", 1, "1", pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub inparadec(s As Integer, paname As String, pavalue As String)  '引數個數   引數名  值
    Set para(s) = ObjCommand.CreateParameter(paname, "14", 1, "18", pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub outpara(s As Integer, paname As String, paformat As String, palen As String)  '引數個數   引數名  字元型別 長度
    Set para(s) = ObjCommand.CreateParameter(paname, paformat, 2, palen)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Sub inoutpara(s As Integer, paname As String, paformat As String, palen As String, pavalue As String)  '引數個數   引數名  字元型別 長度  值
    Set para(s) = ObjCommand.CreateParameter(paname, paformat, 3, palen, pavalue)
    ObjCommand.Parameters.Append para(s)
End Sub

Public Function outvalue(s As Integer) As String  '返回指定引數返回值
    outvalue = para(s).Value
End Function

Public Sub rlspara(s As Integer)  '釋放參數物件
    Dim i As Integer
    For i = 1 To s
        ObjCommand.Parameters.Delete para(i).Name
        Set para(i) = Nothing
    Next
End Sub

Public Function execRT() As Integer  '執行CMD 並返回記錄數
    Set ObjRecordSet = ObjCommand.Execute
    execRT = CInt(ObjRecordSet.RecordCount)
End Function

Public Function getRT() As ADODB.Recordset  '返回記錄集
    Set getRT = ObjCommand.Execute
End Function

Private Sub mfirst()  '遊標定位到第一條
    ObjRecordSet.MoveFirst
End Sub

Private Sub mnext()  '遊標定位到下一條
    ObjRecordSet.MoveNext
End Sub

Public Function getvalue(fieldname As Integer) As String  '取值 BY name
    getvalue = ObjRecordSet.Fields(fieldname).Value
End Function

Public Function numvalue(fieldnum As Integer) As String  '取值 BY number
    numvalue = ObjRecordSet.Fields(fieldnum).Value
End Function

Public Sub clsrcd()  '關閉結果集
    ObjRecordSet.Close
End Sub

Public Sub clscon()  '關閉連線
    ObjConnection.Close
End Sub

Public Function scalar(strQUERY As String) As String  '返回字串值
    Dim ct As Integer
    Call setCmd(strQUERY, 1)
    ct = execRT()
    If ct > 0 Then
        Call mfirst
        scalar = numvalue(0)
    Else
        scalar = ""
    End If
    Call clsrcd
End Function

Public Sub rlscon()  '釋放所有物件
    Set ObjRecordSet = Nothing
    Set ObjCommand = Nothing
	if ObjConnection.State = adStateOpen Then
        ObjConnection.Close
	endif
    Set ObjConnection = Nothing	
End Sub

Private Sub Class_Terminate()  '解構函式
    Set ObjRecordSet = Nothing
    Set ObjCommand = Nothing
	if ObjConnection.State = adStateOpen Then
        ObjConnection.Close
	endif
    Set ObjConnection = Nothing	
End Sub

3.新增一個SUB在模組裡

測試連線資料庫(PROGRESS)

Option Explicit

Public Sub test1()
    Dim ado As adosql
    Set ado = New adosql
    ado.openDsn "Dsn=mfgtest;uid=sql;pwd=123;host=xxx.xx.xx.xx;port=xxxx;db=mfgdb;"
    
    Dim sqlstr As String
    
    sqlstr = "select ifnull(sum(op_qty_comp),0) from pub.op_hist where op_domain = 'CN01' and op_site = 'CN01' and op_type = 'BACKFLSH' and op_date = ? and op_part = ? and op_wo_op = ?"
    ado.inparadate 1, "@date", "2020-04-28"
    ado.inparastr 2, "@part", "18", "ABC0001"
    ado.inparaint 3, "@op", "40"
    MsgBox (ado.scalar(sqlstr))
    ado.rlspara 3
    
    Set ado = Nothing
End Sub

測試連線資料庫(MS SQLSERVER)

Option Explicit

Public Sub test2()
    Dim ado As adosql
    Set ado = New adosql
    ado.openDsn "driver={SQL Server};server=10.3.xxx.x;uid=sql;pwd=xxxx;database=TESTDB"
    
    Dim sqlstr As String
    
    sqlstr = "select isnull(sum(sodqty),0) from salesdetail where plantcode = 'CN01' and orddate >= ?"
    ado.inparadate 1, "@date", "2020-04-28"
    MsgBox (ado.scalar(sqlstr))
    ado.rlspara 3
    
    Set ado = Nothing
End Sub

這樣就可以比較方便的取到資料輸出到EXCEL表格裡了