Closing a workbook if it is not located in a specific directory

[willow1985]

Hello, I know that it is not possible to prevent someone from copying an excel workbook however I was wondering if it was possible to disable the copied workbook?
That if the sheet is opened from a different location than the original (I can specify the directory in a cell on a hidden sheet) it will close down with a message like "This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook" and close the file.

Is this possible? I have a spreadsheet at work that many users utilize but apparently at one point an individual copied the sheet and now we have overlapping records. It is a mess and I am trying to prevent reoccurance.
Thank you to anyone who can help!

 

[Joe4]

I put in an On Error Resume Next statement and that seems to work as I assume that I am only getting the runtime error because they don't match?

No, them not matching does not cause an error.

You need to be VERY CAREFUL when using "On Error Resume Next". That will ignore ALL errors, which means:
- you will not know when you have valid errors you need to address
- it makes debugging very hard

Take it off, and see exactly which line is causing the error, and use the method of using Message Boxes (Iike I have shown you a few times now) to verify your variable values, and see if you can see where things are going off the rails.

 

[willow1985]

I am still getting this 2nd option to cancel however even though I changed it to False...
How can I fix this? Thank you for all of your help!!

Private Sub Workbook_Open()
    Application.Calculation = xlAutomatic
    Application.CalculateBeforeSave = True
    Dim firstFolder As String
    Dim fn1 As String
    Dim fn2 As String
    Dim FullFileName As String
    Const AllowCancel = False 'changed this to False, want the book to close but still gives save option
FullFileName = Sheets("List").Range("F2").Value
   firstFolder = Sheets("List").Range("F1").Value
   With ActiveWorkbook
On Error Resume Next
   fn1 = Mid(.FullName, InStr(UCase(.FullName), UCase(firstFolder)))
    fn2 = Mid(FullFileName, InStr(UCase(FullFileName), UCase(firstFolder)))
        If fn1 <> fn2 Then
                    Dim choice As Long, bttns As Long
            If AllowCancel Then bttns = vbOKCancel Else bttns = vbOKOnly
            choice = MsgBox("This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook.", bttns)
            If choice = vbOK Then .Close

        End If
    End With
End Sub

 

[Joe4]

You still have not gotten rid of the "On Error Resume Next" line, like I mentioned (remember, I warned about the dangers of using this!).
It is virtually impossible to debug the code with that line in there, as it will ignore and bypass any error.
You need to remove it and try again to get a better handle of what is going on.

 

[GWteB]

Didn't take a close look at the code of all posts within this thread, but given your request...

Closing a workbook if it is not located in a specific directory

... is it workable for you if you make the workbook dependent on the presence of a (hidden) file?
Simple code can be written for this. Furthermore, the workbook remains portable for an administrator, as long as the hidden file is moved along with it.

This goes in the ThisWorkbook module:

Option Explicit

Private Const HIDDENFILE As String = "MyHiddenFileName.Secret"


Private Sub Workbook_Open()
    
    Application.Calculation = xlAutomatic
    Application.CalculateBeforeSave = True

    CheckOnPrecenceOf HIDDENFILE
End Sub


Private Sub CreateHiddenFile()

    Dim MySecretFile As String, Handle As Long

    MySecretFile = ThisWorkbook.Path & "\" & HIDDENFILE
    Handle = VBA.FreeFile
    Open MySecretFile For Binary As #Handle
    Close #Handle
    VBA.SetAttr MySecretFile, vbHidden
End Sub


Private Sub CheckOnPrecenceOf(ByVal argFileName As String)

    Const ALLOWCANCEL = False  'if TRUE the user may cancel and then this workbook will not be closed

    argFileName = ThisWorkbook.Path & "\" & argFileName
    If VBA.Len(VBA.Dir(argFileName, vbHidden)) = 0 Then

        Dim Bttns As VbMsgBoxResult
        If ALLOWCANCEL Then
            Bttns = vbOKCancel
        Else
            Bttns = vbOKOnly
        End If
        If vbOK = MsgBox("This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook.", Bttns) Then
            ThisWorkbook.Close SaveChanges:=False
        End If
    End If
End Sub

 

[willow1985]

You still have not gotten rid of the "On Error Resume Next" line, like I mentioned (remember, I warned about the dangers of using this!).
It is virtually impossible to debug the code with that line in there, as it will ignore and bypass any error.
You need to remove it and try again to get a better handle of what is going on.

The vba code only works with the "On Error Resume Next" because without it it kept giving me the below error instead of the message box when the file was moved to another directory and I require the message box when the directories don't match, not a Run-time error.

If you have any way around the "On Error Resume Next" I would very much appreciate it .

Above directory does not contain the word "Aerospace" so no match but instead of giving the msg box advising that the directory is not correct it gives the following Runtime error:

Code works:

Private Sub Workbook_Open()
    Application.Calculation = xlAutomatic
    Application.CalculateBeforeSave = True
    Dim firstFolder As String
    Dim fn1 As String
    Dim fn2 As String
    Dim FullFileName As String
    Const AllowCancel = False 'changed this to False, want the book to close but still gives save option
FullFileName = Sheets("List").Range("F2").Value
   firstFolder = Sheets("List").Range("F1").Value
   With ActiveWorkbook
