Error when Outlook VBA macro runs too frequently

Question

Let me start with a brief description of what my project accomplishes currently. I have 3 subroutines in 'ThisOutlookSession'. One checks the last ~30 unread mail items and sends the subject to a sub that checks it's contents for a key word, the other does the same thing but handling the Items_ItemAdd event (new incoming mail) and the last sub I alluded to already checks the subject line and if a keyword is found calls a module I named 'ExcelConnection' which is where the issue stems from.

In the 'ExcelConnection' module I have this code that opens a workbook:

Dim oXL As Object
Dim oWS As Object
Dim lngRow As Long

Set oXL = CreateObject("Excel.Application")
oXL.Workbooks.Open FileName:="T:\Capstone Proj\TimeStampsOnly.xlsx", AddTOMRU:=False, UpdateLinks:=False

'// Change sheet name to suit
Set oWS = oXL.Sheets("TimeStamps")

The issue is: This process takes about a minute or so to complete and then it goes through an ExitSave point where the workbook is saved, closed, and the application 'quits', BUT if another piece of mail comes in before it finished running and "ExitSaving" it gives an error saying I cant open the workbook since it's already open. This also stops the initial instance and the result is the workbook stays open in the background where I can't close it manually and I cant edit it either since it keeps saying it's being modified by 'Another User' (Outlook).

Is there any way to tell the macro to wait until the everything is done running before it runs again? This only happens when two pieces of mail with keywords come in within a minute or so of each other.

If you have any questions or need more code samples please let me know! Thank you.

Edit: This is the code for the 'ExcelConnection' module that is triggered by a keyword in subject line of email.

    Public Sub ExcelConnect(msg As Outlook.MailItem, LType As String)
'// Declare all variables needed for excel functionality and open appropriate document
    Dim oXL As Object
    Dim oWS As Object
    Dim lngRow As Long

Set oXL = CreateObject("Excel.Application")
oXL.Workbooks.Open FileName:="T:\Capstone Proj\TimeStampsOnly.xlsx", AddTOMRU:=False, UpdateLinks:=False

'// Change sheet name to suit
Set oWS = oXL.Sheets("TimeStamps")
lngRow = oWS.Range("A" & oXL.Rows.Count).End(-4162).Offset(1).Row '// -4162 = xlUp. not available late bound

Dim subArray() As String
Dim jRow As Long
Dim jobnum As Variant


subArray = Split(msg.Subject, "-", 2)   '// Need the hypen to end the standardized subject line
jobnum = Trim(Right(subArray(0), 8))
jRow = IsExist(jobnum, lngRow, oWS)


Select Case LType '// Choose actions based on proccess step

    Case "MDIQE"
    If oWS.cells(jRow, 3).Value <> 0 Then
    GoTo ExitSave
    Else
        With oWS
            .cells(jRow, 1).Value = jobnum
            .cells(jRow, 2).Value = msg.ReceivedTime
            .cells(jRow, 3).Value = msg.ReceivedTime
        End With
    End If
'-------------------------------------------------------------
        Case "MDIQ"
        If oWS.cells(jRow, 2).Value <> 0 Then
        GoTo ExitSave
        Else
            With oWS
                .cells(jRow, 1).Value = jobnum
                .cells(jRow, 2).Value = msg.ReceivedTime
            End With
        End If
'-------------------------------------------------------------
        Case "MDIE"
        If oWS.cells(jRow, 3).Value <> 0 Then
        GoTo ExitSave
        Else
            With oWS
                .cells(jRow, 1).Value = jobnum
                .cells(jRow, 3).Value = msg.ReceivedTime
            End With
        End If
'-------------------------------------------------------------
        Case "MDIR"
        If oWS.cells(jRow, 4).Value <> 0 Then
        GoTo ExitSave
        Else
            With oWS
                .cells(jRow, 1).Value = jobnum
                .cells(jRow, 4).Value = msg.ReceivedTime
            End With
        End If
