VBA Excel 实例在从 MS Access 打开时不会关闭 - 后期绑定

Question

我知道这已经被反复讨论了很多次，但没有一个解决方案适用于我

这是从MS Access 运行的

Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Workbooks.Open CurPath & MainProjectName & ".xlsm", True
ExcelApp.Visible = False
ExcelApp.Quit
Set ExcelApp = Nothing

此外，.xlsm文件在过程结束时执行以下操作

ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

但是.xlsm文件仍然是打开的，隐藏在某个地方。我把它看作是一个实例，而不是一个应用程序，我之所以知道.xlsm文件保持打开，是因为有时excel VBA窗口保持打开(只是VBA窗口，而不是excel窗口(，在那里我可以看到哪个文件的模块在那里。

张贴我的所有代码

这是从MS Access运行并打开xlsm文件的部分

Public Function RunLoadFilesTest()
ODBCConnString
RunVariables
Dim Rs2   As DAO.Recordset
Dim TABLENAME As String
Set Rs2 = CurrentDb.OpenRecordset("SELECT * FROM QFilesToExportEMail")
Do Until Rs2.EOF
TABLENAME = Rs2("TableName")
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, TABLENAME, CurPath & MainProjectName & ".xlsm", True
Rs2.MoveNext
Loop
Rs2.Close
Set Rs2 = Nothing
Set ExcelApp = CreateObject("Excel.Application")
Set ExcelWbk = ExcelApp.Workbooks.Open(CurPath & MainProjectName & ".xlsm", True)
ExcelApp.Visible = False     ' APP RUNS IN BACKGROUND
'ExcelWbk.Close      ' POSSIBLY SKIP IF WORKBOOK IS CLOSED
ExcelApp.Quit
' RELEASE RESOURCES
Set ExcelWbk = Nothing
Set ExcelApp = Nothing

End Function

这是xlsm文件的代码。它从ThisWorkbook模块自动打开。我删除了很多代码，不是为了打乱线程，而是留下了打开工作簿、激活工作簿、关闭等的每一部分。

Public Sub MainProcedure()
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
Application.EnableEvents = False
CurPath = ActiveWorkbook.Path & ""
'this is to deselect sheets
Sheets("QFilesToExportEMail").Select
Sheets("QReportDates").Activate
FormattedDate = Range("A2").Value
RunDate = Range("B2").Value
ReportPath = Range("C2").Value
MonthlyPath = Range("D2").Value
ProjectName = Range("E2").Value

Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Dim i     As Integer
CurRowNum = 2
Set CurRange = Sheets("QFilesToExportEMail").Range("B" & CurRowNum & ":B" & LastRow)
For Each CurCell In CurRange

If CurCell <> "" Then

Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
FirstRowOfSection = ActiveWorkbook.Worksheets("QFilesToExportEMail").Columns(2).Find(ExcelFileName).Row

If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If

If CurRowNum = FirstRowOfSection Then
SheetToSelect = ExcelSheetName
End If

If IsNull(TemplateFileName) Or TemplateFileName = "" Then
Workbooks.Add
Else
Workbooks.Open CurPath & TemplateFileName
End If

ActiveWorkbook.SaveAs MonthlyPath & FinalExcelFileName

For i = CurRowNum To LastRowOfSection
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
Next i
End If

Windows(FinalExcelFileName).Activate
Sheets(SheetToSelect).Select

ActiveWorkbook.Save
ActiveWorkbook.Close

If LastRowOfSection >= LastRow Then
Exit For
End If

Next
Set CurRange = Sheets("QFilesToExportEMail").Range("A2:A" & LastRow)
For Each CurCell In CurRange
If CurCell <> "" Then
CurSheetName = CurCell
If CheckSheet(CurSheetName) Then
Sheets(CurSheetName).Delete
End If
End If
Next

Sheets("QFilesToExportEMail").Delete
Sheets("QReportDates").Delete

ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

Answer 1

由于工作簿对象没有像处理应用程序对象那样完全释放，因此底层进程仍然存在。但是，这需要您分配工作簿对象以便以后发布。

Dim ExcelApp As object, ExcelWbk as Object
Set ExcelApp = CreateObject("Excel.Application")
Set ExcelWbk = ExcelApp.Workbooks.Open(CurPath & MainProjectName & ".xlsm", True)
ExcelApp.Visible = False     ' APP RUNS IN BACKGROUND

'... DO STUFF
' CLOSE OBJECTS
ExcelWbk.Close
ExcelApp.Quit
' RELEASE RESOURCES
Set ExcelWbk = Nothing
Set ExcelApp = Nothing

这适用于任何COM连接的语言，如VBA，包括：

• Python:WIN32COM将多张图纸保存/导出为PDF
• R： 如何将Excel工作表区域从R中导出到图片，以及
• PHP：使用PHP将excel转换为pdf

如图所示，即使是开源也可以像VBA一样从外部连接到Excel，并且应该始终以相应的语义释放初始化的对象。

---

考虑重构Excel VBA代码以获得最佳实践：

• 显式声明变量和类型
• 集成适当的错误处理(没有错误处理可以让资源运行(
• 使用With...End With块，避免Activate、Select、ActiveWorkbook和ActiveSheet(可能导致运行时错误(
• 声明并使用Cell、Range或Workbook对象，最后取消初始化所有Set对象
• 在需要的地方使用ThisWorkbook.限定符(即代码所在的工作簿(

注意：以下内容未经测试。所以要仔细测试、调试，尤其是因为使用了所有的名称。

Option Explicit       ' BEST PRACTICE TO INCLUDE AS TOP LINE AND 
' AND ALWAYS DebugCompile AFTER CODE CHANGES
Public Sub MainProcedure()
On Error GoTo ErrHandle
' EXPLICITLY DECLARE EVERY VARIABLE AND TYPE
Dim FormattedDate As Date, RunDate As Date
Dim ReportPath As String, MonthlyPath As String, CurPath As String
Dim ProjectName As String, ExcelFileName As String, FinalExcelFileName As String
Dim TableName As String, TemplateFileName As String
Dim SheetToSelect As String, ExcelSheetName As String
Dim CurSheetName As String

Dim i As Integer, CurRowNum As Long, LastRow As Long
Dim FirstRowOfSection As Long, LastRowOfSection As Long
Dim CurCell As Variant, curRange As Range

Dim wb As Workbook

Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
Application.EnableEvents = False
CurPath = ThisWorkbook.Path & ""                     ' USE ThisWorkbook
With ThisWorkbook.Worksheets("QReportDates")          ' USE WITH CONTEXT
FormattedDate = .Range("A2").Value
RunDate = .Range("B2").Value
ReportPath = .Range("C2").Value
MonthlyPath = .Range("D2").Value
ProjectName = .Range("E2").Value
End With

CurRowNum = 2
With ThisWorkbook.Worksheets("QFilesToExportEMail")   ' USE WITH CONTEXT
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

Set curRange = .Range("B" & CurRowNum & ":B" & LastRow)
For Each CurCell In curRange
If CurCell <> "" Then
FirstRowOfSection = .Columns(2).Find(ExcelFileName).Row

If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If

If CurRowNum = FirstRowOfSection Then
SheetToSelect = ExcelSheetName
End If

' USE WORKBOOK OBJECT
If IsNull(TemplateFileName) Or TemplateFileName = "" Then
Set wb = Workbooks.Add
Else
Set wb = Workbooks.Open(CurPath & TemplateFileName)
End If

wb.SaveAs MonthlyPath & FinalExcelFileName
End If

' USE WORKBOOK OBJECT
wb.Worksheets(SheetToSelect).Select
wb.Save
wb.Close
Set wb = Nothing                              ' RELEASE RESOURCE

If LastRowOfSection >= LastRow Then
Exit For
End If
Next CurCell
Set curRange = .Range("A2:A" & LastRow)
For Each CurCell In curRange
If CurCell <> "" Then
CurSheetName = CurCell

If CheckSheet(CurSheetName) Then         ' ASSUMED A SEPARATE FUNCTION
ThisWorkbook.Worksheets(CurSheetName).Delete
End If

End If
Next CurCell
End With

' USE ThisWorkbook QUALIFIER
ThisWorkbook.Worksheets("QFilesToExportEMail").Delete
ThisWorkbook.Worksheets("QReportDates").Delete
ThisWorkbook.Save
' ThisWorkbook.Close                                 ' AVOID CLOSING IN MACRO
ExitHandle:
' ALWAYS RELEASE RESOURCE (ERROR OR NOT)
Set curCell = Nothing: Set curRange = Nothing: Set wb = Nothing
Exit Sub

ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Resume ExitHandle
End Sub