社区首页 >专栏 >VBA与数据库——写个类操作ADO_打开数据库

VBA与数据库——写个类操作ADO_打开数据库

xyj

发布于 2021-11-12 07:14:16

3K00

代码可运行

文章被收录于专栏：VBA 学习VBA 学习

运行总次数：0

代码可运行

在前面介绍的一些操作数据库的代码中，可以看到，主要的操作逻辑基本上是打开数据库-操作-关闭数据库，很多时候改变的仅仅是操作，所以，把这些封装到一个类里面，以后调用自己写的类就会更方便。

因为ADO这个东西不仅仅只有Excel VBA可以调用，只要能调用COM组件的语言都是可以使用的，所以ADO实现的方法和属性都是通用性的，对于使用Excel VBA的人来说，有些时候为了方便在Excel里使用，自然需要做进一步的处理。

使用VBAProject管理类代码

我个人是习惯使用VBAProject来管理代码的，新建一个.xlam加载宏文件，插入类模块，命名CADO，设置Instancing=2，添加引用：

Microsoft ActiveX Data Objects #.# Library

#.#代表的是版本号，使用自己电脑的最高版本即可。

添加这个引用的目的是为了使用前期绑定，方便输代码，因为使用了VBAProject来管理代码，以后其他文件需要操作数据库都添加引用这个文件即可，不会再需要添加引用ADO。

类模块顶部声明：

'函数的返回值，0表示成功
Private Enum RetCode
    RetSucce = 0
    RetErr
End Enum
Private AdoConn As ADODB.Connection
'用来返回错误，通过GetErr函数
Private StrErr As String

然后输入类的初始、销毁代码，主要就是声明ADODB.Connection以及关闭数据库：

Private Sub Class_Initialize()
    Set AdoConn = New ADODB.Connection
End Sub

Private Sub Class_Terminate()
    If AdoConn.State = adStateOpen Then AdoConn.Close
    Set AdoConn = Nothing
End Sub

插入模块，命名MAPI，输入代码：

Public Function NewCADO() As CADO
    Set NewCADO = New CADO
End Function

准备工作就结束了。

实现OpenDB

打开数据库就是调用ADO的Open方法，在打开的时候，主要是需要写好Provider字符串，前面基本上是使用Excel来做测试的，但是数据库有很多种，不同的数据库Provider字符串是不一样的，希望的OpenDB函数就是可以根据输入的数据库信息，自动构建好Provider字符串：

Function OpenDB(dbSrc As String) As Long
    On Error GoTo errHandle
    
    If AdoConn.State = adStateOpen Then AdoConn.Close
    
    AdoConn.Open GetProvider(dbSrc)
    OpenDB = RetCode.RetSucce
    
    Exit Function
errHandle:
    StrErr = Err.Description
    OpenDB = RetCode.RetErr
End Function

Private Function GetProvider(dbSrc As String) As String
    '开头如果是Provider，那就是已经写好了连接语句
    If VBA.LCase$(VBA.Left$(dbSrc, 8)) = "provider" Then
        GetProvider = dbSrc
        Exit Function
    End If
    
    '否则按照文件的后缀来处理
    Dim strExt As String
    strExt = GetExt(dbSrc)
'    没有后缀的文件，尝试使用文件的前面部分字节来判断
    If VBA.Len(strExt) = 0 Then strExt = GetExtByBin(dbSrc)
    
    strExt = VBA.LCase$(strExt)
    
    Select Case strExt
    Case "xls", "xlsx", "xlsm", "xlsb"
        GetProvider = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & dbSrc
        GetProvider = GetProvider & ";Extended Properties=""Excel 12.0;HDR=YES"";"
        
    Case "mdb", "accdb"
        GetProvider = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & dbSrc
        
    Case "udl"
        GetProvider = "File Name=" & dbSrc
    
    Case "sqlite"
        '个人习惯使用的sqlite数据库的后缀
        GetProvider = "Provider=SQLITEDB;Data Source=" & dbSrc
        
    End Select
End Function

Private Function GetExt(ByVal FullPath As String) As String
    Dim i As Long
    '先找到文件名，避免一下路径中可能存在的"."
    FullPath = GetName(FullPath)
    
    i = VBA.InStrRev(FullPath, ".")
    If i Then
        GetExt = VBA.Mid$(FullPath, i + 1)
    Else
        GetExt = ""
    End If
End Function

Private Function GetName(ByVal FullPath As String) As String
    Dim i As Long
    i = VBA.InStrRev(FullPath, "\")
    
    If i Then
        GetName = VBA.Mid$(FullPath, i + 1)
    Else
        GetName = FullPath
    End If
End Function

Private Function GetExtByBin(dbPath As String) As String
    Dim b() As Byte
    ReDim b(&H12) As Byte
    
    ReadTxtByOpenBin dbPath, b
    
    Dim str As String
    str = VBA.StrConv(b, vbUnicode)
    
    If VBA.InStr(str, "SQLite format 3") Then
        GetExtByBin = "sqlite"
    ElseIf VBA.InStr(str, "Standard Jet DB") Then
        GetExtByBin = "mdb"
    ElseIf VBA.InStr(str, "Standard ACE DB") Then
        GetExtByBin = "accdb"
        
    ElseIf VBA.Left$(str, 2) = "PK" Then
        'TODO 判断的过于简单
        GetExtByBin = "xlsx"
        
    Else
        GetExtByBin = ""
    End If
End Function

Private Function ReadTxtByOpenBin(txtName As String, b() As Byte) As Long
    Dim num_file As Integer
    
    num_file = VBA.FreeFile
    
    Open txtName For Binary Access Read As #num_file
    Get #num_file, 1, b
    
    Close #num_file
End Function