在Access VBA

Question

我目前的情况：

我正在开发嵌入excel文件（名为“Dashboard.xlsm”和访问文件“Dashboard.accdb”）中的VBA程序的高潮。这两个文件通过VBA相互通信，以帮助我对我需要为公司分析的数据做一些繁重的工作。因为这些程序正在分发给几个在3秒内没有完成某些事情而感到恐慌的管理员，我需要一个很好的方法来指示在Access中通过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

您可以选择实现这一目标，但最明显的两个选择是：

1. 从 Excel执行查询，并从 Excel
更新状态栏
2. 从 Access执行查询，但将Excel Application引用传递给Access，以便Access可以回调到Excel状态栏。

由于您正在从Excel驱动活动，而已经引用了Access应用程序，因此第一个选项是最合乎逻辑的。第二种方法是可行的 - 您只需将Excel对象传递给Access，然后您就可以使用Excel自动执行Access以自动化Excel。

您需要将generateFRMPReport_Access程序从Access VBA移至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