Can I use VB to check if a workbook is open and if it is return with a msg box

[UMAKEMESIK]

Hello

I use this code to open workbook 2 from workbook1

    Dim LastRow As Range
    Dim ws As Worksheet
        Set ws = Sheets("Worksheet")
        
        
  
        
    Workbooks.Open Filename:="R:\General\COVER SHEET_Protective\Protective Packaging Order Log.xlsm", Password:="PP", WriteResPassword:="PP"

Can I insert some code to first check to see if the workbook protective packaging order log.xlsm is open already with a password or read only.

if the workbook is open with read only we would like to proceed with the code and moving data from wb1 to wb2

if the sheet is opened with a password.

can we get a msg box back that says the wb2 is in use
and the code will end.

any help would be appreciated.

 

[Jeffrey Mahoney]

Please try this code

Sub TestReadonly()
  Dim PFN As String
  Dim WB As Workbook
  Dim OpenStatus As Integer
  
  PFN = "C:\Users\Jeff\Documents\MREXCEL\Book2.xlsm"
  
  OpenStatus = IsFileOpen(PFN)
  
  If OpenStatus = -1 Then   'Open by you with (not read only)
    'Don't run the code
  ElseIf OpenStatus = 3 Then    'Open by you as read only
    Set WB = Workbooks.Open(PFN, ReadOnly:=False, Password:="new", WriteResPassword:="new")
    'Run the code
  ElseIf OpenStatus = 1 Then
    'Somebody else has it open
  ElseIf OpenStatus = 0 Then
    'The file is not open by anybody
  End If
  
End Sub

'Check to see if current user has file open
Function IsWBOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    IsWBOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function




'Checks to see if file is open by another user or by current user
Function IsFileOpen(PathFilename As String) As Integer
    Dim filenum As Integer, errnum As Integer


    On Error Resume Next    ' Turn error checking off.
    filenum = FreeFile()    ' Get a free file number.
    
                            ' Attempt to open the file and lock it.
    Open PathFilename For Input Lock Read As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=filenum]#filenum[/URL] 
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.


    ' Check to see which error occurred.
    Select Case errnum


        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
          If IsWBOpen(GetFileName(PathFilename)) = True Then
            'Open as read only
            IsFileOpen = 3
          Else
            IsFileOpen = 0
          End If


        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            If IsWBOpen(GetFileName(PathFilename)) = True Then
              IsFileOpen = -1                               'Open by this user
            Else
              IsFileOpen = 1                                'Open by another user
            End If


        ' Another error occurred.
        Case Else
            Error errnum
    End Select


End Function

 

[UMAKEMESIK]

Thankyou for taking the time.

By looking at it , it appears all will work.

my issue is that the code I use is
activated by a button on the page and it's one
lone stream that happens at once
with no sub breaks.

by putting In your code there is a sub and function break
so the rest of the code does not act.

and if I put your code in the middle I have to put in an end sub
so my code ends before I even get to yours.

is there a way to avoid the sub and function breaks

so once activated the code will go through all of the actions including yours

below is everything that happens when the button is pressed on the excel sheet.
the button activates this codea;

Private Sub CommandButton1_Click()



Application.ScreenUpdating = False


    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    
    
    
    Dim MyPath As String
Dim MyFile As String
Application.ScreenUpdating = True



'-----------------------------------------------------------------------------


If Len(Dir("R:\General\COVER SHEET_Protective\" & Range("B2") & "\", vbDirectory)) = 0 Then
  
    MkDir "R:\General\COVER SHEET_Protective\" & Range("B2")

End If

If Len(Dir("R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3") & "\", vbDirectory)) = 0 Then
    MkDir "R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3")

End If


If Dir("R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3"), vbDirectory) <> "" Then
    MyPath = "R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3") & "\"
Else
    MyPath = "R:\General\COVER SHEET_Protective\"
End If

MyFile = Range("G3") & " - Order.xlsm"
'MyFile = Range("F16") & " - " & Range("O16") & " - " & Range("AB3") & ".xls"

ActiveWorkbook.SaveCopyAs Filename:=MyPath & MyFile

Application.ScreenUpdating = True
Application.ScreenUpdating = False




