Modifying a VBA code that is meant to lock a sheet/adding in a password requirement

[willow1985]

I was assisted with the below code on this Forum but need further help with it.

The purpose of this code was to disable a excel spreadsheet (close the sheet) if the sheet was copied to another location. This did not have to be fool proof as the users are not well versed in Excel and it is more meant as a deterrent for people making their own copies.

That being said if a copy is made and the directory of the workbook does not contain the file name referenced in Sheets("List").Range("F1") the workbook closes.

What I would like is if it doesnt match, instead of closing the workbook lock it down with a password instead.

Is this possible?

Thank you to anyone who can help.

Batch Log.xlsm
	E	F
1	First file in Directory:	AEROSPACE
2		\\DAVIN\CADO\AEROSPACE\Batch Records\Batch Log.xlsm
List

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

 

[DanteAmor]

Check if this is what you need. The password is "willow"

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
        Application.DisplayAlerts = False
        .SaveAs Filename:=.FullName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="willow", CreateBackup:=False
        .Close False
      End If
    End If
  End With
End Sub

 

[willow1985]

Check if this is what you need. The password is "willow"

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
        Application.DisplayAlerts = False
        .SaveAs Filename:=.FullName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="willow", CreateBackup:=False
        .Close False
      End If
    End If
  End With
End Sub

This code works unfortunately when moved to another location it prompts for a password to re-open but then immediately closes again once the password is entered. I was hoping once the password is entered would give a chance to modify the workbook. This is close but the purpose of the password is if someone moves the original document then I could open it, enter the password and fix the document without having to disable macros.

Any ideas?

Thank you so much Dante!

 

[DanteAmor]

I tried the code, save the file with password willow. I open the workbook, enter the password willow, macros are enabled, and I can modify the data. I don't know what problem you may have, maybe the version.

 

[willow1985]

I tried the code, save the file with password willow. I open the workbook, enter the password willow, macros are enabled, and I can modify the data. I don't know what problem you may have, maybe the version.

If the workbook is in the wrong directory however and macros are enabled it wont let me modify the book because it automatically closes. Even in the wrong directory, when I enter the password I do not want it to close but have the option to change the directory in the workbook. I hope I am explaining this ok...