With VBA in MS Excel I open emails from a file location on one of our servers.
After the script locates the file, it opens it in an instance of Outlook.
If I do not have an active instance of Outlook everything works.
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 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
Example code to replicate it
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 want 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 tried .close .quit ActiveInspector but none of these suit my needs.
I would try to get the program to wait until the .msg stops displaying but I am unsure if I have the knowledge to do so.
The reason for 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.
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