更新Excel的数据库查询函数库

作者:, 发表于

办公自动化

查看该系列所有文章

更新一下之前写的Excel的数据库类,将其改成函数的形式,调用更简单(省却了生成类实例的步骤)。现在这个代码在工作中用了一年多,已经比较健壮。若有问题,请留言指出或与我联系。

这些代码有如下优势:

  • 无需任何配置。在VBA中新建模块,并把代码复制转帖过去即可使用。
  • 有以下函数:执行数据库语句、查询数据库、结果复制到单元格(Excel中最常用)、将Excel表格上传到数据库。基本覆盖Excel中对数据库的常用操作。
  • 会在立即窗口显示数据库错误信息,方便查错。
  • 在数据库连接字符串字典中配好数据库连接信息后,数据库访问时可直接使用配好的链接字符串。

具体的函数用法已经写在下面代码注释里。简单描述一下:

  • dqQueryToArray(sql, connection_string) 查询数据库,返回一个二维数组
  • dbQueryOne(sql, connection_string) 查询数据库,返回单个变量。
  • dbQueryToCell(sql, range, connection_string, withHeader) 查询数据库后,将结果显示在range开始的区域中;withHeader控制是否显示列名。
  • dbExec(sql, necction_string) 执行数据库语句;无返回值
  • dbInsertRange(table, range, connection_string, is_empty) 将本Excel文件的range区域里的数据插入到数据库的表table。其中is_empty控制在上传数据前是否清空table的原数据。

其它就看一下代码吧:

' EXCEL的ADO数据库操作函数库
' 这些代码应该放在Excel的VBA模块中,类模块的名字为database,并以以下形式引用:
'
' res = dbQueryToArry(sql, connection_string)
'    ' 返回sql的查询结果,结果为一个二维数组
' res = dbQueryOne(sql, connection_string)
'    ' 返回sql的查询结果,但只返回第一个数据(相当于数据库查询结果的左上角那个数据)
' dbQueryToCell sql, save_to_range, connection_string, withHeader
'    ' 将sql的查询结果直接写入到以save_to_range开头的单元格区域中
'    ' withHeader控制是否复制表头,默认为true(复制表头)
'
' 其中参数sql为数据库查询语句,connection_string为数据库连接字符串。
'
' 比如要连接SQL数据库,并已经设置ODBC,连接字符串为:
'   "Provider=MSDASQL;DSN=odbc_name;UID=username;PWD=password;database=database_name;"
' 如果未设置ODBC,连接字符串为:
'   "driver={SQL Server};server=service_name_or_ip;uid=username;pwd=password;database=database_name;"
' 其中最后面的database变量可省略。对于SQL Server,推荐使用后一种方法。
'
' 如果数据来源为Excel文件,connection_string参数可省略
'
' 其它功能:内置数据库的连接字符串、查询存储过程
'
' Author: zhang@zhiqiang.org, 2014-03-01 v4
' url: http://zhiqiang.org/blog/it/excel-vba-database-functions.html

Private sqlDict As Object        ' 缓存数据
Private cnn As Object, rst As Object, lastConn As String

Private Sub dbInitialize()
    If Not sqlDict Is Nothing Then Exit Sub

    Set sqlDict = CreateObject("scripting.Dictionary")
    lastConn = ""

    ' 在这里可以缓存一些常用的数据库信息,这样在查询数据库时可以直接调用
    ' 比如dbQueryToArry(sql, "this")

    With sqlDict
        .Add "SQL服务器", _
             "Provider=MSDASQL;DSN=odbc_name;UID=username;PWD=password;database=database_name;"
        .Add "SQL服务器(无需配置ODBC)", _
             "driver={SQL Server};server=ip;uid=username;pwd=password;database=database_name;"
        .Add "this", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
                     ";Extended Properties=Excel " & Application.Version & ";"
    End With
End Sub