'NEXT COMMAND ---------------------------------------------------------------------------------
        




    Dim LastRow As Range
    Dim ws As Worksheet
        Set ws = Sheets("Worksheet")
        
        
  
        
    Workbooks.Open Filename:="R:\General\COVER SHEET_Protective\Protective Packaging Order Log.xlsm", Password:="PP", WriteResPassword:="PP"
       
        
        Set LastRow = Sheets("ORDER LOG").Cells(Rows.Count, 1).End(xlUp)
            
            With LastRow
            
.Offset(1, 0) = ws.[G3]
                  ActiveSheet.Hyperlinks.Add Anchor:=.Offset(1), _
 Address:="R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3") & "\" & Range("G3") & " - Order.xlsm"
 

  
.Offset(1).Font.Size = 14
             
                .Offset(1, 1) = ws.[B2]
                .Offset(1, 2) = ws.[C3]
                .Offset(1, 3) = ws.[G7]
                .Offset(1, 4) = ws.[c7]
                .Offset(1, 5) = ws.[G5]
                .Offset(1, 6) = ws.[D10]
                .Offset(1, 7) = ws.[D11]
                .Offset(1, 8) = ws.[D12]
                
                
            
            End With
            


          
        
    
     ActiveWorkbook.Save



    Application.ScreenUpdating = True
 
     
     
Application.Quit


    
     
   
     

       Application.ScreenUpdating = False
       Application.DisplayAlerts = False
       Application.ScreenUpdating = True
  
       
    
    
     
End Sub

I would like to put your code before this line

Workbooks.Open Filename:="R:\General\COVER SHEET_Protective\Protective Packaging Order Log.xlsm", Password:="PP", WriteResPassword:="PP"

thankyou

 

[Jeffrey Mahoney]

So, I want to make sure we're clear. The TestReadOnly is an example of how to do the proper tests to check if a file is open in Read Only status or if the password has already been applied. You will need to take the code inside the SUB and use as much as you need inside the routines you've already created.

The functions that get called by the example SUB I provided are stand alone functions, they don't get inserted into any other SUB. As soon as a function is finished, it returns back to the calling SUB.

Jeff

 

[UMAKEMESIK]

So, I want to make sure we're clear. The TestReadOnly is an example of how to do the proper tests to check if a file is open in Read Only status or if the password has already been applied. You will need to take the code inside the SUB and use as much as you need inside the routines you've already created.

The functions that get called by the example SUB I provided are stand alone functions, they don't get inserted into any other SUB. As soon as a function is finished, it returns back to the calling SUB.

Jeff

Jeffrey,

I will keep fooling around with this in some test sheets but I do think the organization is beyond my paygrade.
I do appreciate the time taken to respond.

Have a nice one.

 

[UMAKEMESIK]

Jeffrey,

I will keep fooling around with this in some test sheets but I do think the organization is beyond my paygrade.
I do appreciate the time taken to respond.

Have a nice one.

on this code below
I get an error and
the word ( isfileopen )
is highlighted blue


the error is:

sub or function not defined.

  Dim PFN As String
  Dim WB As Workbook
  Dim OpenStatus As Integer
 
  
  
  PFN = "R:\General\COVER SHEET_Protective\Protective Packaging Order Log.xlsm"
  'Check to see if current user has file open



  
  OpenStatus = ISFILEOPEN(PFN)

 

[Jeffrey Mahoney]

The last code I posted has the IsFileOpen Function. Copy that into your module and it should work fine.

 

[UMAKEMESIK]

The last code I posted has the IsFileOpen Function. Copy that into your module and it should work fine.

thankyou.

I guess I'm not understanding how to insert parts of your code.

everytime I insert any part, the VBA requires a sub break. If I put in a Sub break, end Sub.


my entire code stream works with one click of a button. by introducing sub breaks, the code stops
and the actions below the sub break are not completed .

Private Sub CommandButton1_Click()




'=========================================================================================
Application.ScreenUpdating = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

Dim MyPath As String
Dim MyFile As String
Application.ScreenUpdating = True



'-----------------------------------------------------------------------------


