Now this is one I have designed myself from scratch.
At its simplest level, CU_UserID("someID") checks for a match in the Windows UserID, which is great if you distribute an XLSM file and don't want Event macros to run for anyone else but yourself.
As a more complex function, CU_Public will check the current user against a specified file list of "valid users" which should be held in an Excel (or CSV) validation file, stored somewhere publicly accessible, e.g. a read-only SharePoint site or some other web URL.
Makes use of code copied from modSpecialFolders
'modCheckUsers
'v2.02 2013-10-29 10:34
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com
' DGF Help Contact: see BPMHelpContact module
'=========================================================================
'===========================================================================
' modCheckUsers
'===========================================================================
' Checks current Windows userID against specified userID, or against
' predetermined access list (outlined below)
'
'===========================================================================
' Additional modules required:
'===========================================================================
' modAppsOffice v4.05
'
' Code included from other modules:
' [modSpecialFolders]
'
'=========================================================================
' VERSION HISTORY
'=========================================================================
' v2.02 bugfix: CU_Controlled opens new Excel session invisible and quits
' (needed for compatibility with modAppsOffice v4.05)
' v2.01 bugfix: CU_Controlled always opens new Excel session
' v2.00 added code from modSpecialFolders
' v1.10a annotations only
' v1.10 late bound references
' v1.09 bugfix: opens lookup ReadOnly
' v1.08 bugfixes: CU_controlled open/close
' CheckUsers master list moved to iShare (hidden folder)
' v1.07 bugfix: Application.Statusbar for non-Excel applications
' v1.06 annotations improved, no functional change
' v1.05 added CU_userID (legacy: replaces CU_tparish and CU_userKID, both remain functional)
' renamed constants (e.g. CU_masterpth)
' v1.02 added StatusBar messages
Option Explicit
'Checks current user KID against known access lists
' CU_userID - checks whether current user matches specified userID 'v1.05
' CU_Public - checks userIDs file in specified path
' CU_Controlled - checks Controlled userIDs file, here:
Private Const CU_masterpth As String = "\\ishare.dhl.com\sites\DGFUK\BPMpublic\CheckUsers\" 'v1.08
Private Const CU_masterfn As String = "Approved User IDs.xls" 'v1.05
'place list of valid KIDs in column 1 of each sheet / sheet 1 of each file
'further columns and column headers are irrelevant but can be used
Private Const CU_StatusBar = "Checking user ID" 'v1.02
Private blnASU As Boolean
'=================================================================================================
'=================================================================================================
'=================================================================================================
'=================================================================================================
'
' Code from modSpecialFolders module:
'
'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009
Private Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hwnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
'Desktop
Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Private Const CSIDL_PERSONAL = &H5 'My Documents
Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites
Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Private Const CSIDL_RECENT = &H8 '<user name>\Recent
Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo
Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin
Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu
Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop
Private Const CSIDL_DRIVES = &H11 'My Computer
Private Const CSIDL_NETWORK = &H12 'Network Neighborhood
Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood
Private Const CSIDL_FONTS = &H14 'Windows\fonts
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data
Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood
Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)
Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Private Const CSIDL_COMMON_FAVORITES = &H1F
Private Const CSIDL_INTERNET_CACHE = &H20
Private Const CSIDL_COOKIES = &H21
Private Const CSIDL_HISTORY = &H22
Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Private Const CSIDL_WINDOWS = &H24 'Windows Directory
Private Const CSIDL_SYSTEM = &H25 'System Directory
Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Private Const CSIDL_PROFILE = &H28 'USERPROFILE
Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools
Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
Private Const MAX_PATH = 260
Private Const NOERROR = 0
Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String
strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function
'=================================================================================================
'=================================================================================================
'=================================================================================================
'=================================================================================================
Private Sub CU_app(ByVal CU_Status As Boolean, Optional ByVal CU_StatusMsg As String)
'v1.07 2013-06-05 17:16
'always run CU_app(False,CU_StatusMsg) before and CU_app(True) after
'CU_StatusMsg is appended to CU_StatusBar
If CU_Status = False Then
'start of process
If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = CU_StatusBar & CU_StatusMsg
blnASU = Application.ScreenUpdating
Application.ScreenUpdating = False
Else
'end of process
Application.ScreenUpdating = blnASU
If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False
End If
End Sub
Function CU_userID(ByVal userID As String) As Boolean
'v2.00 2013-08-09 11:20
'checks whether current user matches specified userID
Dim CU_StatusMsg As String
CU_StatusMsg = ": user " & userID
CU_app False, CU_StatusMsg
If InStr(UCase(SpecFolder(CSIDL_PROFILE)), UCase(userID)) > 0 Then CU_userID = True
CU_app True
End Function
Function CU_Public(ByVal UserListFolder As String) As Boolean
'v1.10 2013-07-10 13:07
'checks current user KID against approved KIDs. This function checks
'KID file [CU_masterfn] in [UserListFolder], so can be used by anyone
'list of KIDs in column 1 of CU_masterfn in UserListFolder
'further columns and column headers are irrelevant
Dim CU_StatusMsg As String
CU_StatusMsg = " against approved KIDs in " & CU_masterfn & " in " & UserListFolder
CU_app False, CU_StatusMsg
'open RecordSet from TXT, instead of opening XLS user IDs file?
Const cBsl As String = "\"
Const cFsl As String = "/"
Dim pth As String, WB As Object, rng As Object
pth = UserListFolder
If InStr(pth, cBsl) = 0 And InStr(pth, cFsl) = 0 Then
MsgBox pth & vbLf & "Path incorrect or not specified", vbCritical, "CU_Public failed"
Exit Function
Else
pth = pth_sl(pth) 'adds slash to end of path if required
End If
Dim XLapp As Object
Set XLapp = XLlaunch 'requires modAppsOffice
Set WB = XLapp.Workbooks.Open(FileName:=CU_masterpth & CU_masterfn, ReadOnly:=True)
Set rng = WB.Sheets(1).Columns(1).Cells(1)
If rng.Offset(1) <> "" Then Set rng = WB.Sheets(1).Range(rng, rng.End(-4121)) 'xlDown
CU_Public = CU_KIDlist(rng)
WB.Close
Set WB = Nothing
XLapp.Quit
'Set XLapp = XLclose(XLapp)
If XLapp Is Nothing Then Else MsgBox "Warn: XLclose failed"
CU_app True
End Function
Function CU_Controlled(ByVal UserList As String) As Boolean
'v2.02 2013-10-29 10:34
'checks current user KID against approved KIDs. This function
'checks sheet [UserList] in master file on BPMpublic shared drive
'which can only be edited by specific users
'e.g. "Sales Admin" or "BPM Admin"
Dim CU_StatusMsg As String
CU_StatusMsg = " against protected KIDs in " & UserList & " sheet in " & CU_masterfn & " on BPMpublic shared drive"
CU_app False, CU_StatusMsg
If Dir(CU_masterpth & CU_masterfn) <> CU_masterfn Then Exit Function
'open RecordSet from TXT, instead of opening XLS user IDs file?
Dim XLapp As Object, WB As Object, rng As Object 'v1.10
Set XLapp = XLlaunch(False) 'v2.02 'v2.01
Set WB = XLapp.Workbooks.Open(FileName:=CU_masterpth & CU_masterfn, ReadOnly:=True)
Set rng = WB.Sheets(UserList).Columns(1).Cells(1)
If rng.Offset(1) <> "" Then Set rng = WB.Sheets(UserList).Range(rng, rng.End(-4121)) 'xlDown
CU_Controlled = CU_KIDlist(rng)
WB.Close
Set WB = Nothing
If Not XLapp Is Application Then
Set XLapp = Nothing
If XLapp Is Nothing Then Else MsgBox "Warn: XLclose failed"
End If
CU_app True
End Function
Private Function CU_KIDlist(ByRef KIDlist As Object) As Boolean
'v1.10 2013-07-10 13:03
Dim k As Byte, kmax As Byte, userfolder As String
userfolder = UCase(SpecFolder(CSIDL_PROFILE))
kmax = KIDlist.Cells.Count
Dim userKID() As String
ReDim userKID(1 To kmax) As String
For k = 1 To kmax
userKID(k) = UCase("" & KIDlist.Cells(k).Text)
Next k
For k = 1 To kmax
'NB: PROFILE includes \Documents and Settings\ in WinXP or \Users\ in Win7
If InStr(userfolder, userKID(k)) > 0 Then
CU_KIDlist = True
Exit Function
End If
Next k
End Function
Private Function pth_sl(ByVal PathToAddSlash As String) As String
'v1.02 2013-01-06 10:40
'from modZip v3.04 2012-11-06 16:06
'adds a slash to end of path (if required)
Const cFsl As String = "/" 'URL
Const cBsl As String = "\" 'UNC
If InStr(PathToAddSlash, cFsl) > 0 And Right(PathToAddSlash, 1) <> cFsl Then
pth_sl = PathToAddSlash & cFsl
Do Until InStr(cFsl & cFsl, pth_sl) = 0
pth_sl = Replace(pth_sl, cFsl & cFsl, cFsl)
Loop
Exit Function
ElseIf InStr(PathToAddSlash, cBsl) > 0 And Right(PathToAddSlash, 1) <> cBsl Then
pth_sl = PathToAddSlash & cBsl
Do Until InStr(cBsl & cBsl, pth_sl) = 0
pth_sl = Replace(pth_sl, cBsl & cBsl, cBsl)
Loop
Exit Function
End If
End Function
'**** legacy code, replaced by CU_userID in v1.05 ****
Function CU_userKID(ByVal userKID As String) As Boolean
'v1.02 2013-01-06 10:32 **** legacy code only, replaced by CU_userID in v1.05
CU_userKID = CU_userID(userKID)
End Function
'**** legacy code, replaced by CU_userID in v1.05 ****
Function CU_tparish() As Boolean
'v1.02 2013-01-06 10:32 **** legacy code only, replaced by CU_userID in v1.05
Const userKID As String = "tparish"
CU_tparish = CU_userID(userKID)
End Function
No comments:
Post a Comment