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

UMAKEMESIK

UMAKEMESIK

Active Member
Joined
Oct 3, 2005
Messages
378
Hello

I use this code to open workbook 2 from workbook1

Code: 
    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.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Please try this code

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
 
Upvote 0
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;

Code: 
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

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


thankyou
 
Upvote 0
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
 
Upvote 0
Jeffrey Mahoney said:
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
Click to expand...

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.
 
Upvote 0
UMAKEMESIK said:
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.
Click to expand...


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


the error is:

sub or function not defined.


Code: 
  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)
 
Upvote 0
The last code I posted has the IsFileOpen Function. Copy that into your module and it should work fine.
 
Upvote 0
Jeffrey Mahoney said:
The last code I posted has the IsFileOpen Function. Copy that into your module and it should work fine.
Click to expand...

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 .

Rich (BB code): 
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
 
Upvote 0
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:
Code: 
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
 
Upvote 0
Jeffrey Mahoney said:
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:
Code: 
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
Click to expand...


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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Automating textbox updates in PP using VBA to read excel data
Replies
0
Views
429
noobslayer252
N
M
  • Question
Macro added to QAT running/opening original workbook
Replies
3
Views
384
Wookiee
Wookiee
R
  • Question
The VBA that I am using to password protect an excel file asks to save a copy of the file while running, when I want it to pass protect the same file
Replies
1
Views
536
Jeffrey Mahoney
Jeffrey Mahoney
willow1985
  • Solved
VBA activate workbook, msg box if cell contains certain text, close workbook
Replies
5
Views
328
willow1985
willow1985
G
  • Solved
Msg box in a destination xlsm if no results are found in source xlsx
Replies
3
Views
366
HaHoBe
HaHoBe

Forum statistics

Threads
1,214,590
Messages
6,120,421
Members
448,961
Latest member
nzskater

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top