' 查询数据库,返回RecordSet对象
' sql: 数据库查询语句
' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等,
'   利用内设的数据库连接信息
Public Function dbQuery(sql As String, _
                      Optional ByVal sqlConnectString As String = "this") As Object        ' ADODB.Recordset
    dbConnectSQL sqlConnectString

    On Error GoTo errorhander
    rst.Open sql, cnn

    Set dbQuery = rst

errorhander:
    dbDisplayError sql
End Function

' 查询数据库,返回一个数组
' sql: 数据库查询语句
' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等,
'   利用内设的数据库连接信息
Public Function dbQueryToArray(sql As String, _
                             Optional ByVal sqlConnectString As String = "this")
    dbConnectSQL sqlConnectString

    On Error GoTo errorhander

    rst.Open sql, cnn
    dbQueryToArray = rst.GetRows(10000000)
errorhander:
    DisplayError sql
End Function

' 查询数据库,返回单个数值
' sql: 数据库查询语句
' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等,
'   利用内设的数据库连接信息
Public Function dbQueryOne(sql As String, _
                         Optional ByVal sqlConnectString As String = "this")
    dbConnectSQL sqlConnectString
    On Error GoTo errorhander

    rst.Open sql, cnn
    dbQueryOne = rst.Fields.Item(0).value

errorhander:
    dbDisplayError sql
End Function

' 查询数据库,返回单个数值
' sql: 数据库查询语句
' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等,
'   利用内设的数据库连接信息
Public Function dbQueryToCell(sql$, Optional rng As Excel.Range, _
                            Optional ByVal sqlConnectString$ = "this", _
                            Optional withHeader As Boolean = True)
    On Error GoTo error_handler
    dbConnectSQL sqlConnectString

    rst.Open sql, cnn

    Set rng = rng.Cells(1, 1)

    If withHeader = True Then
        Dim i As Long
        For i = 0 To rst.Fields.Count - 1
            rng.Offset(0, i).value = rst.Fields(i).Name
        Next
        rng.Offset(1, 0).CopyFromRecordset rst
    Else
        rng.CopyFromRecordset rst
    End If

error_handler:
    dbDisplayError sql
End Function

' 执行任意数据库语句,无返回结果。如需返回结果,请使用Query、QueryOne、QueryToCell等函数
' sql: 数据库查询语句
' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等,利用内设的数据库连接信息
Sub dbExec(ByVal sql As String, _
                         Optional ByVal sqlConnectString As String = "this")
    dbConnectSQL sqlConnectString

    On Error GoTo errorhander

    cnn.Execute sql

errorhander:
    dbDisplayError sql
End Sub

' 这个函数用来上传一个Excel区域到数据库,数据表必须事先建好,并且包括Excel区域的第一行
' Database.InsertRange(table, rng, sqlConnectString, isEmpty)
'   table:Excel数据将上传到这个表内
'   rng: 将被上传的Excel区域
'   sqlConnectString: 数据库连接字符串
'   isEmpty: 是否清空原有表格数据
Public Function dbInsertRange(table$, rng As Excel.Range, Optional ByVal sqlConnectString$ = "this", _
        Optional isEmpty As Boolean = False)

    dbConnectSQL sqlConnectString
    On Error Resume Next

    If isEmpty Then dbExec "delete from " & table, sqlConnectString$

    Dim r As Long, sqlHead$, i As Long

    ' 首选根据isEmpty选项,删除原表内所有数据
    For i = 1 To rng.Columns.Count
        sqlHead = sqlHead & ",[" & rng.Cells(1, i) & "]"
    Next i

    ' 其次,依次拆入每行
    ' 目前每一行都需运行一个SQL语句,效率较低,如果数据量较大,可能会引起Excel死机
    sqlHead = "insert into " & table & " (" & mid(sqlHead, 2, 10000000) & ") values "

    For r = 2 To rng.rows.Count
        Dim sql$

        sql = ""
        For i = 1 To rng.Columns.Count
            Dim v
            v = rng.Cells(r, i).value()
            If IsError(v) Then v = ""
            If IsDate(v) Then
                sql = sql & ",'" & Format(v, "yyyy-mm-dd") & "'"
            ElseIf v <> "" And IsNumeric(v) Then
                sql = sql & "," & v
            Else
                sql = sql & ",'" & v & "'"
            End If
        Next i

        dbExec sqlHead & " (" & mid(sql, 2, 1000000) & ")", sqlConnectString$
    Next r
