Outlook VBA Check if File is Open/Not Open

[Felix_Dragonhammer]

So I have a bit of code to check whether or not a file is open or not and act accordingly:

Sub Check()
    
    Dim Ret
    Ret = IsWorkBookOpen("C:\Users\sberger\Desktop\GPAU\Target.xlsx")
    If Ret = False Then
    
        Dim xlApp As Object
        Dim sourceWB As Object
    
        Set xlApp = CreateObject("Excel.Application")
        With xlApp
            .Visible = True
            .EnableEvents = False
        End With
    
           Set sourceWB = xlApp.Workbooks.Open("C:\Users\sberger\Desktop\GPAU\Target.xlsm", , False, , , , , , , True)
           sourceWB.Activate
           
    Else
    
        Exit Sub
    
    End If
     
    xlApp.Run ("Test")
    
End Sub

------------------------------------------------------------------------------------------------------------

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long
    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    
    Select Case ErrNo
    Case 70:   IsWorkBookOpen = True
    Case Else: IsWorkBookOpen = False
    
    End Select
End Function

Much to my chagrin, I have discovered it is not. The workbook I have it checking is opened, but the code I have insists on opening a new one each time I run it. I can only assume I goofed up the function somehow when I adapted it.

Any help resolving this would be sincerely appreciated! Also, if anyone could provide code to activate the "Target" workbook in the event it is already open, I would appreciate that as well.

 

[RickXL]

Hi,

This is what I use. It is written as a separate function but the code could be extracted and included in the main macro if you prefer.

Sub wbTest()

    Dim wb As Workbook
    Dim strFilePath As String
    Dim strFile As String
    
    ' Get the My Documents Folder and add "@Excel"
    strFilePath = CreateObject("Wscript.Shell").SpecialFolders("MyDocuments") & "\@Excel\"
    
    ' Set the file name
    strFile = "A.xlsx"
    
    ' Set the workbook id - without re-opening the workbook
    Set wb = wbOpen(strFilePath & strFile)
    
    ' Do something with workbook
    Debug.Print wb.Sheets.Count
    
End Sub

Function wbOpen(strWB As String) As Workbook
    For Each wbOpen In Workbooks
        If wbOpen.FullName = strWB Then Exit Function
    Next
    If wbOpen Is Nothing Then Set wbOpen = Workbooks.Open(strWB)
End Function

Basically, the list of open workbooks is searched and if the desired one is not found then it opens it. Otherwise it assigns it to a workbook object name.

 

[Felix_Dragonhammer]

Okay, so I've made the following adjustments as suggested. But now... nothing happens. I probably am forgetting something...

Here is my adaptation:

(Note: I have added a now relevant bit of code to show what Sub is running the action. I just want the one you have to test if something is open or not, and open it if it isn't.

Sub Save_and_Open_IR_Customer_Inventory(itm As Outlook.MailItem)
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim item As Object
    Dim Atmt As Attachment
    Dim File_Name As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("IR GPAU Files")
    
    For Each Atmt In SubFolder.Items(SubFolder.Items.Count).Attachments
'Check filename of each attachment and save if it has "xls" extension
            If Right(Atmt.FileName, 4) = "xlsx" Then
            'This path must exist! Change folder name as necessary.
    File_Name = "C:\Users\sberger\Desktop\GPAU\" & Atmt.FileName
    Atmt.SaveAsFile File_Name
            End If
    Next Atmt
        
    Call wbTest
    
    xlApp.Run ("Test")
    
    End Sub
    
Sub wbTest()
    Dim wb As Workbook
    Dim strFilePath As String
    Dim strFile As String
    
    ' Get the My Documents Folder and add "@Excel"
    strFilePath = CreateObject("Wscript.Shell").SpecialFolders("GPAU") & "\@Excel\"
    
    ' Set the file name
    strFile = "Target.xlsm"
    
    ' Set the workbook id - without re-opening the workbook
    Set wb = wbOpen(strFilePath & strFile)
    
End Sub
Function wbOpen(strWB As String) As Workbook
    For Each wbOpen In Workbooks
        If wbOpen.FullName = strWB Then Exit Function
    Next
    If wbOpen Is Nothing Then Set wbOpen = Workbooks.Open(strWB)
End Function

 

[RickXL]

Hi,

I think you will need to implement it like this:

Sub Save_and_Open_IR_Customer_Inventory() '(itm As Outlook.MailItem)
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim item As Object
    Dim Atmt As Attachment
    Dim File_Name As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Dim wbOpen As Excel.Workbook
    Dim xlApp As Excel.Application
    
    Set xlApp = CreateObject("Excel.Application")
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("IR GPAU Files")
    
    For Each Atmt In SubFolder.Items(SubFolder.Items.Count).Attachments
        'Check filename of each attachment and save if it has "xls" extension
        If Right(Atmt.FileName, 4) = "xlsx" Then
            'This path must exist! Change folder name as necessary.
            File_Name = "C:\Users\sberger\Desktop\GPAU\" & Atmt.FileName
            Atmt.SaveAsFile File_Name
            xlApp.Visible = True
            For Each wbOpen In Workbooks
                If wbOpen.FullName = File_Name Then Exit For
            Next
            If wbOpen Is Nothing Then Set wbOpen = xlApp.Workbooks.Open(File_Name)
        End If
    Next Atmt
        

    
    xlApp.Run ("Test")
    
End Sub

I am not sure what the xlApp.Run("Test") is.

 

[Felix_Dragonhammer]

I tried your code... still nothing. If it makes a difference, I'm using Excel 2010

 

[RickXL]

Hi,

Is this an Excel macro or an Outlook macro?

 

[Felix_Dragonhammer]

It's in Outlook. The "Test" macro is in Excel, though.

 

[Felix_Dragonhammer]

It's not even saving the file to the folder anymore...

 

[Felix_Dragonhammer]

Okay, for some reason my original code doesn't do anything either.

 

[Felix_Dragonhammer]

For whatever reason, the Outlook VBA ddin't like your code at all. When I removed it, my original started working again.