在Access VBA中更新Excel Application.StatusBar

我目前的情况：

我正在开发embedded在excel文件（名为“Dashboard.xlsm”和访问文件“Dashboard.accdb”）中的VBA程序的顶点。 这两个文件通过VBA互相交谈，以帮助我为我的公司分析一些数据。 因为这些程序正在分发给几个经理，如果某些事情在3秒钟内没有完成，我就需要一个很好的方法来指出在Excel中运行的SQL查询的进度（因为Access在背景）。

我目前的Excel代码：

Sub generateFRMPComprehensive_ButtonClick(Optional sheetName As Variant) Application.ScreenUpdating = False Dim directoryPath As String Dim cn As Object Dim rs As Object Dim strCon As String Dim strSQL, strInput As String Dim sArray As Variant Dim appAccess As Access.Application Dim directoryName oldStatusBar = Application.DisplayStatusBar Application.DisplayStatusBar = True directoryName = Application.ActiveWorkbook.Path directoryPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Dashboard Exports" Application.ScreenUpdating = False If IsMissing(sheetName) Then sheetName = Application.InputBox("Sheet Name?", "Sheet Selection") If sheetName = "False" Then Exit Sub Else End If If FileFolderExists(directoryPath) = 0 Then Application.StatusBar = "Creating Export Folder" MkDir directoryPath End If End If '-- Set the workbook path and name reportWorkbookName = "Report for " & sheetName & ".xlsx" reportWorkbookPath = directoryPath & "\" & reportWorkbookName '-- end set '-- Check for a report already existing If FileExists(reportWorkbookPath) = True Then Beep alertBox = MsgBox(reportWorkbookName & " already exists in " & directoryPath & ". Do you want to replace it?", vbYesNo, "File Exists") If alertBox = vbYes Then Kill reportWorkbookPath '-- Run the sub again with the new sheetName, exit on completion. generateFRMPComprehensive_ButtonClick (sheetName) Exit Sub ElseIf alertBox = vbNo Then Exit Sub ElseIf alertBox = "False" Then Exit Sub End If End If '-- End check '- Generate the report '-- Create new access object Set appAccess = New Access.Application '-- End Create '-- Open the acces project Application.StatusBar = "Updating Access DB" Call appAccess.OpenCurrentDatabase(directoryName & "\Dashboard.accdb") appAccess.Visible = False '-- End open '-- Import New FRMP Data Application.StatusBar = "Running SQL Queries" appAccess.Application.Run "CleanFRMPDB", sheetName, directoryName & "\Dashboard.xlsm" '-- End Import Workbooks.Add ActiveWorkbook.SaveAs "Report for " & sheetName ActiveWorkbook.Close appAccess.Application.Run "generateFRMPReport_Access", reportWorkbookPath Workbooks.Open (reportWorkbookPath) End Sub 

我现在的访问码：

 Public Sub generateFRMPReport_Access(excelReportFileLocation As String) Dim queriesList As Variant queriesList = Array("selectAppsWithNoHolds", _ "selectAppsWithPartialHolds", _ "selectAppsCompleted", _ "selectAppsCompletedEPHIY", _ "selectAppsByDivision", _ "selectAppsByGroup", _ "selectAppsEPHIY", _ "selectAppsEPHIN", _ "selectAppsEPHIYN", _ "selectApps") For i = 0 To 9 DoCmd.TransferSpreadsheet acExport, , queriesList(i), _ excelReportFileLocation, True Next i End Sub 

我的请求：

有没有一种方法可以在Access中的for循环中调用Application.DisplayStatusBar并传递正在运行的查询的名称？

或者，还可以使用其他方式显示此信息？

谢谢！！

Answer 1

你有几个select来实现这一点，但最明显的两个是：

1. 从 Excel执行查询，并从 Excel更新状态栏
2. 从 Access执行查询，但将Excel应用程序引用传递到Access，以便Access可以callback到Excel状态栏。

正如你从Excel驱动的活动，你已经有了访问应用程序的参考，第一个选项是最合乎逻辑的。 第二种方法是可能的 – 您只需要将Excel对象传递给Access，但是您将使用Excel自动执行Access以使Excel自动运行。

您需要将Access VBA中的generateFRMPReport_Access过程移动到Excel VBA中，并将您的调用修改为generateFRMPComprehensive_ButtonClick

 Sub generateFRMPComprehensive_ButtonClick(Optional sheetName As Variant) '... 'appAccess.Application.Run "generateFRMPReport_Access", reportWorkbookPath generateFRMPReport_Access reportWorkbookPath, appAccess '... End Sub Public Sub generateFRMPReport_Access(excelReportFileLocation As String, appAccess As Access.Application) Dim queriesList As Variant Dim i As Long queriesList = Array("selectAppsWithNoHolds", _ "selectAppsWithPartialHolds", _ "selectAppsCompleted", _ "selectAppsCompletedEPHIY", _ "selectAppsByDivision", _ "selectAppsByGroup", _ "selectAppsEPHIY", _ "selectAppsEPHIN", _ "selectAppsEPHIYN", _ "selectApps") Application.DisplayStatusBar = True For i = 0 To 9 Application.StatusBar = "Running query " & (i + 1) & " of 9" appAccess.DoCmd.TransferSpreadsheet acExport, , queriesList(i), _ excelReportFileLocation, True Next i Application.StatusBar = False Application.DisplayStatusBar = False End Sub