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!

 

[willow1985]

The "fn1" calculation must be AFTER your "With Activeworkbook" line.

Note that any references that start with a ".", like .FullName are only valid with in a "With" block.

I am sorry I am still very green with writing VBA. I tried moving the With ActiveWorkbook in multiple areas but still get errors

Now I get Invalid procedure call or argument...

Private Sub Workbook_Open()
    Application.Calculation = xlAutomatic
    Application.CalculateBeforeSave = True
    Dim firstFolder As String
    Dim fn1 As String
    Dim fn2 As String
    Const AllowCancel = True
   firstFolder = Range("F1")

   With ActiveWorkbook

   fn1 = Mid(.FullName, InStr(UCase(.FullName), UCase(firstFolder))) 'this line has the error according to the debugger
    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]

Somewhere along the way you dropped your "FullFileName" variable!
You still need this in there, and need to set it equal to something.
All the variables you formula calls need to be defined and set to something.

 

[willow1985]

I added it back in but still get the same error on the same line...

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 = True
FullFileName = Sheets("List").Range("F2").Value
   firstFolder = Range("F1")
   With ActiveWorkbook
   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

Batch Log.xlsm
	E	F
1	File Directory Main:	ADMINISTRATION
2		X:\ADMINISTRATION\QAEng\Carla's Documents\Test\Batch Log.xlsm
List

 

[Joe4]

I copied your code "as-is", and debugged it, and do not get any "Invalid procedure call or argument" errors.

 

[willow1985]

I copied your code "as-is", and debugged it, and do not get any "Invalid procedure call or argument" errors.

This is what I am getting:

 

[Joe4]

If you insert this line of code above the one returning errors, run the code and let me know what it returns:

MsgBox .FullName & vbCrLf & firstFolder

 

[willow1985]

If you insert this line of code above the one returning errors, run the code and let me know what it returns:

MsgBox .FullName & vbCrLf & firstFolder

Got it, I didnt specify the sheet called List!

 

[willow1985]

If you insert this line of code above the one returning errors, run the code and let me know what it returns:

MsgBox .FullName & vbCrLf & firstFolder

Ok it now works in the proper directory however in the wrong directory I get a runtime error instead of the message box I want

 

[willow1985]

If you insert this line of code above the one returning errors, run the code and let me know what it returns:

MsgBox .FullName & vbCrLf & firstFolder

I moved it to a wrong directory and get the same runtime error with the same highlighted line instead of message box:

"This is a copy of the original workbook and therefore cannot be used. Please open the correct workbook"
and closing the workbook

 

[willow1985]

If you insert this line of code above the one returning errors, run the code and let me know what it returns:

MsgBox .FullName & vbCrLf & firstFolder

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?

What do you think?

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 = True
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