Outlook创建Excel后内存释放不完全

magako

代码功能如下：
Outlook中为某些邮件创建了一个文件夹，选中这个文件夹后运行vba，来导出文件夹里的邮件信息。到桌面上创建：邮件列表.xlsx，如果已经存在就删除原来的再创建一个同名的，填好表后关闭Excel清理对象内存，但是好像清不干净。



代码第一次运行没有问题，第二次运行报错424要求对象。发现第一次运行后任务管理器中还有Excel在运行，但是关闭这个没有用。需要设置 Excel 应用程序为可见，运行第二次报错时终止运行，关闭运行中打开的Excel应用，那么运行第三次就没有问题。



求教：Outlook创建excel对象后应如何正确释放内存呢？

1. Option Explicit
   
2. Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
   
3. Sub TestFolder()
   
4. Dim mobjOutlook As Outlook.NameSpace
   
5. Dim objOutlook As New Outlook.Application
   
6. Dim objFolder As Outlook.folder
   
7. Dim i As Integer
   
8. Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
   
9. Dim itemFolder As Outlook.folder
   
10. Dim obj As Object
    
11. Dim F As Outlook.MAPIFolder
    
12. Dim xlApp As Object
    
13. Dim wb As Object
    
14. Dim desktopPath As String
    
15. Dim xlSheet As Object
    
16. Dim wbk As Workbook
    
17. 
    
18. Set obj = Application.ActiveWindow
    
19.   If TypeOf obj Is Outlook.Inspector Then
    
20.     Set obj = obj.CurrentItem
    
21.   Else
    
22.    Set obj = obj.Selection(1)
    
23.   End If
    
24.   Set F = obj.Parent
    
25.      Debug.Print F.FolderPath
    
26.      Debug.Print F.Name
    
27.      
    
28. If F.Name = "收件箱" Or F.Name = "联系人" Then
    
29.     MsgBox "请选择文件夹！"
    
30.     Exit Sub
    
31.   Else
    
32.    
    
33.    ' 获取桌面路径
    
34.     desktopPath = Environ("USERPROFILE") & "\Desktop\邮件列表.xlsx"
    
35.    
    
36. Set mobjOutlook = objOutlook.GetNamespace("MAPI")
    
37. Set objFolder = mobjOutlook.GetDefaultFolder(olFolderInbox).folders(F.Name)
    
38. 
    
39. Dim objMail As Outlook.MailItem
    
40. 
    
41. On Error Resume Next      '如有错误则跳过
    
42. Kill desktopPath
    
43. DoEvents
    
44. 'Sleep 3000 ' 等待1000毫秒
    
45. 'Err.Clear
    
46. On Error GoTo 0
    
47. 
    
48. ' 创建 Excel 应用程序对象
    
49.     Set xlApp = CreateObject("Excel.Application")
    
50. ' 设置 Excel 应用程序为可见
    
51.     xlApp.Visible = True
    
52. ' 新建一个 Excel 工作簿
    
53.     Set wb = xlApp.Workbooks.Add
    
54.    
    
55.    
    
56.    '保存新建的工作簿到桌面
    
57.     wb.SaveAs FileName:=desktopPath
    
58. 
    
59. wb.Sheets(1).Cells(1, 1) = "邮箱"
    
60. wb.Sheets(1).Cells(1, 2) = "发件人"
    
61. wb.Sheets(1).Cells(1, 3) = "收件时间"
    
62. wb.Sheets(1).Cells(1, 4) = "主题"
    
63. wb.Sheets(1).Cells(1, 5) = "正文"
    
64. wb.Sheets(1).Cells(1, 6) = "附件"
    
65. wb.Sheets(1).Cells(1, 7) = "部门"
    
66. 
    
67. wb.Activate
    
68. wb.Sheets("Sheet1").Select
    
69. ' 选择工作表
    
70.     Set xlSheet = wb.Sheets("Sheet1")
    
71. 
    
72. ' 冻结首行
    
73.     xlApp.ActiveWindow.SplitRow = 1
    
74.     xlApp.ActiveWindow.SplitColumn = 0
    
75.     xlApp.ActiveWindow.FreezePanes = True
    
76. 
    
77. 
    
78. i = 1
    
79. For Each objMail In objFolder.Items
    
80. 
    
81.     xlSheet.Range("A" & i + 1) = objMail.SenderEmailAddress
    
82.     xlSheet.Range("B" & i + 1) = objMail.SenderName
    
83.     xlSheet.Range("C" & i + 1) = objMail.ReceivedTime
    
84.     xlSheet.Range("D" & i + 1) = objMail.Subject
    
85.     xlSheet.Range("E" & i + 1) = objMail.Body
    
86.     xlSheet.Range("F" & i + 1) = objMail.Attachments.Count
    
87. '    xlSheet.Range("G" & i + 1) = objMail.PidTagDepartmentName
    
88. 
    
89.     i = i + 1
    
90. Next
    
91. 
    
92. 
    
93.     xlSheet.Columns("A:D").EntireColumn.AutoFit
    
94.     wb.Save
    
95. 
    
96.     xlSheet.UsedRange.Select
    
97. 
    
98.     xlSheet.Range("A1:G" & [a65536].End(xlUp).Row).Select
    
99. '    xlSheet.Range("A1:G" & [a65536].End(xlUp).Row).WrapText = False
    
100. 
     
101. With Selection
     
102.     .WrapText = False
     
103.     .AutoFilter
     
104. End With
     
105. 
     
106.     xlSheet.Range("A1").Select
     
107. 
     
108.     wb.Save
     
109.     wb.Close
     
110.    
     
111.     For Each wbk In xlApp.Workbooks
     
112.         wbk.Close SaveChanges:=False
     
113.     Next wbk
     
114.    
     
115.     xlApp.Quit
     
116.      
     
117.      '清理
     
118.     Set xlSheet = Nothing
     
119.     Set wb = Nothing
     
120.     Set xlApp = Nothing
     
121. '    Sleep 3000 ' 等待1000毫秒
     
122. 
     
123.     Shell "excel.exe " & desktopPath, vbMaximizedFocus
     
124.    
     
125. End If
     
126. End Sub

复制代码

morpheus126

xlApp.Quit

magako

morpheus126 发表于 2024-8-27 10:36
xlApp.Quit

115行写了，用这个关，窗口是没了，但是任务管理器中还有。如果是手动关就没问题。