Outlook 2013>VBA>Wait if excel file is open

[aworthey]

Hello,

I'm trying to insert a few lines of code at the beginning of my Outlook macro that would check to see if the Excel file is in use and pause until it's available. I've made an attempt, but it seems to loop indefinitely even after I close the file.

Here's the code:

Set wbTEST = Excel.Workbooks.Open(FileName:="\\Uswifs06\8181\Sales Ops\Source\Dev\QuoteView\KPS Sales Quote Index.xlsm")
    
    If wbTEST.ReadOnly Then
    
    Do Until Not wbTEST.ReadOnly
    
        Do Until Now > Now + TimeValue("0:00:05")
        Loop
    Loop
    
    End If

[skatonni]

You will want something like this

Do Until Now > start + TimeValue("0:00:05")

For example:

Option Explicit

Private Sub pause_test()

Dim wbRO As Boolean
Dim start As Date

wbRO = True
start = Now

If wbRO Then
    
    Do Until Not wbRO
    
        MsgBox "start: " & start
        
        Do Until Now > start + TimeValue("0:00:05")
            MsgBox "Between start and now is " & dateDiff("s", start, Now) & " seconds"
        Loop
        
        wbRO = False
    
    Loop
     
End If

End Sub

[aworthey]

skatonni,

Thanks for the suggestion! That completely makes sense. I've implemented it...however, it seems to execute the workbook paste whether the workbook is open or not.

Here's what I have:

start = Now
    Set wbTEST = Excel.Application.Workbooks.Open("\\Uswifs06\8181\Sales Ops\Source\Dev\QuoteView\KPS Sales Quote Index.xlsm")
    
    If wbTEST.ReadOnly Then
    
        Do Until Not wbTEST.ReadOnly
    
            Do Until Now > start + TimeValue("0:00:10")
            
            Loop
        Loop
    
    End If

[skatonni]

Your code does not show anything except that the delay time should now work.

Edit - This might help you figure out what could work.

Private Sub workbookRW()

Dim xlApp As Object
Dim wbTEST As Object
Dim wbRO As Boolean
Dim start As Date

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

Set wbTEST = xlApp.Workbooks.Open("h:\Test\Test.xlsx")

start = Now

If wbTEST.ReadOnly Then
     
    Do Until Not wbTEST.ReadOnly
    
        wbTEST.Close savechanges:=False
        
        Do Until Now > start + TimeValue("0:00:05")
             
        Loop
        
        Debug.Print "If not closed, close the original ReadWrite version now."
        
        Set wbTEST = xlApp.Workbooks.Open("h:\Test\Test.xlsx")
        start = Now
        
    Loop
     
End If

Debug.Print "Read write version should be ready now."

ExitRoutine:
    Set wbTEST = Nothing
    Set xlApp = Nothing

End Sub

[aworthey]

skatonni,

Your suggestions helped tremendously! Thanks

There is one final hurdle I'm trying to overcome...now that the loops are working properly, I'm encountering a Read-Write pop up box. I don't want this to happen, so I inserted an Application.DisplayAlerts = False statement just before opening the file. But I am still encountering the pop up.

Any ideas?

[skatonni]

For anyone to debug there has to be code.

Just the minimal amount to demonstrate the problem. See my examples.

[aworthey]

My apologies...

Option Explicit
Sub CopyToExcel(olItem As MailItem)
    
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim gaFolder As Folder
    Dim teFolder As Folder
    Dim sgFolder As Folder
    Dim lgFolder As Folder
    Dim tiFolder As Folder
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim ga As String, te As String, sg As String, lg As String, ti As String, ct As String, qp As String, sq As String, gm As String, am As String, jn As String, dd As String, cn As String, pn As String, cy As String, em As String, cid As String, qtp As String, qcat As String, catp As String
    Dim start As Date
    Dim Finish As Date
    Dim kItem As String
    Dim quoteID As Long
    Dim kNumber As String
    Dim wbTEST As Object
    Dim T0 As Long
    Dim objOwner As Outlook.Recipient
    Dim Rng As Range
    Dim NxtQuote As Long
    
    start = Now
    
    Excel.Application.DisplayAlerts = False
    Set xlWB = Excel.Application.Workbooks.Open("\\Uswifs06\8181\Sales Ops\Source\Dev\QuoteView\KPS Sales Quote Index.xlsm")
    If xlWB.ReadOnly Then
        Do Until Not xlWB.ReadOnly
            Do Until Now > start + TimeValue("0:00:10")
            Loop
        Loop
    End If

[aworthey]

skatonni,

your original code with the debug.print worked! thanks!!