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.

Answer 1

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

Answer 2

In outlook the minimum automatic send and receive can be set to 1 minute as shown below.

Yes if your process takes 1 minute or so then you can increase this to 5 mins or to whatever you want but this may not keep you updated with latest emails. Mine is set to 1 Minute. You may call me paranoid 0_0!

So when you are paranoid like me then what is the alternative? If there was a way which ran your code not in 1 minute or so but in 1 second or so then your problem should be solved. Right? :)

Use OLEDB to write to the Excel file. This code finds the job number and writes to that row if the relevant cell is empty and then saves the files in less than 2 seconds

Const FName As String = "T:\Capstone Proj\TimeStampsOnly.xlsx"
Const SheetName As String = "TimeStamps"

Const adUseClient = 3
Const adOpenDynamic = 2
Const adLockOptimistic = 3
Const adCmdText = &H1

Const Col_A As String = "Put Column A header here"
Const Col_B As String = "Put Column B header here"
Const Col_C As String = "Put Column C header here"
Const Col_D As String = "Put Column D header here"
Const Col_E As String = "Put Column E header here"
Const Col_F As String = "Put Column F header here"

Public Sub ExcelConnect(msg As Outlook.MailItem, LType As String)
    Dim ReceivedTime As String, jobnum As String
    Dim conString As String

    Dim objRecordset As Object, objConnection As Object

    ReceivedTime = msg.ReceivedTime
    jobnum = Trim(Right(Split(msg.Subject, "-", 2)(0), 8))

    conString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                FName & _
                ";Extended Properties=""Excel 12.0;HDR=Yes"""

    Set objConnection = CreateObject("ADODB.Connection")
    Set objRecordset = CreateObject("ADODB.Recordset")

    objConnection.Open conString

    objRecordset.CursorLocation = adUseClient
    objRecordset.Open "Select * FROM [" & SheetName & "$] WHERE " & Col_A & " ='" & jobnum & "'", _
    objConnection, adOpenDynamic, adLockOptimistic, adCmdText

    If objRecordset.RecordCount > 0 Then
        With objRecordset
            Select Case LType
                Case "MDIQE"
                    If Len(Trim(.Fields.Item(Col_C).Value)) = 0 Then
                        .Fields.Item(Col_B).Value = ReceivedTime
                        .Fields.Item(Col_C).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIQ"
                    If Len(Trim(.Fields.Item(Col_B).Value)) = 0 Then
                        .Fields.Item(Col_B).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIE"
                    If Len(Trim(.Fields.Item(Col_C).Value)) = 0 Then
                        .Fields.Item(Col_C).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIR"
                    If Len(Trim(.Fields.Item(Col_D).Value)) = 0 Then
                        .Fields.Item(Col_D).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIP"
                    If Len(Trim(.Fields.Item(Col_E).Value)) = 0 Then
                        .Fields.Item(Col_E).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIF"
                    If Len(Trim(.Fields.Item(Col_F).Value)) = 0 Then
                        .Fields.Item(Col_G).Value = ReceivedTime
                        .Update
                    End If
            End Select
        End With
    End If

    objConnection.Close
End Sub

The above code is tried and tested with my excel file. If you face any problem then let me know and we will try and fix it.