0

I am working with VBA in MS Excel trying to get emails to open from a file location on one of our servers. I am successful in doing so, but I am experiencing an odd error with outlook. After the script has located the correct file I was looking for, it opens it in an instance of Outlook. If I do not have an active instance of Outlook open everything works fine and no noticeable errors occur, though if Outlook is open and I open the .msg file and say I accidentally open it again or a part of the program proceeds into more code, Outlook will forever think the file is open even if it is closed, Outlook will keep this file open in it's memory until the application is killed.

To replicate this issue

  1. made a userform with a ListBox and Button called "guiBody" and "MoBtn"
  2. populated guiBody with the file names from a location on my computer which was under "E:"
  3. once someone selects an item from guiBody and presses MoBtn it activates a module which then opens that corresponding file in outlook for editing.
  4. If the user then retries to open that file the system will throw an error for the file already being opened.

this is an example snip for someone to try and replicate it quick

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

I wanted Outlook to open the file but not retain it in it's memory. Or have the ability to kill off the active instances of the opened files.

I have already tried .close .quit ActiveInspector but none of these suit my needs.

The next solution I was going to try is attempting to get the program to wait until the .msg stops displaying but I am unsure if I have the knowledge to do so.

Additionally, the specific reason I was doing this in excel is for the background capability to store information that we might need like dates, and comments based on when someone accesses these .msg files or alters them.