End Function

' 查询存储过程,返回的是ADODB.RecordSet对象
Public Function dbQueryStoredProc(procName$, para, _
                                Optional ByVal sqlConnectString As String = "this", _
                                Optional returnPara As Boolean = True) As Object        'ADODB.Recordset

    On Error GoTo errorhander
    dbConnectSQL sqlConnectString

    With com
        .ActiveConnection = cnn
        .CommandType = adCmdStoredProc

        .CommandText = procName

        ' 获取存储过程的参数定义
        .Parameters.Refresh

        ' 如果存在输出参数,则删除它,默认第一个为输出参数
        On Error Resume Next
        If returnPara Then .Parameters.Delete 0

        ' 设置输入参数的值
        If IsArray(para) Then
            Dim i
            For i = 0 To UBound(para)
                .Parameters.Item(i).value = para(i)
            Next i
        End If

        ' 改变输入参数大小
        Dim tmpp
        For Each tmpp In .Parameters
            tmpp.Size = 255
        Next tmpp

        ' 获取参数返回值
        Set dbQueryStoredProc = .Execute()
    End With

errorhander:
    DisplayError sql
End Function

Private Sub dbClose()
    ' 当类被注销时,断开数据库连接
    On Error Resume Next
    If cnn.State <> 0 Then cnn.Close
End Sub

' 连接数据库
' 此处首先检查cnn是否已经连接到想要连接的数据库,如果已经连接,将不产生任何操作
' 本Database对象在对象存续过程中,不会主动断开;
' 只有在对象注销之时,才断开数据库,如需断开数据库连接,请set db = nothing
Private Function dbConnectSQL(ByVal sqlConnectString$) As String
    On Error Resume Next
    Call dbInitialize

    If sqlDict.Exists(LCase(sqlConnectString)) Then
        sqlConnectString = sqlDict.Item(LCase(sqlConnectString))
    End If

    If rst Is Nothing Then Set rst = CreateObject("ADODB.Recordset")
    If cnn Is Nothing Then Set cnn = CreateObject("ADODB.Connection")
    If cnn.State <> 1 Or lastCnn <> sqlConnectString Then
        cnn.Close
        Set cnn = Nothing
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open sqlConnectString
        lastConn = sqlConnectString
    End If

    dbConnectSQL = sqlConnectString
End Function

' 显示查询数据库过程中出现的错误信息,信息被显示在立即窗口。
Private Sub dbDisplayError(sql$)
    Dim e
    If cnn.Errors.Count > 0 Then
        Debug.Print cnn.Errors.Count & " errors found when exec """ & sql & """"
        For Each e In cnn.Errors
            Debug.Print "Error info: " & e.description & " Source: " & e.Source
        Next e
    End If
End Sub

 

Q.E.D.


上一篇:Excel文件作为数据库源时如何判断数据类型2014年3月17日
在前面的文章里,我已经提到Excel数据本身可以当做一张SQL查询的数据表,并在Excel内进行数据库运算操作。数据库查询函数可以用我之前写的Excel数据

下一篇:VBA调用Lotus发送邮件的收件人长度问题2014年6月12日
通过VBA发送Lotus邮件,收件人列表不能超过256个字节,否则会被截断,从而丢失一部分收件人。可以通过分割成不超过256长度的字符串列表解决。


  • 支持使用微薄、微信和QQ的账户登陆进行评论。由各自网站直接认证,不会泄露你的密码。
  • 登陆后可选择分享评论到所绑定的社交网络,如微薄、人人和QQ空间。
  • 评论提交后无法修改。如需修改,请删除原评论再重新提交。
  • 评论支持LaTeX代码,行内公式请用\(a+b=c\),行间公式请用\[a+b=c\]。公式只支持英文字符。