Option Strict On
Imports Microsoft.Win32
Imports System.Text
Imports System.Security.Cryptography
Public Module AccountManagement
'Please enjoy this example.
'
'The Name of the Root key where your accounts will be stored(appkey)
'You need to set this to whatever you want
'
Public AppKey As String = "TESTAPPTITLE"
'
'
'
'
'
'
'
'it will be a subkey of this------------>
Public MyRegistryKey As String = "Software\" & AppKey
'The main Root Node(further modification will be needed if you attempt to use HKLM)...
Public Node As String = "HKEY_CURRENT_USER\"
'The path to the key of your stored values
Public MyUsersRegistryKey As String = Node & MyRegistryKey & "\" & "Users"
'The current user
Public CurrentUserName As String
'Tells if the user is logged in or not
Public LoggedIn As Boolean = False
'The list of allowable characters for usernames/passwords
Public ValidPasswordCharacters As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890`1234567890-=!@#$%^&*()_+[]\;',./{}|:""<>? "
Public ValidUserNameCharacters As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
Public Function Accounts() As List(Of String)
'This function will return a list of account names
Dim regKey As Microsoft.Win32.RegistryKey
regKey = Registry.CurrentUser.OpenSubKey(MyUsersRegistryKey, True)
Dim AccountNames() As String = regKey.GetSubKeyNames
Dim AccountList As New List(Of String)
For Each Subkey As String In AccountNames
AccountList.Add(Subkey)
Next
Return AccountList
End Function
Public Function AllowLogin(ByVal UserName As String, ByVal Password As String) As Boolean
If CreateHash(UserName & Password) = GetStoredUserHash(UserName) Then
Return True
Else
Return False
End If
End Function
Public Sub ChangePassword(ByVal ExisitingAccountName As String, ByVal NewPassword As String)
Dim CurrentUserSubKey As String = Node & MyUsersRegistryKey & "\" & ExisitingAccountName
Dim PWHash As String = CreateHash(ExisitingAccountName & NewPassword)
SetValue(CurrentUserSubKey, "Hash", PWHash)
End Sub
Public Sub CreateAccount(ByVal NewAccountName As String, ByVal Password As String, ByVal IsAdmin As Boolean)
Select Case ContainsValidCharacters(NewAccountName, Vmode.UserName)
Case True
Select Case ContainsValidCharacters(Password, Vmode.Password)
Case True
Dim CurrentUserSubKey As String = Node & MyUsersRegistryKey & "\" & NewAccountName
Dim PWHash As String = CreateHash(NewAccountName & Password)
My.Computer.Registry.CurrentUser.CreateSubKey(CurrentUserSubKey)
SetValue(CurrentUserSubKey, "UserName", NewAccountName)
SetValue(CurrentUserSubKey, "Hash", PWHash)
'------------------------------
'This is where you would add your custom permissions
'------------------------------
'First you put the user's subkey, then the name of the permission, then whether the user is granted that permission or not
'Replace these with whatever you want
AddPermission(CurrentUserSubKey, "Read", True)
AddPermission(CurrentUserSubKey, "Write", True)
AddPermission(CurrentUserSubKey, "Access", True)
AddPermission(CurrentUserSubKey, "Function1", True)
AddPermission(CurrentUserSubKey, "Function2", True)
AddPermission(CurrentUserSubKey, "Function3", True)
AddPermission(CurrentUserSubKey, "Function4", True)
Case Else
MsgBox("The password for the new account contains invalid characters!")
End Select
Case Else
MsgBox("The new account name contains invalid characters!")
End Select
End Sub
Public Function AccessIsAllowed(ByVal CurrentUser As String, ByVal RequiredPermission As String) As Boolean
Dim CurrentUserSubKey As String = Node & MyUsersRegistryKey & "\" & CurrentUser
If PermissionGranted(CurrentUserSubKey, RequiredPermission) = True Then
Return True
Else
Return False
End If
End Function
Public Sub SampleFunctionWithRequiredPermission()
If AccessIsAllowed(CurrentUserName, "Function1") = True Then
'Some Code
'Some Functionality
'Some Result
MsgBox("Access Granted!")
Else
MsgBox("Access Denied!")
End If
End Sub
Public Sub AddPermission(ByVal CurrentUserSubKey As String, ByVal PermissionName As String, ByVal GrantPermission As Boolean)
SetValue(CurrentUserSubKey, PermissionName, GrantPermission)
End Sub
Public Function CreateHash(ByVal SourceText As String) As String
Dim Ue As New UnicodeEncoding()
Dim ByteSourceText() As Byte = Ue.GetBytes(SourceText)
Dim Md5 As New MD5CryptoServiceProvider()
Dim ByteHash() As Byte = Md5.ComputeHash(ByteSourceText)
Return System.Convert.ToBase64String(ByteHash)
End Function
Public Sub DeleteAccount(ByVal UserName As String)
My.Computer.Registry.CurrentUser.DeleteSubKey(MyUsersRegistryKey & "\" & UserName)
End Sub
Public Function GetStoredUserHash(ByVal UserName As String) As String
Dim Hash As String
Dim CurrentUserSubKey As String = Node & MyUsersRegistryKey & "\" & UserName
Hash = DirectCast(My.Computer.Registry.GetValue(CurrentUserSubKey, "Hash", 0), String)
Return Hash
End Function
Public Sub Login(ByVal UserName As String, ByVal Password As String)
If AllowLogin(UserName, Password) = True Then
CurrentUserName = UserName
LoggedIn = True
'-------------------------
'Your Extended Login Code
'-------------------------
End If
End Sub
Public Sub Logoff()
CurrentUserName = ""
LoggedIn = False
'--------------------
'Your Extended Code To Logoff
'--------------------
End Sub
Public Sub SetValue(ByVal Key As String, ByVal ValueName As String, ByVal Value As Object)
My.Computer.Registry.SetValue(Key, ValueName, Value)
End Sub
Public Function PermissionGranted(ByVal Key As String, ByVal ValueName As String) As Boolean
Try
Return DirectCast(My.Computer.Registry.GetValue(Key, ValueName, False), Boolean)
Catch
Return False
End Try
End Function
Public Function ContainsValidCharacters(ByVal Item As String, ByVal ValidationMode As Vmode) As Boolean
Select Case ValidationMode
Case Vmode.Password
For Each letter As String In Item
If InStr(ValidPasswordCharacters, letter) < 1 Then
Else
Return False
End If
Next
Return True
Case Vmode.UserName
For Each letter As String In Item
If InStr(ValidUserNameCharacters, letter) < 1 Then
Else
Return False
End If
Next
Return True
Case Else
Return False
End Select
End Function
Public Enum Vmode
UserName
Password
End Enum
End Module
|
