ADOX

ADOX 简介

ADOX 是 Microsoft ActiveX Data Objects Extensions for Data Definition Language and Security 的缩写，它是对 ADO 对象和编程模型的扩展。ADOX 可以用来执行一系列用 ADO 无法单独实现的功能。例如，要想使用 ADO 对已有的数据库结构进行修改非常麻烦，但使用 ADOX 就可以很容易做到，同时 ADOX 还提供了数据库相关信息工具，例如获取数据表个数、数据表名称等。

要使用 ADOX，需要建立对 ADOX 的引用，ADOX 库是 Microsoft ADO Ext. 2.8 for DDL and Security，如下图所示：

ADOX 最上层对象是 Catalog。它的下级对象包括 Tables 集合、Groups 集合、Users 集合、Procedures 集合、Views 集合，而这些集合又包括各自的 Table 对象、Groups 对象、Users 对象、Procedures 对象、Views 对象。

Tables 集合包含了目录的所有 Table 对象。Table 对象就是数据库中的表对象（包括系统表对象、数据表对象和查询表对象等）。

引用 Tables 集合中的 Table 对象有以下三种方式：

1. 使用编号：如 Tables(0) 是第 1 个数据表，Tables(1) 表示第 2 个数据表。
2. 使用 Table 对象的名称，如 Tables("数据") 表示名称为“数据”的数据表。
3. 使用对象的属性，如 Tables![数据] 表示名称为“数据”的数据表。

Table 对象的常用属性有 Name、Type、DateCreated 属性和 DateModified 属性。

• Name 属性：返回表的名称。
• Type 属性：返回表的类型。
• DateCreated 属性：返回表的创建日期。
• DateModified 属性：返回表的最后一次修改日期。

注意： ADOX 获取的工作表名称都有后缀“$”，要想使用工作表名，需使用 Replace 函数进行替换。

1.1 获取工作簿中的所有工作表名称

用 ADOX 获取代码如下：

Sub tt()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("汇总表")
    Dim cat As New ADOX.Catalog
    Dim tabl As ADOX.Table
    cat.ActiveConnection = "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;datasource=" & ThisWorkbook.FullName
    ws.Range("a1") = "表名"
    i = 2
    For Each tabl In cat.Tables
        If tabl.Type = "TABLE" Then
            ws.Range("a" & i) = Replace(tabl.Name, "$", "")
            i = i + 1
        End If
    Next
End Sub

1.2 获取数据表中的字段信息

用 ADOX 获取代码如下：

Sub ttt()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("汇总表")
    Dim cat As New ADOX.Catalog
    Dim col As ADOX.Column
    Dim i As Integer
    i = 1
    cat.ActiveConnection = "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;datasource=" & ThisWorkbook.FullName
    For Each col In cat.Tables("表一$").Columns
        ws.Range("c" & i) = col.Name
        i = i + 1
    Next
    Set cat = Nothing
    Set col = Nothing
End Sub

如下图所示，文件夹“案例5-1源文件”里保存的几个店铺数据，现在的任务是这几个工作簿数据汇总到当前工作簿中，即在当前工作簿中每插入一个工作表，命名为文件夹中每个工作簿的名字，并把该工作簿中每个工作表数据循环添加进来。最后再把当前工作簿所有的数据合并到“汇总表”工作表中。

代码如下：

Sub tt()
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim mycat As ADOX.Catalog
    Dim sql, x As String
    Dim file() As String, FileStr As String, n As Integer, PathStr As String
    Dim arr() As String
    With Application.FileDialog(msoFileDialogFolderPicker) ' 创建文件对话框的实例
        If .Show Then ' 如果在对话框中单击了"确定"
            PathStr = .SelectedItems(1) ' 将选定的路径赋予变量
        Else
            Exit Sub ' 否则退出程序
        End If
    End With
    On Error Resume Next
    FileStr = Dir(PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & "*.xl*") ' 获取路径下第一个文件名
    While Len(FileStr) > 0 ' 只要文件名长度大于0就循环下去
        n = n + 1 ' 累加变量，该变量等于文件个数
        ReDim Preserve file(1 To n)
        file(n) = PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & FileStr ' 将路径与文件名逐个写入数组
        FileStr = Dir()
    Wend ' Wend 是 VBScript 和 VBA 中的关键字，用于结束 While 循环
    For i = 1 To UBound(file)
        ReDim Preserve arr(1 To UBound(file))
        Set fso = CreateObject("scripting.filesystemobject")
        arr(i) = fso.GetBaseName(file(i)) ' GetBaseName 方法返回路径中最后部件的基本名字（去掉扩展名）
    Next i
    If n = 0 Then MsgBox "没发现excel文件": Exit Sub ' 如果没有文件则退出程序
    On Error Resume Next
    Application.DisplayAlerts = False
    For i = 1 To UBound(file)
        ThisWorkbook.Worksheets(arr(i)).Delete
    Next i
    For i = 1 To UBound(file)
        Set cnn = New ADODB.Connection
        With cnn
            .Provider = "microsoft.ace.oledb.12.0"
            .ConnectionString = "extended properties=excel 12.0;data source=" & file(i)
            .Open
        End With
        Set mycat = New ADOX.Catalog
        mycat.ActiveConnection = "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;datasource=" & file(i)
        sql = ""
        For j = 1 To mycat.Tables.Count - 1 ' 从第一个到倒数第二个工作表循环
            x = Replace(mycat.Tables(j - 1).Name, "'", "")
            sql = sql & "select '" & arr(i) & "' as 店铺,'" & Replace(x, "$", "") & "' as 月份,* from [" & x & "] union "
        Next j
        x = Replace(mycat.Tables(mycat.Tables.Count - 1).Name, "'", "") ' 获取最后一个工作表的名字，最后一个语句不用 union
        sql = sql & "select '" & arr(i) & "' as 店铺,'" & Replace(x, "$", "") & "' as 月份,* from [" & x & "]"
        Set rs = New ADODB.Recordset
        rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
        Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws.Name = arr(i)
        For j = 1 To rs.Fields.Count
            Cells(1, j) = rs.Fields(j - 1).Name
        Next j
        ws.Range("a2").CopyFromRecordset rs
    Next i
    Set ws = ThisWorkbook.Worksheets("汇总表")
    ws.Cells.Clear
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.ace.oledb.12.0"
        .ConnectionString = "extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
        .Open
    End With
    For j = 1 To UBound(arr) - 1
        sql = sql & "select * from [" & arr(j) & "$] union "
    Next j
    sql = sql & "select * from [" & arr(UBound(arr)) & "$]"
    Set rs = New ADODB.Recordset
    rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    For j = 1 To rs.Fields.Count
        ws.Cells(1, j) = rs.Fields(j - 1).Name
    Next j
    ws.Range("a2").CopyFromRecordset rs
    Application.DisplayAlerts = True
    rs.Close: Set rs = Nothing
    cnn.Close: Set cnn = Nothing
End Sub