When I click "Send" it presents me with a list of folders to choose where to save it, rather than automatically filing it in Sent Items. It then asks me if I'm certain I want to send it (which has been remarkably helpful in not sending an email with something missing), and once I've run this gauntlet, it sends my email and files the message.
For the last two or three days, I've stopped being prompted and my mail is sent as if there's no macro to be triggered. This has occasionally happened and I've opened Outlook's macro editor, add a space, remove the space, and resave to reset it. This process hasn't worked this time.
I added message boxes to the code and none of them appeared. I don't get an error message. I triple-checked that macros are enabled and that there are no missing references. I seem to have the June release of Office 365 updates. Updates automatically install. Macros still run in Word.
AFAIK, I did nothing to cause the macro to stop. I want to say it's Microsoft's fault (who would blame me?) but I don't know how and can't rule myself out yet. I just don't know what went wrong.
Code: Select all
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, _
Cancel As Boolean)
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
Dim prompt As String
prompt = "Ready to Send? " & Item.Subject & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Ready?") = vbNo Then
Cancel = True
End If
If TypeName(objFolder) <> "Nothing" And _
IsInDefaultStore(objFolder) Then
Set Item.SaveSentMessageFolder = objFolder
End If
Set objFolder = Nothing
Set objNS = Nothing
End Sub
Public Function IsInDefaultStore(objOL As Object) As Boolean
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Select Case objOL.Class
Case olFolder
If objOL.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
End If
Case olAppointment, olContact, olDistributionList, _
olJournal, olMail, olNote, olPost, olTask
If objOL.Parent.StoreID = objInbox.StoreID Then
IsInDefaultStore = True
End If
Case Else
MsgBox "This function isn't designed to work " & _
"with " & TypeName(objOL) & _
" items and will return False.", _
, "IsInDefaultStore"
End Select
Set objApp = Nothing
Set objNS = Nothing
Set objInbox = Nothing
End Function
