Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Excel Worksheet Password Protect Problem

Status
Not open for further replies.

joecolombo

Vendor
Jan 19, 2005
33
US
I am not a programmer. Can anyone tell me why this code will not work. It is used in an Excel worksheet to password protect it from viewing.

Private Sub Worksheet_Activate()
'password protect your VBA project
Dim strPassword As String
On Error Resume Next
Const Password = "123" '**Change password here**


Me.Protect Password:=Password
Me.Columns.Hidden = True


strPassword = InputBox("Enter password to view this sheet", "Password
required !")


If strPassword = "" Then
Me.Previous.Select
Exit Sub
ElseIf strPassword <> Password Then
MsgBox "Password Incorrect", , "Wrong password"
Me.Previous.Select
Exit Sub
Else
Me.Unprotect Password:=Password
Me.Columns.Hidden = False
End If


On Error GoTo 0
End Sub


Private Sub Worksheet_Deactivate()
On Error Resume Next
Me.Columns.Hidden = True
On Error GoTo 0
End Sub

 
Put the following in ThisWorkbook

Code:
Private Sub Workbook_Activate()
   Const pass As String = "123"
   Dim response As String
   
   Call Hide_Sheets(True)
   
   response = InputBox("Enter password to view this sheet", "Password Required !")

   If response <> pass Then
      MsgBox ("Wrong password.")
      Call Save_Quit
   Else
      Call Hide_Sheets(False)
   End If
End Sub

Private Sub Workbook_Deactivate()
   Call Save_Quit
End Sub

Private Sub Hide_Sheets(flag As Boolean)
   Dim s As Integer
   
   For s = 1 To Sheets.Count
      If flag Then
         Sheets(s).Cells.EntireColumn.Hidden = True
      Else
         Sheets(s).Cells.EntireColumn.Hidden = False
      End If
   Next s
End Sub

Private Sub Save_Quit()
   Call Hide_Sheets(True)
   
   Application.DisplayAlerts = False
   Application.ActiveWorkbook.Save
   Application.Quit
End Sub
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top