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

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

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

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

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