The code below is meant to allow only the authoriser (network name "JSMITH") to tick my checkbox so that she confirms she's happy with the report to be sent out (multiple report users but only one authoriser). But I keep getting an error "Object required". What am I doing wrong in the code below? thanks
Private Sub CheckBox1_Click()
If Environ("username") <> "JSMITH" Then
CheckBox1.Value = False
End If
End Sub
I think what you are after is the following code:
Sub CheckBox1_Click()
If ActiveSheet.Shapes("Check Box 1").ControlFormat.Value = 1 Then
If Environ("username") = "JSMITH" or Environ("username") = "DTailor" Then
'Do nothing
Else
'Uncheck because user not matching
ActiveSheet.Shapes("Check Box 1").ControlFormat.Value = 0
MsgBox ("You are not authorized to tick this box.")
End If
End If
End Sub
For an ActiveX checkbox I would use the following code:
Sub CheckBox1_Click()
If ActiveSheet.OLEObjects("CheckBox1").Object.Enabled = True Then
If Environ("username") = "JSMITH" or Environ("username") = "DTailor" Then
'Do nothing
Else
'Uncheck because user not matching
ActiveSheet.OLEObjects("CheckBox1").Object.Enabled = False
MsgBox ("You are not authorized to tick this box.")
End If
End If
End Sub
Related
I am trying to create an excel addin which has a button when clicked will display a VBA form. Its quite simple one list box and one command button.
Below is the code in Command button
Private Sub CommandButton1_Click()
ThisWorkbook.IsAddin = False
On Error GoTo ErrHandler:
KeyAcc = WorksheetFunction.VLookup(ComboBox1.Value, Sheet1.Range("A:B"), 2, False)
MsgBox KeyAcc
ThisWorkbook.IsAddin = True
Unload Me
Exit Sub
ErrHandler:
MsgBox ComboBox1.Value & " Not found in the Database"
ThisWorkbook.IsAddin = True
Unload Me
ActiveWorkbook.Save = False
End Sub
Code in form load
Private Sub UserForm_Activate()
Application.ScreenUpdating = False
Dim cCount As Integer
ThisWorkbook.IsAddin = False
ThisWorkbook.Sheets("Sheet1").Select
For cCount = 1 To 320
UserForm1.ComboBox1.AddItem Range("A" & cCount).Value
Next
ThisWorkbook.IsAddin = True
ComboBox1.SetFocus
End Sub
The problem i face is whenever the user activates this button on the first book ie, after opening a new excel and performs the operation it works, once done when i try to close the blank workbook it asks do you want to Save your changes to the Addin
Is there any way to avoid this?
You don't need all that work just to load your combobox:
Private Sub UserForm_Activate()
Me.ComboBox1.List = ThisWorkbook.Sheets("Sheet1").Range("A1:A320").Value
ComboBox1.SetFocus
End Sub
I've been trying to get the typical hide sheets/unhide sheets code to work for encouraging Macro enabling. Since I lock down saving, I needed to do it slightly differently than putting it in the Workbook_BeforeClose Sub as usually is done.
But...my hide sub
Sub HideSheets()
'Error Handling when workbook is unprotected.
On Error GoTo EH
'Unprotect the workbook to allow conditional formatting changes.
ThisWorkbook.Sheets("Field Service Report").Unprotect Password:="x"
ThisWorkbook.Sheets("Prompt").Unprotect Password:="x"
'Main Sub Code
Application.EnableCancelKey = xlDisabled
Sheets("Prompt").Visible = xlSheetVisible
Sheets("Field Service Report").Visible = xlSheetVeryHidden
Application.EnableCancelKey = xlInterrupt
'Reprotect worksheet before ending sub.
ThisWorkbook.Sheets("Field Service Report").Protect Password:="x", UserInterfaceOnly:=True
ThisWorkbook.Sheets("Prompt").Protect Password:="x"
Exit Sub
EH:
Call EH
Resume Next
End Sub
and my unhide sub
Sub UnhideSheets()
'Error Handling
On Error GoTo EH
'Unprotect the workbook to allow conditional formatting changes.
ThisWorkbook.Sheets("Field Service Report").Unprotect Password:="x"
ThisWorkbook.Sheets("Prompt").Unprotect Password:="x"
'Main Sub Code
Application.EnableCancelKey = xlDisabled
Sheets("Field Service Report").Visible = xlSheetVisible
Sheets("Prompt").Visible = xlSheetVeryHidden
Application.EnableCancelKey = xlInterrupt
'Reprotect worksheet before ending sub.
ThisWorkbook.Sheets("Field Service Report").Protect Password:="x", UserInterfaceOnly:=True
ThisWorkbook.Sheets("Prompt").Protect Password:="x"
Exit Sub
EH:
Call EH
Resume Next
End Sub
....works fine when called form the immediate window. Sheets hide and unhide appropriately.
But, when I step through the sub it doesn't actually do anything. The idea is to set the sheets to the "prompt" sheet before saving, save, then revert to usable after saving. But I can't even see if that code is working correctly (it appears to) because stepping through the actual hide/unhide subs doesn't do anything.
Edit: No errors, just doesn't change any settings to hide or unhide sheets.
Thoughts?
Edit: So given the comments below, my subs work when run from the immediate window and when stepped through via debugger. They hide and unhide the worksheets appropriately. So, the only thing that can be wrong is the code that calls these subs. So, here are two more subs. One is the button code for a save button, and the other is the Workbook_BeforeSave Sub.
Sub Save_Form()
'Error Handling ...
On Error GoTo EH
'Unprotect the workbook ...
ThisWorkbook.Sheets("Field Service Report").Unprotect Password:="x"
'Variable to disable any other save but this button.
Module1.SaveChk = 1
'Code to automatically save a copy ...
Module1.UserPath = Environ("USERPROFILE")
Module1.Path = UserPath & "\Desktop\"
If Module1.EditChk = "Y" Then
Module1.SaveName = "FSR Master"
Else
Module1.SaveName = Range("AF6").Value
End If
ThisWorkbook.SaveAs _
Filename:=Path & SaveName & ".xlsm", _
FileFormat:=52
If Module1.SaveError <> 1 Then
'User Display of Save Success
MsgBox "Filename = " & SaveName & vbNewLine _
& "File is saved to your desktop."
Else
Module1.SaveError = 0
End If
'Reset SaveChk variable
Module1.SaveChk = 0
'Reprotect Worksheet
ThisWorkbook.Sheets("Field Service Report").Protect Password:="x", UserInterfaceOnly:=True
Exit Sub
EH:
Call ErHa
Resume Next
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Error Handling ...
On Error GoTo EH
'Save Initiation Check
If Module1.SaveChk <> 1 Then
Cancel = True
MsgBox "Please Use Form Save Button", vbOKCancel + vbExclamation, "SAVE CANCELLED"
Exit Sub
End If
If Module1.EditChk <> "Y" Then 'Skips the whole block if EditChk = Y
'Create the final range of cells for checking
Set Module1.Required = Application.Union(Module1.Fixed, Module1.Drive, Module1.Stage)
'Check if all required cells are filled in
If WorksheetFunction.CountA(Module1.Required) < Module1.Required.Count Then
Cancel = True
MsgBox "Please Completed Shaded Cells!", vbOK + vbExclamation, "SAVE CANCELLED"
Module1.SaveError = 1
Else
'Set the report date before saving
Application.EnableEvents = False
Range("AE59") = Format(Now(), "mm-dd-yyyy hh:mm:ss AM/PM")
Application.EnableEvents = True
End If
End If
'Renable Macro Splash Screen Before Save
Call HideSheets
Exit Sub
EH:
Call ErHa
Resume Next
End Sub
I currently enable and disable in different subs where tbA is a textbox, lbA & lbB are listboxes, Generate, Reset & Clse are buttons. There are other codes under these, but I've shorten to show the least amount to reproduce.
After enabling lbA & lbB for input I SetFocus to lbA, but as soon as the sub ends, my focus goes to either Reset or Close
Private Sub Userform_Activate
lbA.Enabled = False
lbB.Enabled = False
Generate.Enabled = False
End Sub
Private Sub tbA_AfterUpdate()
If tbA.TextLength > 0 Then
tbA.Enabled = False
lbA.Enabled = True
lbB.Enabled = True
Generate.Enabled = True
lbA.SetFocus
Elseif tbA.TextLength = 0 Then
Msgbox "Invalid Input"
Exit Sub
End If 'setting focus works up till here
End Sub 'as soon as this sub ends, and it's time for user to input lbA & lbB
'it loses focus to the Reset & Close button
Private Sub Generate_Click()
Msgbox tbA & "from " & lbA " to " & lbB
End
End Sub
Thanks in advance!
The code below restricts access by hiding a sheet unless a password is entered. If it is entered correctly, the sheet can be viewed from the individual tabs. However, it won't let me view and then edit the sheet.
Can this be adjusted to allow the user to enter a password and then view and edit the sheet?
Private Sub Workbook_Open()
Sheets("Sheet1").Visible = xlSheetHidden
End Sub
Public ViewAccess As Boolean 'In restricted sheet's activate event
Private Sub Worksheet_Activate()
If ViewAccess = False Then
Me.Visible = xlSheetHidden
Response = Application.InputBox("Password", xTitleId, "", Type:=2)
If Response = "123" Then
Me.Visible = xlSheetVisible
Application.EnableEvents = True
ViewAccess = True
End If
End If
End Sub
Following code will help you. When a user will select a sheet with name HiddenSheet it will ask for password. If password is correct then it will allow for editing data otherwise will go to previous sheet automatically, You have to change HiddenSheet for your sheet name.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim MySheetName As String
MySheetName = "HiddenSheet" 'The sheed which I want to hide.
If Application.ActiveSheet.Name = MySheetName Then
Application.EnableEvents = False
Application.ActiveSheet.Visible = False
response = Application.InputBox("Password", "Enter Password", "", Type:=2)
If response = "123456" Then 'Unhide Password.
Application.Sheets(MySheetName).Visible = True
Application.Sheets(MySheetName).Select
End If
End If
Application.Sheets(MySheetName).Visible = True
Application.EnableEvents = True
End Sub
Code snipped:
I have an excel file that all my colleagues must have read access, but only a few may have write access.
I tried to introduce in workbook_open a procedure to test user and depending on it to decide how the file to be opened. I learned that does not work directly, so I tried to access an add-in that has a procedure that changes the readonly status.
Private Sub Workbook_Open()
users = Environ("USERNAME")
Select Case users
Case "chris": MsgBox "ok"
Case "david": MsgBox "ok"
Case "sam": MsgBox "ok"
Case Else: Application.Run ("read_only")
End Select
End Sub
This is the sub function in the Addin
Sub read_only()
file_name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
Status = ActiveWorkbook.readonly
ActiveWorkbook.Close ' (the problem is here because also this sub stops when my workbook closes)
If Status = False Then
Workbooks.Open fileName:=file_name, readonly:=True
Else
Workbooks.Open fileName:=file_name, readonly:=False
End If
End Sub
Has anyone an idea how to solve this?
You can do it directly :)
Try this
Private Sub Workbook_Open()
Users = Environ("USERNAME")
Select Case Users
Case "chris": MsgBox "ok"
Case "david": MsgBox "ok"
Case "sam": MsgBox "ok"
Case Else
Application.DisplayAlerts = False
On Error Resume Next
'may already be read only
If ThisWorkbook.Path <> vbNullString Then ThisWorkbook.ChangeFileAccess xlReadOnly
On Error GoTo 0
Application.DisplayAlerts = True
End Select
End Sub