Datei im Netzwerk bereits mit Schreibrechten geöffnet - Anzeige Benutzername fehlt

' Modify the display name and user initials  

' entries in the registry for Office 2007 applications   
'  
' ****************************************************  
Option Explicit
' Main procedure to set registry keys  
Sub Main

' Declare variables  

Dim strDisplayName, strIn 
Dim objWshShell, objSysinfo    
' Create Active Directory System object  
Set objSysinfo    = WScript.CreateObject("ADSystemInfo")  
' Get display name from user object  
strDisplayName = Trim(GetUserNameFromAD(objSysinfo.username))
' Get extracted user initals  
strIn = Trim(GetUserInitials(strDisplayName))
'Create WScript Shell object  
Set objWshShell = WScript.CreateObject ("WScript.Shell")   
' Set UserName   
objWshShell.Run "Reg Add HKCU\Software\Microsoft\Office\Common\UserInfo /v UserName /d " & _  
chr(34) & strDisplayName & chr(34) & " /f", 1, TRUE  
' Set UserInitals  
objWshShell.Run "Reg Add HKCU\Software\Microsoft\Office\Common\UserInfo /v UserInitials /d " & _  
chr(34) & strIn & chr(34) & " /f", 1, TRUE  
 ' Dispose WScript Shell object  
Set objWshShell = nothing
End Sub
' Function to read user object from Active Directory  
Function GetUserNameFromAD(ADsPath)
Dim objUser
' Get AD object  
Set objUser = GetObject("LDAP://" & ADsPath)  
' Get Common Name from AD object  
GetUserNameFromAD = objUser.Get("cn")  
' Dispose AD object  
Set objUser = nothing
End Function
' Function to  extract intials from Common Name  
Function GetUserInitials(UserName)
' Reset errors  
Err.Clear 
' Extract user initals  
GetUserInitials =  Mid(UserName, InStr(Username, " ") + 1, 1) & Mid(UserName, 1, 1)  
' Check if an error has occured and set initals to an empty string  
If Err.Number <> 0 Then
GetUserInitials = ""  
Err.Clear
End If
End Function
' Call Main Procedure  
Main()