KyWillm
  • 13
  • 3
  • "If I do not have an active instance of Outlook open everything works fine" - how so? You only ever call `GetObject("", "Outlook.Application")` - doesn't that require an already-open instance of Outlook? – Tim Williams Apr 20 '23 at 15:36
  • @TimWilliams GetObject("", "Outlook.Application") opens a .msg file in a stored location that was combined on the variables "folderPath" and "thisFile" the original program is a userform list which thisFIle is a name of a file that the user selects to edit. An already opened instance isn't required as the process of opening a .msg file opens an Outlook instance. But if it's already open it will go under the already opened sessions memory, but it will never kill it, it seems. Oddly enough if more than one file is selected it works fine with this code and clears it from the memory correctly. – KyWillm Apr 20 '23 at 16:02
  • 1
    `GetObject("", "Outlook.Application")` doesn't seem to open a msg file, but it does seem to open Outlook OK - guess I was thinking of `GetObject("Outlook.Application")` which causes a run-time error if Outlook is not open. Maybe you could update your post with a set of steps to reproduce the problem (along with a minimal amount of code, since most of what you've included doesn't seem to be part of the real problem) – Tim Williams Apr 20 '23 at 16:24
  • FYI you don't ever seem to call `Msg.Close` in your code? – Tim Williams Apr 20 '23 at 16:32
  • @TimWilliams My bad on that one I must have misunderstood what it was when I was constructing it. I added the new code snippets that go through the whole process of the script to get up to that point hopefully it helps to clarify it, I also added a little bit of code at the top which should work for new items. I added the Msg.Close olSave to the program afterwards because it wouldn't actually work with how the script was originally made I got rid of the two step process of declaring the GetObject("", "Outlook.Application") and condensed it to one. and then it worked. – KyWillm Apr 20 '23 at 17:10
  • This issue I think is from that original code snippet though. I think the Msg is not clearing correctly from excel or Outlook. If you do two selections of a .msg file it will open both no problem in quick succession but if only one instance is made I think the "Msg" object does not clear the original selection for some reason. – KyWillm Apr 20 '23 at 17:12
  • I'd suggest separating creating an Outlook object from the message object. That will give you greater clarity and control of your objects. Ie `Set oOutlook = CreateObject(...)` followed by `Set Msg = oOutlook.Seszion. ...` Then you can decide when to Quit the Outlook instance. Also, have a look in Task Manager. You may have more Outlook instances than you expect. – chris neilsen Apr 20 '23 at 18:03
  • Unrelated, but you might be interested in [this](https://stackoverflow.com/a/56874163/445425) – chris neilsen Apr 20 '23 at 18:08
  • @chrisneilsen I originally had an object called objOL that was Set objOL = GetObject("", "Outlook.Application") that then instantiated the Msg object but I had taken it out because it was actually constraining my ability to close the open sessions of .msg files. By the way thank you for sharing that, I am quite new to VBA originally I was using Java, I used Call because I was following what others had posted and I guess it was old, I'll update my script to reflect this. Oh an before I forget the outlook instances in Task Manager do close completely, it must be the Msg Object not clearing. – KyWillm Apr 20 '23 at 18:38
  • Re _because it was actually constraining my ability to close the open sessions of .msg files._ well, you're still facing that issue. Separating the objects can only help. BTW there's too much code here for me to want to replicate your issue. You really should create a [mre] that just demonstrates the problem. – chris neilsen Apr 21 '23 at 01:43
  • @chrisneilsen That's true, I'll see what I can do on that front. I removed a lot of the code. and the top block of code you should be able to drag and drop into a userform with a listbox and button no problem you would just have to point to a file path in your directory where you have .msg items stored from Outlook. – KyWillm Apr 21 '23 at 12:15

1 Answers1

0

I got the program to work correctly, for some reason Outlook does not like to instantiate a previously opened "Archived" MailItem, I put Archived in quotes because it's just a file I stored on a server, but I guess Outlook treats it as such.

Because of that reason I had to do a work around which added a new MailItem and then when someone saved said item it would apply that as a new template on the "Archived" item. I tried multiple solutions and seeing if I could use properties of MailItems without saving the new template but no such properties or events that I could use existed. I probably could have done this a bit nicer but honestly, it's taken up too much time and I couldn't have been bothered.

Below is the new code which works in my current version of VBA on MS Excel Enterprise Version 2301 (Build 16026.20238), if anyone finds this post later and has the same question. I'll also post a shortened version of it so it's a bit more understandable without all my crap in it.

Private Sub MD(guiList As MSForms.ListBox)
    Dim ol As Object: Set ol = CreateObject("Outlook.Application")
    For r = 0 To guiList.ListCount - 1
        If (guiList.Selected(r) = True) Then
            folderPath = "E:\ReportingTeam\ReportProcedures\Draft Templates" & "\" & guiList.List(r) & ".msg"
            On Error Resume Next
            Dim Msg As Object: Set Msg = ol.CreateItem(olMailItem)
            Dim targetMessage As Object: Set targetMessage = ol.Session.OpenSharedItem(folderPath)
            
            'Instantiate Outlook Message for editing
            Msg.Subject = targetMessage.Subject
            Msg.CC = targetMessage.CC
            Msg.To = targetMessage.To
            Msg.HTMLBody = targetMessage.HTMLBody
            Msg.Importance = targetMessage.Importance
            
            'Display the copied data from the template
            Msg.Display
            
            'Count the number of active Inspector items
            Dim iCount As Integer: iCount = ol.Inspectors.count
            
            'When the user closes the template they were modifying the if will execute and-
            'depending on if they saved it or not will apply the new template over the previous one.
            Do
                If (ol.Inspectors.count = iCount) Then
                Else
                    If Msg.Saved Then
                        targetMessage.Subject = Msg.Subject
                        targetMessage.To = Msg.To
                        targetMessage.CC = Msg.CC
                        targetMessage.HTMLBody = Msg.HTMLBody
                        targetMessage.Importance = Msg.Importance
                        targetMessage.Save
                        Msg.Delete
                        Set Msg = Nothing
                        Set targetMessage = Nothing
                    Else
                        Msg.Delete
                        targetMessage.Close olDiscard
                        Set Msg = Nothing
                        Set targetMessage = Nothing
                        MsgBox ("No Updates were made to this template")
                    End If
                End If
            Loop Until Msg Is Nothing
            On Error GoTo 0
        End If
    Next
End Sub

My corrected code snippet:

Private Sub MD(guiList As MSForms.ListBox)
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("RecordedInfo")
    Dim ol As Object: Set ol = CreateObject("Outlook.Application")
    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" & "\" & guiList.List(r) & ".msg"
            On Error Resume Next
            Dim Msg As Object: Set Msg = ol.CreateItem(olMailItem)
            Dim targetMessage As Object: Set targetMessage = ol.Session.OpenSharedItem(folderPath)
            
            'Instantiate Outlook Message for editing
            Msg.Subject = targetMessage.Subject
            Msg.CC = targetMessage.CC
            Msg.To = targetMessage.To
            Msg.HTMLBody = targetMessage.HTMLBody
            Msg.Importance = targetMessage.Importance
            
            'Display the copied data from the template
            Msg.Display
            
            'Count the number of active Inspector items
            Dim iCount As Integer: iCount = ol.Inspectors.count
            
            'When the user closes the template they were modifying the if will execute and-
            'depending on if they saved it or not will apply the new template over the previous one.
            Do
                If (ol.Inspectors.count = iCount) Then
                Else
                    If Msg.Saved Then
                        targetMessage.Subject = Msg.Subject
                        targetMessage.To = Msg.To
                        targetMessage.CC = Msg.CC
                        targetMessage.HTMLBody = Msg.HTMLBody
                        targetMessage.Importance = Msg.Importance
                        targetMessage.Save
                        Msg.Delete
                        Set Msg = Nothing
                        Set targetMessage = Nothing
                        update = True
                    Else
                        Msg.Delete
                        targetMessage.Close olDiscard
                        Set Msg = Nothing
                        Set targetMessage = Nothing
                        update = False
                        MsgBox ("No Updates were made to this template")
                    End If
                End If
            Loop Until Msg Is Nothing
            On Error GoTo 0
            
            'Jibberish for my program. "Documentation"
            For InfoLen = 2 To sheetLength
                If (guiList.List(r) = ws.Range("A" & InfoLen) And Err = 0 And update = True) Then
                    response = InputBox("Why did you modify the " & guiList.List(r) & " template?", "Comment")
                    If (ws.Range("C" & InfoLen) = "") Then
                        ws.Range("C" & InfoLen) = Date
                        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
                        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 there was an error notify the user
            If Err <> 0 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
            
        End If
    Next
    Refresher.WindowRefresh guiList
End Sub
KyWillm
  • 13
  • 3