Function SendToExcelODBCTableNames()
    Dim objXL As Object
    Dim xlWB As Object
    Dim xlWS As Object
    Dim intCount As Integer
    Dim rst As Dao.Recordset
    Dim strName As String
    Dim strSQL As String
    Dim fld As Dao.Field

    strName = Left(CurrentProject.Name, Len(CurrentProject.Name) - 4)
    strSQL = "Select [Name]," & strName & " As DbName from MSysObjects Where Connect Is Not Null ORDER BY [Name]"

    Set rst = CurrentDb.OpenRecordset("Select [Name], '" & strName & "' As DbName from MSysObjects Where Connect Is Not Null ORDER BY [Name]")
    Set objXL = CreateObject("Excel.Application")
    objXL.Visible = True
    Set xlWB = objXL.Workbooks.Add
    Set xlWS = xlWB.Worksheets("Sheet1")
    intCount = 1

    For Each fld In rst.Fields
        xlWS.Cells(1, intCount).Value = fld.Name
        intCount = intCount + 1
        rst.MoveNext
    Next

    rst.MoveFirst
    xlWS.Range("A2").CopyFromRecordset rst
    objXL.UserControl = True
    Set objXL = Nothing

End Function