使用 VBA 将 MS Access 数据库查询导入 Excel，无需登录提示

Import MS Access Database Query into Excel using VBA without Login Prompt

提问by user2465349

I am trying to import an MS Access query into excel without triggering the log-in prompt. I have attempted this operation a few different ways, but both methods haven't given me a complete solution.

我正在尝试将 MS Access 查询导入 excel 而不触发登录提示。我尝试了几种不同的方法，但这两种方法都没有给我一个完整的解决方案。

Specifics:

规格：

1. My access query source is an unprotected access database file (database1.accdb) built in MS Access 2010. This database gets tables from different sources (by use of linked tables) and performs data processing. One of these sources requires a password, so when I run the query, a log-in prompt comes up asking me for credentials (which I have). I have no issues with the query itself.

2. My excel spreadsheet (built in excel 2010) contains VBA code that retrieves tables from other data sources and some of them require authentication as well, so I built a custom prompt that lets a user enter credentials for all the tables.

1. 我的访问查询源是在 MS Access 2010 中构建的未受保护的访问数据库文件 (database1.accdb)。该数据库从不同来源获取表（通过使用链接表）并执行数据处理。其中一个来源需要密码，所以当我运行查询时，会出现一个登录提示，要求我提供凭据（我有）。我对查询本身没有问题。

2. 我的 excel 电子表格（内置于 excel 2010）包含从其他数据源检索表的 VBA 代码，其中一些还需要身份验证，因此我构建了一个自定义提示，让用户输入所有表的凭据。

The problem here is that I have a prompt coming up in the excel spreadsheet that asks the user for log-in information, but then another prompt comes up when the access query is imported. Here's what I've tried to do to handle the problem:

这里的问题是我在 excel 电子表格中出现一个提示，要求用户提供登录信息，但在导入访问查询时出现另一个提示。这是我尝试做的来处理这个问题：

Method 1: Using the Macro Recorder:

方法 1：使用宏记录器：

I used excel's built in macro recorder to follow my manual steps in importing the access query. When I'm recording the macro, the imports works and the query comes in with no errors as expected. However, when I try to run the macro, I get a runtime error:

我使用 excel 的内置宏记录器来按照我的手动步骤导入访问查询。当我录制宏时，导入工作并且查询按预期没有出现错误。但是，当我尝试运行宏时，出现运行时错误：

"Run-time error '1004':

The query did not run, or the database could not be opened. Check the database  
server or contact your database administrator. Make sure the external database  
is available and has not been moved or reorganized, then try the operation  
again."

Code from Macro Recorder:

来自宏记录器的代码：