On Error Resume Next
   fn1 = Mid(.FullName, InStr(UCase(.FullName), UCase(firstFolder)))
    fn2 = Mid(FullFileName, InStr(UCase(FullFileName), UCase(firstFolder)))
        If fn1 <> fn2 Then
                    Dim choice As Long, bttns As Long
            If AllowCancel Then bttns = vbOKCancel Else bttns = vbOKOnly
            choice = MsgBox("This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook.", bttns)
            If choice = vbOK Then .Close

        End If
    End With
End Sub

 

[willow1985]

Didn't take a close look at the code of all posts within this thread, but given your request...


... is it workable for you if you make the workbook dependent on the presence of a (hidden) file?
Simple code can be written for this. Furthermore, the workbook remains portable for an administrator, as long as the hidden file is moved along with it.

This goes in the ThisWorkbook module:

Option Explicit

Private Const HIDDENFILE As String = "MyHiddenFileName.Secret"


Private Sub Workbook_Open()
  
    Application.Calculation = xlAutomatic
    Application.CalculateBeforeSave = True

    CheckOnPrecenceOf HIDDENFILE
End Sub


Private Sub CreateHiddenFile()

    Dim MySecretFile As String, Handle As Long

    MySecretFile = ThisWorkbook.Path & "\" & HIDDENFILE
    Handle = VBA.FreeFile
    Open MySecretFile For Binary As #Handle
    Close #Handle
    VBA.SetAttr MySecretFile, vbHidden
End Sub


Private Sub CheckOnPrecenceOf(ByVal argFileName As String)

    Const ALLOWCANCEL = False  'if TRUE the user may cancel and then this workbook will not be closed

    argFileName = ThisWorkbook.Path & "\" & argFileName
    If VBA.Len(VBA.Dir(argFileName, vbHidden)) = 0 Then

        Dim Bttns As VbMsgBoxResult
        If ALLOWCANCEL Then
            Bttns = vbOKCancel
        Else
            Bttns = vbOKOnly
        End If
        If vbOK = MsgBox("This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook.", Bttns) Then
            ThisWorkbook.Close SaveChanges:=False
        End If
    End If
End Sub

Sorry GWteB but a hidden file is not an option due to some of our restrictions on the network. Joe4's code is working but just need to fix the dependence on the "On Error Resume Next" Line (see above previous post). Any help is greatly appreciated!

 

[willow1985]

in the ThisWorkbook module:

Private Sub Workbook_Open()
    Const AllowCancel = True 'when true, allow the user to exit the messagebox by clicking Cancel and keep file open
    Const FullFileName = "replace this text between the quotes with full path and file name"
    With ActiveWorkbook
        If .FullName <> FullFileName Then
            Dim choice As Long, bttns As Long
            If AllowCancel Then bttns = vbOKCancel Else bttns = vbOKOnly
            choice = MsgBox("This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook.", bttns)
            If choice = vbOK Then .Close
        End If
    End With
End Sub

Replace the text in the Const FullFileName ... line with what the immediate window returns when you type

?ActiveWorkbook.FullName

I recommend leaving AllowCancel set to true so that you have an option to still access the file, for instance if you intentionally move it to another folder or rename it.

Hi JGordon11

Is there a way to change the AllowCancel to a password prompted Cancel, that if the wrong password is entered then the workbook closes?

I made the below code based on everyones help on this board, and it works however I would like to keep the Allow Cancel on that if someone moves the workbook I could fix the problem by entering a password to access the sheet instead of having to disable macros. I hope I am making sense...

I really appreciate the help with this

Private Sub Workbook_Open()

Application.Calculation = xlAutomatic

Application.CalculateBeforeSave = True

Dim firstFolder As String

Dim fn1 As String

Dim fn2 As String

Dim FullFileName As String

Const AllowCancel = False

FullFileName = Sheets("List").Range("F2").Value

firstFolder = Sheets("List").Range("F1").Value

With ActiveWorkbook



On Error Resume Next



fn1 = Mid(.FullName, InStr(UCase(.FullName), UCase(firstFolder)))

fn2 = Mid(FullFileName, InStr(UCase(FullFileName), UCase(firstFolder)))

If fn1 <> fn2 Then

Dim choice As Long, bttns As Long

If AllowCancel Then bttns = vbOKCancel Else bttns = vbOKOnly

choice = MsgBox("This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook.", bttns)

If choice = vbOK Then .Close False



End If

End With

End Sub

 

[JGordon11]

I would go another route. Whoever would have had the password get their Application.Username. Put those names between the pipes in the code below. And delete the Const AllowCancel line.

    Dim Admins As String
    Admins = "|Name1|Name2|Name3|"
    Dim AllowCancel As Boolean
    AllowCancel = InStr(1, Admins, "|" & Application.UserName & "|")

This will give the cancel option to the Admins. You can have any number of Admins including zero. Which is a similar result as creating a password that the admins know.

 

[willow1985]

I would go another route. Whoever would have had the password get their Application.Username. Put those names between the pipes in the code below. And delete the Const AllowCancel line.

    Dim Admins As String
    Admins = "|Name1|Name2|Name3|"
    Dim AllowCancel As Boolean
    AllowCancel = InStr(1, Admins, "|" & Application.UserName & "|")

This will give the cancel option to the Admins. You can have any number of Admins including zero. Which is a similar result as creating a password that the admins know.

Hi JGordon11, the problem with this is I won't always be logged in under my username and really all we are looking for is something that will hinder a user from making copies by accident and be forced to contact us if it occurs.

Would it be possible to do just a password and not the username?