Excel VBA打开Outlook .msg文件后内存残留问题求助

使用Excel VBA从服务器路径打开.msg文件，脚本定位文件后在Outlook实例中打开编辑。Outlook未运行时一切正常；但Outlook已启动时，关闭.msg文件后，Outlook仍会在内存中保留该文件锁，导致重复打开时报错。

复现步骤 #

• 创建带有ListBox（guiBody）和按钮（MoBtn）的用户窗体
• 将本地E盘路径下的.msg文件名（去除后缀）填充至guiBody
• 选中列表项并点击MoBtn，触发模块在Outlook中打开对应文件
• 关闭打开的.msg窗口后，再次尝试打开该文件，系统提示文件已被打开

复现代码 #

Private Sub CommandButton1_Click()
    Dim Msg As Object
    Dim update As Boolean: update = False
    For r = 0 To Me.ListBox1.ListCount - 1
        If (Me.ListBox1.Selected(r) = True) Then
            folderPath = "E:\" 'Your file path
            thisFile = Dir(folderPath & "\" & Me.ListBox1.List(r) & ".msg")
            On Error Resume Next
            Set Msg = GetObject("", "Outlook.Application").Session.OpenSharedItem(folderPath & "\" & thisFile)
            Msg.Display
            MsgBox("Wait")
            Msg.Close olSave
            Set Msg = Nothing
            If (Err <> 0) Then
                MsgBox("Throwing a fit")
            End If
            On Error GoTo 0
        End If
    Next
End Sub

Private Sub UserForm_Activate()
    folderPath = "E:\" 'Your file path
    thisFile = Dir(folderPath & "\*.msg")
    On Error Resume Next
    Do While thisFile <> ""
        Me.ListBox1.AddItem (Replace(thisFile, ".msg", ""))
        thisFile = Dir
    Loop
End Sub

Private Sub MD(guiList As MSForms.ListBox)
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("RecordedInfo")
    Dim Msg As Object
    Dim update As Boolean: update = False
    sheetLength = CalcSheetLength.CalculateSheetLength("RecordedInfo")
    For r = 0 To guiList.ListCount - 1
        If (guiList.Selected(r) = True) Then
            update = False
            folderPath = "E:\ReportingTeam\ReportProcedures\Draft Templates"
            thisFile = Dir(folderPath & "\" & guiList.List(r) & ".msg")
            On Error Resume Next
            Set Msg = GetObject("", "Outlook.Application").Session.OpenSharedItem(folderPath & "\" & thisFile)
            Msg.Display
            If (Err = 0) Then
                update = True
            End If
            On Error GoTo 0
            For InfoLen = 2 To sheetLength
                If (guiList.List(r) = ws.Range("A" & InfoLen) And update = True) Then
                    If (ws.Range("C" & InfoLen) = "") Then
                        ws.Range("C" & InfoLen) = Date
                        response = InputBox("Why did you modify the " & guiList.List(r) & " template?", "Comment")
                        If (ws.Range("D" & InfoLen) = "") Then
                            If (Trim(response) = "") Then
                                ws.Range("D" & InfoLen) = "No Response Given"
                            Else
                                ws.Range("D" & InfoLen) = Trim(response)
                            End If
                        Else
                            If (Trim(response) = "") Then
                                ws.Range("D" & InfoLen) = "No Response Given"
                            Else
                                ws.Range("G" & InfoLen) = ws.Range("D" & InfoLen) & ";" & ws.Range("G" & InfoLen)
                                ws.Range("D" & InfoLen) = Trim(response)
                            End If
                        End If
                    Else
                        ws.Range("F" & InfoLen) = ws.Range("C" & InfoLen) & ";" & ws.Range("F" & InfoLen)
                        ws.Range("C" & InfoLen) = Date
                        response = InputBox("Why did you modify the " & guiList.List(r) & " template?", "Comment")
                        If (ws.Range("D" & InfoLen) = "") Then
                            If (Trim(response) = "") Then
                                ws.Range("D" & InfoLen) = "No Response Given"
                            Else
                                ws.Range("D" & InfoLen) = Trim(response)
                            End If
                        Else
                            If (Trim(response) = "") Then
                                ws.Range("G" & InfoLen) = ws.Range("D" & InfoLen) & ";" & ws.Range("G" & InfoLen)
                                ws.Range("D" & InfoLen) = "No Response Given"
                            Else
                                ws.Range("G" & InfoLen) = ws.Range("D" & InfoLen) & ";" & ws.Range("G" & InfoLen)
                                ws.Range("D" & InfoLen) = Trim(response)
                            End If
                        End If
                    End If
                End If
            Next
            
            If update = False Then
                MsgBox ("The program encountered an error with modifying this draft." & vbCrLf & vbCrLf & "This issue is due to the file still being open on your system, the server not registering the file has closed or another user has the file open." & vbCrLf & vbCrLf & "If the error persists contact Kyle Willman.")
            End If
            On Error Resume Next
            Msg.Close olSave
            Set Msg = Nothing
            On Error GoTo 0
        End If
    Next
    Call Refresher.WindowRefresh(guiList)
End Sub

解决方案 #

核心问题 #

原代码中Msg.Display后立刻执行Msg.Close，未等待用户实际关闭窗口，且未正确关联Outlook Inspector对象，导致Outlook进程未释放文件锁。以下是针对性修复：

1. 等待用户关闭窗口后再释放对象 #

修改打开文件的逻辑，通过Inspector对象等待窗口关闭，确保用户操作完成后再保存关闭：

Private Sub OpenMsgAndWait(fullPath As String)
    Dim olApp As Object
    Dim msgItem As Object
    Dim olInspector As Object
    Dim olClosed As Integer: olClosed = 2 ' Outlook常量olClosed对应值为2
    
    ' 获取或创建Outlook实例
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    ' 打开.msg文件并获取Inspector
    Set msgItem = olApp.Session.OpenSharedItem(fullPath)
    Set olInspector = msgItem.Display
    
    ' 循环等待窗口关闭
    Do While olInspector.WindowState <> olClosed
        DoEvents ' 释放CPU资源，避免假死
    Loop
    
    ' 保存并释放所有对象
    msgItem.Close olSave
    Set olInspector = Nothing
    Set msgItem = Nothing
    ' 不要调用olApp.Quit，否则会关闭用户正在使用的Outlook
End Sub

在原代码中调用这个子过程替代直接打开的逻辑即可。

2. 打开前检查并关闭已存在的实例 #

如果需要确保文件未被其他Inspector打开，可在打开前遍历Outlook的Inspector列表，关闭对应文件的实例：

Private Sub CloseExistingMsgInstance(fullPath As String, olApp As Object)
    Dim existingInspector As Object
    Dim existingItem As Object
    Dim olMail As Integer: olMail = 43 ' Outlook常量olMail对应值为43
    
    For Each existingInspector In olApp.Inspectors
        Set existingItem = existingInspector.CurrentItem
        ' 检查是否为邮件类型，且文件路径匹配
        If existingItem.Class = olMail Then
            On Error Resume Next
            ' 通过MAPI属性获取文件路径，适配多数Outlook版本
            If existingItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E20001E") = fullPath Then
                existingItem.Close olSave
                Exit For
            End If
            On Error GoTo 0
        End If
        Set existingItem = Nothing
    Next
    Set existingInspector = Nothing
End Sub

在打开文件前调用这个方法，传入文件路径和Outlook实例即可。

3. 优化原代码的错误处理和对象释放 #

确保On Error语句正确使用，避免掩盖错误；同时在所有对象操作完成后，显式释放所有对象引用，避免内存泄漏。

内容的提问来源于stack exchange，提问作者KyWillm