Looking for some help on VBA User restrictions.
So far I have the code pasted below. It is working perfectly, but I want to build on it.
I have it so the specific users listed have access to the file, and anyone else who tries to access the file gets a msgbox saying they aren't authorized and then the book closes.
I am however hoping that some of the users can see some sheets (the sheets they shouldn't see will be xlveryhidden) And then the other users can see the other sheets listed...
ie:
Name 1 can see sheet 13,
Name2 can see sheet14 and sheet3
Name 3 can see sheet22 sheet23 and sheet4
In terms of security it isn't hugely important, they are all from the same team, but just for user friendly and tidy document.
Private Sub Workbook_Open()
Dim Users As Variant
Dim UName As String
Dim UFind As Variant
Users = Array("Name1", "Name2", "Name3", "Name4", "Name5")
UName = Environ("UserName")
On Error Resume Next
UFind = WorksheetFunction.Match(UName, Users, 0)
If Err <> 0 Then
MsgBox "You are not authorised to use this Workbook"
ThisWorkbook.Close SaveChanges:=False
End If
End Sub
Came up with an answer, it is pretty simple, and wont withstand new users being added, but for the mean time it is ok...
Private Sub Workbook_Open()
Dim Users As Variant
Dim UName As String
Dim UFind As Variant
Users = Array("Name1", "Name2", "Name3")
UName = Environ("UserName")
On Error Resume Next
UFind = WorksheetFunction.Match(UName, Users, 0)
If UName = "Name2" Then
Worksheets("Sheet23").Visible = True
Worksheets("SHEET17").Visible = True
ElseIf UName = "Name1" Then
Worksheets("Sheet23").Visible = True
Worksheets("SHEET17").Visible = True
Worksheets("Sheet4").Visible = True
ElseIf UName = "Name3" Then
Worksheets("Sheet23").Visible = True
Worksheets("SHEET17").Visible = True
ElseIf Err <> 0 Then
MsgBox "You are not authorised to use this Workbook"
ThisWorkbook.Close SaveChanges:=False
End If
End Sub
And in order to re-hide them all again when closing the file:
SubPrivate Sub Workbook_BeforeClose(Cancel As Boolean)
Worksheets("Sheet23").Visible = False
Worksheets("SHEET17").Visible = False
Worksheets("Sheet4").Visible = False
Worksheets("Sheet1").Visible = False
‘If you don’t save it’s not effective
Me.Save End Sub
Make changes in your If condition as:
If Err <> 0 Then
MsgBox "You are not authorised to use this Workbook"
ThisWorkbook.Close SaveChanges:=False
Else
For Each ws In Worksheets
If ws.Name <> "Sheet" & UFind Then
ws.Visible = xlSheetHidden
End If
Next ws
End If
Make sure that the sheet names are Sheet1, Sheet2, Sheet3, .. etc as mentioned in the question.
Related
maybe you can help me with this issue:
I am trying to set for one excel sheet different kind of privileges.
For example, there will be an Admin with all right and a guest, how is only allowed the change an range of cells.
I started to setup 2 different kind of logins, the one for the admin is working well however the one for the guest not at all.
What am I doing wrong here?
Ps: I just started to learn VBA ☺
Private Sub CommandButton1_Click()
Dim objTargetWorksheet As Worksheet
'Gast
If (TextBox1.Value = "Gast" And TextBox2.Value = "123") _
Or (TextBox1.Value = "Amy" And TextBox2.Value = "345") _
Or (TextBox1.Value = "Paul" And TextBox2.Value = "456") Then
Me.Hide: Application.Visible = True
For Each objTargetWorksheet In ActiveWorkbook.Worksheets
If objTargetWorksheet.Name = TextBox1.Value Then
Range("K3:K50").Locked = True
ActiveSheet.Protect Password:="12345", Contents:=True
Else
Range("K3:K50").Locked = True
ActiveSheet.Protect Password:="12345", Contents:=True
End If
Next
'Admin
ElseIf TextBox1.Value = "Admin" Then
If TextBox2.Value = "" Then
MsgBox "Please Input the Password"
ElseIf TextBox2.Value = "123" Then
Me.Hide: Application.Visible = True
Else
MsgBox "Please Input the right User Name and the right Password"
End If
Else
MsgBox "Please input the right user name and the right password"
End If
End Sub
Private Sub CommandButton2_Click()
ThisWorkbook.Application.Quit
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
ThisWorkbook.Application.Quit
End Sub
You need to reference the sheet you are working on.
For Each objTargetWorksheet In ActiveWorkbook.Worksheets
If objTargetWorksheet.Name = TextBox1.Value Then
objTargetWorksheet.Range("K3:K50").Locked = True
objTargetWorksheet.Protect Password:="12345", Contents:=True
Else
objTargetWorksheet.Range("K3:K50").Locked = True
objTargetWorksheet.Protect Password:="12345", Contents:=True
End If
Next
UPDATE: Cells are locked by default so you actually have to unlock them before protecting the sheet. Try this:
For Each objTargetWorksheet In ActiveWorkbook.Worksheets
If objTargetWorksheet.Name = TextBox1.Value Then
objTargetWorksheet.Cells.Locked = False
objTargetWorksheet.Range("K3:K50").Locked = True
objTargetWorksheet.Protect Password:="12345", Contents:=True
Else
objTargetWorksheet.Cells.Locked = False
objTargetWorksheet.Range("K3:K50").Locked = True
objTargetWorksheet.Protect Password:="12345", Contents:=True
End If
Next
Afternoon, first off, VBA noob here so take it easy on me and please spell out answers or provide full code as I am not familiar enough to just insert chunks as needed. I need a little more context.
What I am trying to do, is have multiple correct passwords but each password will do something different. This is as far as I have gotten and its current operation is as follows:
Sub zebra()
Dim MyPassword As String
MyPassword = "Zebra" ' Change this to alter password
If InputBox("Please enter password to continue.", "Enter Password") <> MyPassword Then
Dim Ans As Boolean
Const Pword As String = "Zebra" ' This should match password
Ans = False
Do While Ans = False
If InputBox("Please enter password to continue.", "Enter Password") = Pword Then
Ans = True
End If
Loop
Exit Sub
End If
Sheets("Level 3").Visible = True ' This selects what sheet should become visible
End Sub
Essentially, pop-up window, enter Zebra password, loop if wrong, unlock sheet "level 3 if correct". What I would like is if it could have the password Zebra unlock Level 3 but another password such as "Tiger" would unlock another sheet such as "Level 2".
In the end, what ever the password is, I need a specific and basically unique answer but am unsure how to code multiple passwords.
PLEASE NOTE: I would like to avoid writing multiple codes because the user interface needs to be simple enough for any level of proficiency to click a button, enter a password, and receive the correct information with ALL other information being hidden as it is highly confidential.
First off all, the way you are trying to apply "security" is not the appropriate, so I suggest to find another alternatives to secure your file.
An alternative to what you are trying to do is to use Case Statement.
An example:
Select Case MyPassword
Case "Zebra"
Sheets("Level 3").Visible = True
Case "Tiger"
Sheets("Level 3").Visible = False
Sheets("Level 2").Visible = True
Case "Elephant"
AnotherAction
Case ""
Msgbox "Password can not be empty."
Case Else
Msgbox "Wrong password."
End Select
Hope it helps.
Here is another example
Option Base 1
Sub CheckPassword()
Dim allPasswords(3)
allPasswords(1) = "Zebra"
allPasswords(2) = "Tiger"
allPasswords(3) = "Monkey"
Dim passwordEntered As String
Dim iChanceCount As Integer
Dim ws As Worksheet
Do While True
passwordEntered = InputBox("Please enter password to continue.", "Enter Password")
If passwordEntered = allPasswords(1) Then
Set ws = Sheets("Level 1")
Else
If passwordEntered = allPasswords(2) Then
Set ws = Sheets("Level 2")
Else
If passwordEntered = allPasswords(3) Then
Set ws = Sheets("Level 3")
End If
End If
End If
'see if we set the worksheet
If ws Is Nothing Then
iChanceCount = iChanceCount + 1
'give them 5 tries then exit
If iChanceCount >= 5 Then Exit Sub
Else
'we have a worksheet so make it visible and exit
ws.Visible = xlSheetVisible
Exit Sub
End If
Loop
End Sub
This should work, however, you should definitely not use this for sensitive data. If you want to restrict access to diferent sheets for each user, I recommend simply having a separate workbook for each user and having yourself a master file that collects data from all of these workbooks.
Sub testy2ElectricBoogaloo()
dim i as long, ans as boolean
Dim mystr As String
ans = False
ReDim arr(1 To Worksheets.Count, 1 To 2)
For i = 1 To UBound(arr)
arr(i, 1) = Worksheets(i).Name
'My code makes every password simply the sheet name followed by a smiley face.
'Adjust to fit your actual passwords.
arr(i, 2) = Worksheets(i).Name & " :)"
Next i
Do While ans = False
mystr = InputBox("Please enter password to continue.", "Enter Password")
If mystr = vbNullString Then Exit Sub
For i = 1 To ThisWorkbook.Worksheets.Count
If mystr = arr(i, 2) Then ans = True: Worksheets(arr(i, 1)).Visible = True: Exit For
Next i
Loop
End Sub
I'm using Excel 2010. I have an Excel macro-enabled template that has a data connection to a text file that is set to automatically refresh when a new document is created using this template.
The following macro is within the "ThisWorkbook" object to remove the data connection before saving the new document:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Do While ActiveWorkbook.Connections.Count > 0
ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
Loop
End Sub
When a user clicks the save icon / hits ctrl+S, inputs a filename and then clicks save to save as a macro-free Excel workbook (as is the default and required filetype) they are prompted with a message stating:
The following features cannot be saved in macro-free workbooks:
• VB project
To save a file with these features, click No, and then choose a
macro-enabled file type in the File Type list.
To continue saving as a macro-free workbook, click Yes.
Is it possible to prevent this message from appearing and have Excel assume that the user wants to continue with a macro-free workbook?
I've searched all over and understand that I may be able to add code to the workbook object that removes itself so that Excel has no VB project to cause this message but this would require each user to change Trust Center Settings (Trust access to the VBA project object model) which I want to avoid.
I've also seen suggestions of using:
Application.DisplayAlerts = False
but can't get this to work. Every example of it's use seems to be within a sub that is also handling the saving of the document whereas in my situation the BeforeSave sub ends before the document is saved in the default, non-vba way which is perhaps why it does not work?
Does this property reset to a default True after the sub has ended / before the save actually occurs?
Apologies for any nonsense I may have dispensed, my experience with VBA is very limited.
I cannot test on Excel 2010, but at least for 2016, it's working fine:
Sub SaveAsRegularWorkbook()
Dim wb As Workbook
Dim Path As String
Set wb = ThisWorkbook
Path = "T:\he\Path\you\prefer\"
Application.DisplayAlerts = False
Application.EnableEvents = False
wb.SaveAs Filename:=Path & "Test.xlsx", FileFormat:=51
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Give it a try.
Different approach... when the template is loaded, require the user to save as (I have a workbook/template with a similar situation...). This should open them up to the user's Documents folder, though you can adjust to save to whatever location.
Inside of the ThisWorkbook module, put:
Option Explicit
Private Sub Workbook_Open()
Dim loc As Variant
Application.DisplayAlerts = False
loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:="%USERPROFILE%\Documents\NAME_OF_FILE")
If loc <> False Then
ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=51
Exit Sub
End If
Application.DisplayAlerts = True
End Sub
Edit1: Adding the if statement using a base-template name, so subsequent saves do not prompt the save-as:
Option Explicit
Private Sub Workbook_Open()
If ActiveWorkbook.Name = "_NAME_OF_FILE.xlsb" Then
Dim loc As Variant
Application.DisplayAlerts = False
loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:="%USERPROFILE%\Documents\_NAME_OF_FILE")
If loc <> False Then
ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=51
Exit Sub
End If
Application.DisplayAlerts = True
End If
End Sub
For this answer, I'm assuming that by Excel macro-enabled template, you mean a xltm file. I also guess that what you mean by "new document" is the document that is generated when a user double-clicks on the xtlm file (hence this new file has no location on since it hasn't been saved yet).
To solve your issue, you could use a custom SaveAs window (Application.GetSaveAsFilename) to have more control on how the user saves the file when the Workbook_BeforeSave event macro gets called.
Here is how to implement it:
1 - Copy this code into a new module.
Option Explicit
Sub SaveAsCustomWindow()
Const C_PROC_NAME As String = "SaveAsCustomWindow"
Dim strFullFileName As String, strPreferedFolder As String, strDefaultName As String
Dim UserInput1 As Variant, UserInput2 As Variant
Dim isValidName As Boolean, isFileClosed As Boolean, isWorkbookClosed As Boolean
Dim strFilename As String, strFilePath As String
'To avoid Warning when overwriting
Application.DisplayAlerts = False
'Disable events (mostly for the BeforeSave event) to avoid creating infinite loop
Application.EnableEvents = False
On Error GoTo ErrHandler
'Customizable section
strDefaultName = ThisWorkbook.Name
strPreferedFolder = Environ("USERPROFILE")
Do While isWorkbookClosed = False
Do While isFileClosed = False
Do While isValidName = False
UserInput1 = Application.GetSaveAsFilename(InitialFileName:=strPreferedFolder & "\" & strDefaultName, FileFilter:="Excel Workbook (*.xlsx),*.xlsx")
If UserInput1 = False Then
GoTo ClosingStatements 'This is important to take care of the case when the user presses cancel
Else
strFullFileName = UserInput1
End If
strFilename = Right(strFullFileName, Len(strFullFileName) - InStrRev(strFullFileName, "\"))
strDefaultName = strFilename
strFilePath = Left(strFullFileName, InStrRev(strFullFileName, "\") - 1)
strPreferedFolder = strFilePath
'If the file exist, ask for overwrite permission
If Dir(strFullFileName) <> "" Then
UserInput2 = MsgBox(strFilename & " already exists." & vbNewLine & "Do you want to overwrite?", vbYesNoCancel Or vbExclamation)
If UserInput2 = vbNo Then
isValidName = False
ElseIf UserInput2 = vbYes Then
isValidName = True
ElseIf UserInput2 = vbCancel Then
GoTo ClosingStatements
Else
GoTo ClosingStatements
End If
Else
isValidName = True
End If
Loop
'Check if file is actually open
If isFileOpen(strFullFileName) Then
MsgBox "The workbook you want to overwrite is currently open. Choose a different name, or close the workbook before saving.", vbExclamation
isValidName = False
isFileClosed = False
Else
isFileClosed = True
End If
Loop
'Check if an opened workbook has the same name
If isWorkbookOpen(strFilename) Then
MsgBox "You cannot save this workbook with the same name as another open workbook or add-in. Choose a different name, or close the other workbook or add-in before saving.", vbExclamation
isValidName = False
isFileClosed = False
isWorkbookClosed = False
Else
isWorkbookClosed = True
End If
Loop
ThisWorkbook.SaveAs Filename:=strFullFileName, FileFormat:=xlOpenXMLWorkbook
ClosingStatements:
Application.EnableEvents = True
Application.DisplayAlerts = True
Exit Sub
ErrHandler:
Call MsgBox("Run-time error '" & Err.Number & "': " & Err.Description & vbNewLine & _
"While running: " & C_PROC_NAME & IIf(Erl <> 0, vbNewLine & "Error Line: " & Erl, "")
GoTo ClosingStatements
End Sub
Function isFileOpen(ByVal Filename As String) As Boolean
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open Filename For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: isFileOpen = False
Case 70: isFileOpen = True
End Select
End Function
Function isWorkbookOpen(ByVal Filename As String) As Boolean
Dim wb As Workbook, ErrNo As Long
On Error Resume Next
Set wb = Workbooks(Filename)
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: isWorkbookOpen = True
Case Else: isWorkbookOpen = False
End Select
End Function
Explanation of part 1: This whole thing might seem a bit overkill, but all the error handling is important here to take into account potential errors and make sure that the setting for Application.EnableEvents is turned back to TRUE even if an error occurs. Otherwise, all event macros will be disabled in your Excel application.
2 - Call the SaveAsCustomWindow procedure inside the Workbook_BeforeSave event procedure like this:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Your code
If ThisWorkbook.Path = "" Then
SaveAsCustomWindow
Cancel = True
End If
End Sub
Note that we need to set the variable Cancel = True in order to prevent the default SaveAs window to show up. Also, the if statement is there to make sure that the custom SaveAs window will only be used if the file has never been saved.
To answer your questions:
Is it possible to prevent this message from appearing?
Yes, using the Application.DisplayAlerts property
Is it possible to have Excel assume that the user wants to continue with a macro-free workbook?
No, you have to write the procedure to save the workbook and bypass the SaveAs excel event and save the workbook using the user input (Path & Filename) with the required format.
The following procedure uses a FileDialog to capture the Path and Filename from the user then saves the file without displaying the warning message.
I have added some explanatory comments nevertheless, let me know of any questions you might have.
Copy these procedures in the ThisWorkbook module:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True 'Prevents repetitive Save
Call Workbook_BeforeSave_ApplySettings_And_Save
End Sub
Private Sub Workbook_BeforeSave_ApplySettings_And_Save()
Dim fd As FileDialog, sFilename As String
Rem Sets FileDialog to capture user input
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.InitialView = msoFileDialogViewDetails
.Title = vbNullString 'Resets default value in case it was changed
.ButtonName = vbNullString 'Resets default value in case it was changed
.AllowMultiSelect = False
If .Show = 0 Then Exit Sub 'User pressed the Cancel Button
sFilename = .SelectedItems(1)
End With
With ThisWorkbook
Do While .Connections.Count > 0
.Connections.Item(.Connections.Count).Delete
Loop
Application.EnableEvents = False 'Prevents repetition of the Workbook_BeforeSave event
Application.DisplayAlerts = False 'Prevents Display of the warning message
On Error Resume Next 'Prevents Events and Display staying disable in case of error
.SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbook 'Saves Template as standard excel using user input
If Err.Number <> 0 Then
MsgBox "Run-time error " & Err.Number & String(2, vbLf) _
& Err.Description & String(2, vbLf) _
& vbTab & "Process will be cancelled.", _
vbOKOnly, "Microsoft Visual Basic"
End If
On Error GoTo 0
Application.DisplayAlerts = True
Application.EnableEvents = True
End With
End Sub
I've been trying to get my login userform to login when clicked based on data in a table in the workbook, but I just can't seem to get the code right.
Details are:
Userform username textbox = UsernameTextbox;
Userform password textbox = PasswordTextbox;
Userform submit button = LoginButton
My workbook has a number of sheets, one of which is "Users". In that sheet, there is a table called "Users_Table". That table has 4 columns:
ID (individual IDs for users) [Column A],
Username [Column B],
Password [Column C],
Admin (answer is "True" or "False" depending on if they have admin rights) [Column D].
I'm trying to do this:
If the username and password is correct for a user AND if the admin column entry is False, then I want to show sheets "Quick Add" and "Overview", I want to make the sheet "Admin" hidden (not VeryHidden since I need to use data on this sheet for other macros), and make "User" sheets VeryHidden so those logged in can't see other users' details. But for users who correctly enter their username and password AND for whom the admin column entry is True, I want to show all sheets.
This is what I have so far:
Private Sub LoginButton_Click()
Dim Username As String
Username = UsernameTextbox.Text
Dim password As String
Password = PasswordTextbox.Text
If IsNull(Me.UsernameTextbox) Or Me.UsernameTextbox = "" Then
MsgBox "You must enter your username.", vbOKOnly, "Required Data"
Me.UsernameTextbox.SetFocus
Exit Sub
End If
If IsNull(Me.PasswordTextbox) Or Me.PasswordTextbox = "" Then
MsgBox "You must enter your Password (case sensitive).", vbOKOnly, "Incomplete Entry"
Me.PasswordTextbox.SetFocus
Exit Sub
End If
Dim temp As String
On Error Resume Next
temp = WorksheetFunction.VLookup(Me.UsernameTextbox.Value, Worksheets("Users").Range("Users_Table"), 2, 0)
If Username = temp Then
Err.Clear
temp = ""
temp = WorksheetFunction.VLookup(Me.UsernameTextbox.Value, Worksheets("Users").Range("Users_Table"), 3, 0)
On Error Goto 0
If Password = temp Then
Sheets("Quick Add").Visible = xlSheetVisible
Sheets("Overview").Visible = xlSheetVisible
Sheets("Admin").Visible = xlSheetHidden 'This is now just Hidden and not VeryHidden since other macros need to use data on this sheet
Sheets("Users").Visible = xlVeryHidden
MsgBox "Password and Username Accepted. You are now Logged In."
'Unload Me
'Sheets("Quick Add").Select
'Range("A1").Select
Else
Sheets("Quick Add").Visible = xlVeryHidden
Sheets("Overview").Visible = xlVeryHidden
Sheets("Admin").Visible = xlVeryHidden
Sheets("Users").Visible = xlVeryHidden
MsgBox "Username and Password Combination Not Accepted"
End If
Else
Sheets("Quick Add").Visible = xlVeryHidden
Sheets("Overview").Visible = xlVeryHidden
Sheets("Admin").Visible = xlVeryHidden
Sheets("Users").Visible = xlVeryHidden
MsgBox "Invalid Username"
End If
End Sub
This works for the first entry in the "Users_Table", but it won't recognise the Username for the others (and so I don't know if it's recognising the Passwords for users as it's failing on the initial Username check). Any ideas what might be going wrong? I'm also not sure how I'd go about adding in the Admin requirement mentioned above. I need Admins ("True" in "Admin" column, i.e. Column D, in the "Users_Table") to be able to see all sheets; the code above is just for Users and shows "Quick Add" and "Overview" and hides "Admin" and "Users" sheets.
Any help would be much appreciated. Thank you!
Any ideas what might be going wrong?
There are a few errors in the code that don't match your description.
temp = WorksheetFunction.VLookup(Me.UsernameTextbox.Value, _
Worksheets("Users").Range("Users_Table"), 2, 0)
If Username = temp Then
Here you are matching the UsernameTextbox to column A (ID). The test for existence of the username should be in column B not A. The same mistake is made where you are matching the username onto the ID column A insread of the column B of user names:
temp = WorksheetFunction.VLookup(Me.UsernameTextbox.Value, _
Worksheets("Users").Range("Users_Table"), 3, 0)
The best approach would be to fetch to row of the user at once (if it exists) and from there get all the attributes.
Private Sub LoginButton_Click()
' Get the user row or exit if not found
Dim r As Range
Set r = Worksheets("Users").Range("Users_Table").Columns(2) _
.Find(UsernameTextbox.text, , xlValues, xlWhole)
If r Is Nothing Then
MsgBox "username not found."
Me.UsernameTextbox.SetFocus
Exit Sub
End If
If Me.PasswordTextbox.Value <> r.Offset(, 1).Value2 Then
MsgBox "Wrong Password."
Me.PasswordTextbox.SetFocus
Exit Sub
End If
' So far user and password are ok
Dim isAdmin As Boolean: isAdmin = r.Offset(, 2).Value2
Sheets("Quick Add").Visible = xlSheetVisible
Sheets("Overview").Visible = xlSheetVisible
Sheets("Admin").Visible = IIf(isAdmin, xlSheetVisible, xlSheetHidden)
Sheets("Users").Visible = IIf(isAdmin, xlSheetVisible, xlSheetVeryHidden)
End Sub
You have made it very complicated. Keep it simple. Try this (untested)
Private Sub LoginButton_Click()
Dim Username As String
Dim password As String
Dim passWs As Worksheet
Dim rng As Range
Dim CorrectDetails As Boolean
Username = UsernameTextbox.Text
password = PasswordTextbox.Text
If Len(Trim(Username)) = 0 Then
UsernameTextbox.SetFocus
MsgBox "Please enter the username", vbOKOnly, "Required Data"
Exit Sub
End If
If Len(Trim(password)) = 0 Then
PasswordTextbox.SetFocus
MsgBox "Please enter the password", vbOKOnly, "Incomplete Entry"
Exit Sub
End If
Set passWs = ThisWorkbook.Worksheets("Users")
With passWs
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lrow
If UCase(Trim(.Range("B" & i).Value)) = UCase(Trim(Username)) Then '<~~ Username Check
If .Range("C" & i).Value = password Then '<~~ Password Check
CorrectDetails = True
'~~> Admin is True
If .Range("D" & i).Value = "True" Then
'
'~~> Do what you want
'
Else
'
'~~> Do what you want
'
End If
Exit For
End If
End If
Next i
'~~> Incorrect Username/Password
If CorrectDetails = False Then
MsgBox "Invalid Username/Password"
End If
End With
End Sub
My Assumptions
In sheet "Users", Col B has username, Col C has password and Col D has Admin values.. If not then please amend the above code as required.
Hello everyone,
I know that is was a long time ago, but maybe it would be useful for sm1 the code above did not work for me, so I modify it for my requirements.
Some details of my code:
CommandButton2 it is my "LogIn Button";
TextBox5 it is my "User / Admin name";
TextBox7 it is my "User / Admin password";
Worksheets("LOG") it is a name and location of the table with "User / Admin names and passwords" data, where col B - usernames, col C - user passwords, col d - admin names, col e - admin passwords. The difference between admin and user rights in my case only in visibility of application (Excel).
Private Sub CommandButton2_Click()
Dim passWs As Worksheet
Dim CorrectDetails As Boolean
Username = TextBox5.Text
password = TextBox7.Text
If Len(Trim(Username)) = 0 Then
TextBox5.SetFocus
MsgBox "Please enter the username", vbOKOnly, "Required Data"
Exit Sub
End If
If Len(Trim(password)) = 0 Then
TextBox7.SetFocus
MsgBox "Please enter the password", vbOKOnly, "Incomplete Entry"
Exit Sub
End If
Set passWs = ThisWorkbook.Worksheets("LOG")
With passWs
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If UCase(Trim(.Range("B" & i).value)) = UCase(Trim(Username)) Then '<~~ Username Check
If .Range("C" & i).value = password Then '<~~ Password Check
CorrectDetails = True
If CorrectDetails = True Then
Application.Visible = False
Me.TextBox5.Text = ""
Me.TextBox7.Text = ""
LogIn.Hide
UserForm1.Show
End If
Exit For
End If
End If
If UCase(Trim(.Range("D" & i).value)) = UCase(Trim(Username)) Then '<~~ Adminname Check
If .Range("E" & i).value = password Then '<~~ Admin Password Check
CorrectDetails = True
If CorrectDetails = True Then
Application.Visible = True
Me.TextBox5.Text = ""
Me.TextBox7.Text = ""
LogIn.Hide
End If
Exit For
End If
End If
Next i
'~~> Incorrect Username/Password
If CorrectDetails = False Then
MsgBox "Invalid Username/Password"
End If
End With
End Sub
I am not a professional, but I am trying to find a way where a user of an excel workbook I created can select and insert a picture (company logo) in left header of all sheets in an excel workbook.
If possible it should be possible to change the picture also, i.e., remove the current picture (if any) and insert a new one. I have searched and found some solutions using macro, but have not found a complete solution to what I am trying to achieve. Appreciate any help.
This seems to work properly (with a virtual printer
Option Explicit
Public Sub setLeftHeaderImage()
Const TITLE As String = "Select Header Image"
Const IMG_TYPES As String = "All Files (*.*),*.*,Jpg (*.jpg),*.jpg,Png (*.png),*.png"
Dim selectedFile As Variant, iniName As String, ws As Worksheet
selectedFile = Application.GetOpenFilename(FileFilter:=IMG_TYPES, TITLE:=TITLE)
If selectedFile <> False Then
For Each ws In Worksheets
With ws.PageSetup
Application.PrintCommunication = False
With .LeftHeaderPicture
.Filename = selectedFile
.Height = 71.25
.Width = 117.75
.Brightness = 0.36
.ColorType = msoPictureAutomatic 'msoPictureWatermark
End With
Application.PrintCommunication = True
On Error GoTo ShowError 'https://support.microsoft.com/en-us/kb/291298
.LeftHeader = "&G" '"&G" Enable the image to show up in left header
.Zoom = 100
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Next
Exit Sub
ShowError:
MsgBox "Setup a printer and 'Print Spooler' service; (" & Err.Description & ")"
End If
End Sub
Thanks for the suggestions EEM!