If Len(Dir("R:\General\COVER SHEET_Protective\" & Range("B2") & "\", vbDirectory)) = 0 Then
  
    MkDir "R:\General\COVER SHEET_Protective\" & Range("B2")

End If

If Len(Dir("R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3") & "\", vbDirectory)) = 0 Then
    MkDir "R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3")

End If


If Dir("R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3"), vbDirectory) <> "" Then
    MyPath = "R:\General\COVER SHEET_Protective\" & Range("B2") & "\" & Range("C3") & "\"
Else
    MyPath = "R:\General\COVER SHEET_Protective\"
End If

MyFile = Range("G3") & " - Order.xlsm"


ActiveWorkbook.SaveCopyAs Filename:=MyPath & MyFile

Application.ScreenUpdating = True
Application.ScreenUpdating = False








    
        
  
    Dim LastRow As Range
    Dim ws As Worksheet
        Set ws = Sheets("Worksheet")
        
        
  
        
    Workbooks.Open Filename:="R:\General\COVER SHEET_Protective\Protective Packaging Order Log.xlsm", Password:="PP", WriteResPassword:="PP"
    
    
'Checks to see if file is open by another user or by current user
Function IsFileOpen(PathFilename As String) As Integer
    Dim filenum As Integer, errnum As Integer


    On Error Resume Next    ' Turn error checking off.
    filenum = FreeFile()    ' Get a free file number.
    
                            ' Attempt to open the file and lock it.
    Open PathFilename For Input Lock Read As #filenum 
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.


    ' Check to see which error occurred.
    Select Case errnum


        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
          If IsWBOpen(GetFileName(PathFilename)) = True Then
            'Open as read only
            IsFileOpen = 3
          Else
            IsFileOpen = 0
          End If


        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            If IsWBOpen(GetFileName(PathFilename)) = True Then
              IsFileOpen = -1                               'Open by this user
            Else
              IsFileOpen = 1                                'Open by another user
            End If


        ' Another error occurred.
        Case Else
            Error errnum
    End Select


End Function
       
        
        Set LastRow = Sheets("ORDER LOG").Cells(Rows.Count, 1).End(xlUp)
            
            With LastRow
            
.Offset(1, 0) = ws.[G3]
                  ActiveSheet.Hyperlinks.Add Anchor:=.Offset(1), _
 Address:="R:\General\COVER SHEET_Protective" & Range("B2") & "" & Range("C3") & "" & Range("G3") & " - Order.xlsm"
 

  
.Offset(1).Font.Size = 14
             
                .Offset(1, 1) = ws.[B2]
                .Offset(1, 2) = ws.[C3]
                .Offset(1, 3) = ws.[G7]
                .Offset(1, 4) = ws.[c7]
                .Offset(1, 5) = ws.[G5]
                .Offset(1, 6) = ws.[D10]
                .Offset(1, 7) = ws.[D11]
                .Offset(1, 8) = ws.[D12]
                
                
            
            End With
            


          
        
    
     ActiveWorkbook.Save



    Application.ScreenUpdating = True
 
     
     
Application.Quit


    
     
   
     

       Application.ScreenUpdating = False
       Application.DisplayAlerts = False
       Application.ScreenUpdating = True
  
       
    
    

End Sub

 

[Jeffrey Mahoney]

You can't paste a SUB or FUNCTION inside of another SUB or FUNCTION. They called get called.

Move the function code and put it after the END SUB.

Inside a SUB, the function is called (in this case) by:

Dim Var as integer
Var = IsFileOpen(PathFileName)

When the function is finished, it returns a value that can be used in the SUB. In this case, IsFileOpen returns one of the following:
-1 : Open by you
0 : Not open
1 : Open by someone else
3 : Open by you as read only

 

[UMAKEMESIK]

You can't paste a SUB or FUNCTION inside of another SUB or FUNCTION. They called get called.

Move the function code and put it after the END SUB.

Inside a SUB, the function is called (in this case) by:

Dim Var as integer
Var = IsFileOpen(PathFileName)

When the function is finished, it returns a value that can be used in the SUB. In this case, IsFileOpen returns one of the following:
-1 : Open by you
0 : Not open
1 : Open by someone else
3 : Open by you as read only

Thankyou for all of the time you have taken, I do appreciate it.

I am going to move on at this point, I really don't want to take any more of your time.
bottom like, I just cant figure it out , I have tried inserting segments and fooled with this for
hours, I just gotta get back to work. I may repost later.

Have a good one.