There are multiple command buttons each with similar code for sign off in a particular cell:
Public Sub CommandButton1_Click()
If Range("S106") <> vbNullString Then
MsgBox ("Initial-NAV Preparer has already been signed off !")
Range("C106").Select
Else
Unprtsht
Worksheets("Checklist").Range("A1:K101").Locked = True
Range("E106").Activate
Call ApplySignOff(0, 1)
Prtsht
End If
End Sub
Public Sub CommandButton2_Click()
If Range("S108") <> vbNullString Then
MsgBox ("Initial-NAV Preparer has already been signed off !")
Range("C108").Select
Else
Unprtsht
Worksheets("Checklist").Range("A1:K101").Locked = True
Range("E108").Activate
Call ApplySignOff(0, 1)
Prtsht
End If
The code to actually get the sign-off is maintained in module 1 of the macro as follows:
Const sPassword = "password"
Sub Unprtsht()
ActiveSheet.Unprotect sPassword
End Sub
Sub Prtsht()
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=sPassword
End Sub
'Function will return True if the user xasn't already signed off
'sGroup - when set to 1 checks Pre-XxXX, when set to 2 check Post-XXXX
Public Function CheckUser(sUser As String, sGroup As Integer) As Boolean
Dim Rng As Range
CheckUser = False
If sGroup = 1 Then
With ActiveSheet.Range("S104:S128")
Set Rng = .Find(What:=sUser)
End With
Else
With ActiveSheet.Range("S156:S167")
Set Rng = .Find(What:=sUser)
End With
End If
If Rng Is Nothing Then CheckUser = True
End Function
Public Function ApplySignOff(iSignatureOffset, sGroup As Integer)
Dim sDisplayname As String
Dim SingleSignOffCheck As String
sDisplayname = GetDisplayName(Environ("USERNAME"))
SingleSignOffCheck = Environ("USERDOMAIN") & "\" & Environ("USERNAME")
Application.ScreenUpdating = False
If CheckUser(SingleSignOffCheck, sGroup) Then
'Unprtsht
ActiveCell.Value = sDisplayname & " (" & SingleSignOffCheck & " " & Date & ")"
ActiveCell.Offset(iSignatureOffset, 11).Value = SingleSignOffCheck
'Prtsht
Else
MsgBox "Current user has already signed off this checklist"
End If
Application.ScreenUpdating = True
End Function
Public Function GetDisplayName(sAMAccountName As Variant) As String
Dim objconn As Object
Dim objCommand As Object
Dim objRoot As Object
Dim objDomain As Object
Dim objRS As Object
Dim strDomain As String
Dim strSQL As String
Dim varSearch As Variant
On Error GoTo PROC_ERR
GetDisplayName = ""
Set objconn = CreateObject("ADODB.Connection")
objconn.Provider = "ADsDSOObject"
objconn.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objconn
Set objRoot = GetObject("
ldap://rootDSE")
strDomain = objRoot.get("defaultNamingContext")
Set objDomain = GetObject("LDAP://" & strDomain)
strSQL = "SELECT displayname FROM 'LDAP://" & strDomain & "'" & _
" WHERE sAMAccountName='" & sAMAccountName & "'"
objCommand.CommandText = strSQL
Set objRS = objCommand.Execute
If objRS.RecordCount > 0 Then
With objRS
.MoveFirst
While Not .EOF
GetDisplayName = !DisplayName
.MoveNext
Wend
.Close
End With
End If
PROC_EXIT:
Set objRS = Nothing
Set objconn = Nothing
Set objCommand = Nothing
Set objRoot = Nothing
Set objDomain = Nothing
Exit Function
PROC_ERR:
MsgBox "Error getting display name for " & sAMAccountName & ". Error " & Err.Number & ": " & Err.Description, vbCritical
Resume PROC_EXIT
End Function