'-------------------------------------------------------------
        Case "MDIP"
        If oWS.cells(jRow, 5).Value <> 0 Then
        GoTo ExitSave
        Else
            With oWS
                .cells(jRow, 1).Value = jobnum
                .cells(jRow, 5).Value = msg.ReceivedTime
            End With
        End If
'-------------------------------------------------------------
        Case "MDIF"
        If oWS.cells(jRow, 6).Value <> 0 Then
        GoTo ExitSave
        Else
            With oWS
                .cells(jRow, 1).Value = jobnum
                .cells(jRow, 6).Value = msg.ReceivedTime
            End With
        End If

    End Select

ExitSave:
    With oXL
        .activeworkbook.Save
        .activeworkbook.Close SaveChanges:=1   '// 2 = xlDoNotSaveChanges but not availabe late bound
        .Application.Quit
    End With

    Set oXL = Nothing
    Set oWS = Nothing
End Sub
Function IsExist(jobnum As Variant, upper As Long, oWS As Object) As Long
    Dim i As Integer, ValueToFind As Variant
    ValueToFind = jobnum
    For i = (upper - 1) To 1 Step -1
        If CStr(oWS.cells(i, 1).Value) = ValueToFind Then
            IsExist = i
            Exit Function
        End If
    Next i
IsExist = upper 'If found nothing
End Function

Thanks for all the help everyone.

Can you not just set Outlook to not check for new mail so often, in Options? ...or, set it programmatically to not check the mail at all when the sub starts, and change back at the end of the sub? — ashleedawg
Possible duplicate of Outlook VBA - Run a code every half an hour — ashleedawg
@ashleedawg I like the idea of having it not check for new mail until the sub is done/ExitSave procedure is finished. I believe that is the metaphorical 'pause' I am looking for. Do you have a link or code sample that handles that by chance? — Wagner Braga
I may have a suggestion but I need to undertsand as to what do you do after opening the workbook. — Siddharth Rout
@SiddharthRout once the workbook is open I select a case based on which keyword was found in the subject and then insert a 'recievedtime' timestamp into an appropriate cell location. After the timestamp is entered I save, close, and quit excel. Issue is if more mail comes in before it saves and quits the workbook will be open still and the code will throw errors and leaves the workbook open. — Wagner Braga

Mistella Mistella · Accepted Answer · 2018-08-22T13:30:52

I'm not used manipulating Excel from Outlook, so this code will probably need some adjustment. The Sub Main will keep checking a specific workbook, until it's opened and not read-only. After doing code, it then closes the workbook and exits the loop. The only downside of this, is that the code will keep running until it has access to the workbook. You could add a counter to keep track of the number of attempts and exit once a specific number has been reached.

Functions ExtractName and WorkbookIsOpen are support functions included below Main.

Public Function Main(wbkLoc As String) As Boolean
    Dim wbk As Workbook

    Do While Not WorkbookIsOpen(ExtractName(wbkLoc)) Then
        Set wbk = Workbooks.Open(wbkLoc)

        'Will open read-only if shared file is already open on another computer
        If wbk.ReadOnly Then
            wbk.Close SaveChanges:=False
        Else
            'ExcelConnection code
            wbk.Close SaveChanges:=True
            Exit Do
        End If
        DoEvents
    Loop

    Set wbk = Nothing
End Function

'Allows use of location variable in Main without hardcoding workbook name
Private Function ExtractName(longName As String) As String
    Dim lastDash As Integer
    Dim extension As Integer

    extension = InStr(1, StrReverse(longName), ".")
    lastDash = InStr(1, StrReverse(longName), "\")
    ExtractName = StrReverse(Mid(StrReverse(longName), extension + 1, lastDash - extension - 1))
End Function

' Returns true if workbook is already open on same computer
Private Function WorkbookIsOpen(rsWbkName As String) As Boolean
    On Error Resume Next
    WorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function

Error when Outlook VBA macro runs too frequently

2 Answers