VBA no longer working via citrix or VMware

Danni

New Member
Joined
Feb 23, 2013
Messages
11
We have a simple macro where multiple users in multiple locations can sign off on a daily checklist. If a user signs off via citrix or VMware other users are then prevented from signing off. No error message is received, when they click the button absolutely nothing happens.

I looked at the code and got a few other to look at it and all seems fine, users not accessing the network via citrix or VMware have no issues in signing off the checklist.

The checklist was working fine of all users one day then suddenly stopped working for the citrix/vmware users the next with no change being made to the code.

Has anyone ever seen this before or have any idea what could have caused a macro that had previously been working for over a year to suddenly stop working?

Any help would be greatly appreciated!
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Danni

New Member
Joined
Feb 23, 2013
Messages
11
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
 

Watch MrExcel Video

Forum statistics

Threads
1,095,545
Messages
5,445,106
Members
405,316
Latest member
joaoamaro

This Week's Hot Topics

Top