Sub Macro2()

    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;" _
        , "Data Source=C:\Database1.accdb;Mode=Share Deny Write;" _
        , "Extended Properties="""";Jet OLEDB:System database="""";" _
        , "Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";" _
        , "Jet OLEDB:Engine Type=6;Jet OLEDB:Database Locking Mode=0;" _
        , "Jet OLEDB:Global Partial Bulk Ops=2;" _
        , "Jet OLEDB:Global Bulk Transactions=1;" _
        , "Jet OLEDB:New Database Password="""";" _
        , "Jet OLEDB:Create System Database=False;" _
        , "Jet OLEDB:Encrypt Database=False;" _
        , "Jet OLEDB:Don't Copy Locale on Compact=False;" _
        , "Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;" _
        , "Jet OLEDB:Support Complex Data=False;" _
        , "Jet OLEDB:Bypass UserInfo Validation=False"), _
        Destination:=Range("$A")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("Query3")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = "C:\Database1.accdb"
        .ListObject.DisplayName = "Table_Database1"
        .Refresh BackgroundQuery:=False
    End With
    Range("I3").Select

End Sub

My guess as to why this macro doesn't work (but the manual steps do) is because some parameters are ignored by the recorder. If I removed the quotes from some of the password fields, the code doesn't error out, but I get the log-in prompt again. I was hoping someone on here can see if there's a missing parameter or an incorrectly assigned parameter.

我对为什么这个宏不起作用（但手动步骤起作用）的猜测是因为记录器忽略了某些参数。如果我从某些密码字段中删除引号，代码不会出错，但我会再次收到登录提示。我希望这里有人可以查看是否缺少参数或分配的参数不正确。

Method 2: Using the DAO Library:

方法二：使用DAO库：

For this method, I had to make a few changes. First I had to add a reference in my editor for "Microsoft DAO 3.6 Object Library". Then I had to covert my .accdb file to a .mdb file so I can use the DAO functions:

对于这种方法，我必须进行一些更改。首先，我必须在我的编辑器中为“Microsoft DAO 3.6 Object Library”添加一个引用。然后我不得不将我的 .accdb 文件转换为 .mdb 文件，以便我可以使用 DAO 函数：

Code for DAO Method:

DAO 方法的代码：

Sub Macro3()

    Dim db1 As Database
    Dim db2 As Database
    Dim recSet As Recordset
    Dim strConnect As String

    Set db1 = OpenDatabase("C:\Database1.mdb")
    strConnect = db1.QueryDefs("Query3").Connect _
    & "DSN=myDsn;USERNAME=myID;PWD=myPassword"

    Set db2 = OpenDatabase("", False, False, strConnect)
    db2.Close
    Set db2 = Nothing

    Set recSet = db1.OpenRecordset("Query3")

    With ActiveSheet.QueryTables.Add(Connection:=recSet, Destination:=Range("$A"))
        .Name = "Connection"
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False

    End With

    recSet.Close
    db1.Close
    Set recSet = Nothing
    Set db1 = Nothing

End Sub

This method works and I can bypass the database's log-in prompt... as long as my query doesn't return a large amount of records. When I was returning up to ~60,000 records, the code would not take more than 5-10 seconds to get a result. However, when I tried pulling more than ~100,000 records, excel would become unresponsive and hang (I let the code run for about 10 minutes before I stopped it). I'm thinking I've hit some limitation on the DAO, other than that I can't find documentation that addresses this.

这种方法有效，我可以绕过数据库的登录提示……只要我的查询不返回大量记录。当我返回大约 60,000 条记录时，代码不会花费超过 5-10 秒的时间来获得结果。但是，当我尝试提取超过 100,000 条记录时，excel 会变得无响应并挂起（我让代码运行了大约 10 分钟，然后才停止）。我想我在 DAO 上遇到了一些限制，除此之外我找不到解决这个问题的文档。

Any assistance is appreciated.

任何帮助表示赞赏。

采纳答案by user2465349

I did some more research and testing and was able to get myself out of this hole. The reason why excel would hang when using the CopyFromRecordsetmethod is because I was trying to bring in more than 65,000 records at once. Apparently, MS Access did not follow excel when its record limit was increased from 65,000 to 1,000,000 records.

我做了更多的研究和测试，并且能够让自己走出这个坑。使用该CopyFromRecordset方法时excel会挂掉的原因是因为我试图一次引入超过65,000条记录。显然，当 MS Access 的记录限制从 65,000 条增加到 1,000,000 条记录时，它并没有遵循 excel。

What I did for a workaround is to open the query and retrieve smaller chunks of records (<=65,000) at a time by using a loop. The code that worked for me is shown below.

我为解决方法所做的是打开查询并使用循环一次检索较小的记录块 (<=65,000)。对我有用的代码如下所示。

Dim daoDB As DAO.Database
Dim daoQueryDef As DAO.QueryDef
Dim daoRcd As DAO.Recordset
Dim daoFld As DAO.Field
Dim i As Integer 'number to track field position
Dim j As LongPtr 'number to track record position (>32,767; cannot be integer)
Dim k As LongPtr 'represents retrieval limit of CopyFromRecordSet method

'notify user of progress
Application.StatusBar = False
Application.StatusBar = "opening query..."

'set up database connection and authentication for query
Set daoDB = OpenDatabase("C:\myFile.mdb")

strConnect = daoDB.QueryDefs("myQuery").Connect _
& "DSN=myDsn;USERNAME=myName;PWD=myPass "
Set daoDB2 = OpenDatabase("", False, False, strConnect)
daoDB2.Close
Set daoDB2 = Nothing

'open the desired query and recordset
Set daoQueryDef = daoDB.QueryDefs("myQuery")
Set daoRcd = daoQueryDef.OpenRecordset(dbOpenSnapshot, dbReadOnly)

'set up the fields in excel
i = 0
With Range("A1")
    For Each daoFld In daoRcd.Fields
    .Offset(0, i).Value = daoFld.Name
    i = i + 1
    Next daoFld
End With

'set up counters and perform record import while updating the user
j = 2
k = 30000
Application.StatusBar = False
Application.StatusBar = "importing... 0"

Do While Not daoRcd.EOF
    ThisWorkbook.Worksheets("Sheet1").Range("A" & j).CopyFromRecordset _
    daoRcd, k
    j = j + k
    Application.StatusBar = False
    Application.StatusBar = "importing... " & j

    'if end of file is reached, end the loop, otherwise continue importing
    If daoRcd.EOF = True Then
    Else
        daoRcd.MoveNext
    End If
Loop

'close the remaining connections
Application.StatusBar = False
daoRcd.Close
daoDB.Close
Set daoRcd = Nothing
Set daoDB = Nothing

Range("A1").Select

I'd like to note a few things I came across in the code building:

我想指出我在代码构建中遇到的一些事情：

1. The dbOpenSnapshot option in the OpenRecordsetmethod is important, because the other options (such as dbOpenDynamic) could more than double the run-time depending on how many operations there are.
2. This macro may have to be modified if it will be used in a 64-bit environment.
3. The CopyFromRecordsetmethod doesn't bring back the field headers automatically, so I added a loop to do this beforehand.
4. The CopyFromRecordsetmethod doesn't give the user any indication if the process is finished or not, so I added period status bar messages using the Application.StatusBarproperty.
5. Even though the loop stops when the end of the file is reached, I was still getting a run-time error when the last record was imported before the start of the next loop iteration, so I added an end-of-file check at the end of the loop.

1. 该OpenRecordset方法中的 dbOpenSnapshot 选项很重要，因为其他选项（例如 dbOpenDynamic）可能会使运行时间增加一倍以上，具体取决于操作的数量。
2. 如果要在 64 位环境中使用此宏，则可能必须对其进行修改。
3. 该CopyFromRecordset方法不会自动带回字段标题，因此我预先添加了一个循环来执行此操作。
4. 该CopyFromRecordset方法不会向用户指示该过程是否完成，因此我使用该Application.StatusBar属性添加了期间状态栏消息。
5. 即使到达文件末尾时循环停止，但在下一次循环迭代开始之前导入最后一条记录时，我仍然收到运行时错误，因此我在循环结束。

In summary, this code allows me to effectively stop MS Access from giving me a log-in prompt when I try to import an Access query whose source is protected. This is not the same protection that is found in the .mdb file itself (which can be specified in the connection string to the file).

总之，当我尝试导入源受保护的 Access 查询时，此代码允许我有效地阻止 MS Access 向我提供登录提示。这与 .mdb 文件本身（可以在文件的连接字符串中指定）中找到的保护不同。

回答by Transformer

Try this :

尝试这个 ：

Sub ShowData()


   Dim daoDB            As DAO.Database
   Dim daoQueryDef      As DAO.QueryDef
   Dim daoRcd           As DAO.Recordset

    Set daoDB = OpenDatabase("C:\Database1.mdb")  
    Set daoQueryDef = daoDB.QueryDefs("Query3")

    Set daoRcd = daoQueryDef.OpenRecordset
    ThisWorkbook.Worksheets("Sheet1").Range("A4").CopyFromRecordset daoRcd


End Sub

OR this...in this case you need to write your complete query in VBA window

或者这...在这种情况下，您需要在 VBA 窗口中编写完整的查询

Sub new1()

    Dim objAdoCon       As Object
    Dim objRcdSet       As Object

    Set objAdoCon = CreateObject("ADODB.Connection")
    Set objRcdSet = CreateObject("ADODB.Recordset")    


     objAdoCon.Open "Provider = Microsoft.Jet.oledb.4.0;Data Source = C:\Database1.mdb" 
     objRcdSet.Open "Write ur Query Here", objAdoCon

     ThisWorkbook.Worksheets("Sheet1").Range("A1").CopyFromRecordset objRcdSet

    Set objAdoCon = Nothing
    Set objRcdSet = Nothing

End Sub