CODEWITHSUNDEEP
vbaoutlookruntime-error
user3165962
user3165962

Reputation: 29

Send email if old unread mail exist

I'm trying to send myself an email if there are any unread emails over 15 minutes old.

The code, when I manually run from within Outlook, sends the mail but I get a

Run time error '-2147221238' (8004010a)

I can't get it to run from a rule or stand alone with task schedule probably due to the above error.

Sub checkForUnreadMails()

    Dim objFolder, objNamespace
    'get running outlook application or open outlook
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
    End If

    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objMsg = Application.CreateItem(olMailItem)

    strFilter = "[received] <= '" & Format(DateAdd("n", -15, Now()), "ddddd h:nn AMPM") & "'"
    Debug.Print strFilter
    Set inboxItems = objNamespace.GetDefaultFolder(olFolderInbox).Items.Restrict(strFilter)
    strFilter = "[Unread] = True"
    Set unreadItems = inboxItems.Restrict(strFilter)

    For Each itm In unreadItems
        With objMsg
            .To = "[email protected]"
            .Subject = "outlookrule There are unread emails over 15 minutes old in Vision ATM mailbox"
            .Categories = "T"
            .BodyFormat = olFormatPlain ' send plain text message
            .Importance = olImportanceHigh
            .Sensitivity = olConfidential
            .Send
        End With
    Next
End Sub

Upvotes: 2

Views: 145

Answers (2)

R3uK
R3uK

Reputation: 14537

Just launch StartTimer once you opened Outlook,
and it'll run checkForUnreadMails every 15 minutes until you close Outlook!

Option Explicit

Public RunWhen As Double
Public Const cRunIntervalSeconds = 900 ' 15 minutes
Public Const cRunWhat = "checkForUnreadMails"  ' the name of the procedure to run

Sub StartTimer()
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=True
End Sub



Sub checkForUnreadMails()
    Dim objFolder, objNamespace
    Dim areUnread As Boolean
    areUnread = False

    '''get running outlook application or open outlook
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objMsg = Application.CreateItem(olMailItem)

    strFilter = "[received] <= '" & Format(DateAdd("n", -15, Now()), "ddddd h:nn AMPM") & "'"
    'Debug.Print strFilter
    Set inboxItems = objNamespace.GetDefaultFolder(olFolderInbox).Items.Restrict(strFilter)
    strFilter = "[Unread] = True"
    Set unreadItems = inboxItems.Restrict(strFilter)

    For Each itm In unreadItems
        If itm.Subject <> vbNullString Then
            areUnread = True
            Exit For
        Else
        End If
    Next itm

    If areUnread Then
        With objMsg
            .to = "[email protected]"
            .Subject = "outlookrule There are unread emails over 15 minutes old in Vision ATM mailbox"
            .Categories = "T"
            .BodyFormat = olFormatPlain
            '''send plain text message
            .Importance = olImportanceHigh
            .Sensitivity = olConfidential
            .Send
        End With 'objMsg
    End If

    StartTimer
End Sub

Use this to stop the timer, when you want to keep Outlook open and not run the sricpt every 15 minutes

Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=False
End Sub

Upvotes: 1

Dmitry Streblechenko
Dmitry Streblechenko

Reputation: 66225

The error code is MAPI_E_OBJECT_DELETED. Your code does no make much sense - you create objMsg once, but attempt to send it multiple time (which you can't) for each unread item.

Why are you sending an email multiple times for each unread email? You do not actually retrieve any information from that email. Either simply check if there are matching emails (unreadItems.Count > 0) and send an email once, or create a new message (Set objMsg = Application.CreateItem(olMailItem)) on each iteration of the loop and include some particular email details.

Sub checkForUnreadMails()

    Dim objFolder, objNamespace
    'get running outlook application or open outlook
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
    End If

Set objNamespace = objOutlook.GetNamespace("MAPI")

strFilter = "[received] <= '" & Format(DateAdd("n", -15, Now()), "ddddd h:nn AMPM") & "'"
Debug.Print strFilter
Set inboxItems = objNamespace.GetDefaultFolder(olFolderInbox).Items.Restrict(strFilter)
strFilter = "[Unread] = True"
Set unreadItems = inboxItems.Restrict(strFilter)
if unreadItems.Count > 0 Then 
  Set objMsg = Application.CreateItem(olMailItem)
  With objMsg
                .To = "[email protected]"
                .Subject = "outlookrule There are unread emails over 15 minutes old in Vision ATM mailbox"
                .Categories = "T"
                .BodyFormat = olFormatPlain ' send plain text message
                .Importance = olImportanceHigh
                .Sensitivity = olConfidential
                .Send
        End With
  End If
End Sub

Upvotes: 5

Related Questions