Read and Write Office2003 UserName

Forums

My Profile

Inbox

Address Book

My Subscription

My Forums

Read and Write Office2003 UserName

Logged in as: Guest

arrSession:exec spGetSession 2,16,62426

	Active Users: There are 0 members and 0 guests.
	Users viewing this topic: none

Printable Version

All Forums >> [Scripting] >> Post a VBScript >> Read and Write Office2003 UserName
Do you like VisualBasicScript.com? Link to us and help spread the word about our forum. Thanks!

Page: [1]

Message

<< Older Topic Newer Topic >>

Read and Write Office2003 UserName - 7/16/2008 3:11:29 PM

TomRiddle

Posts: 165
Score: 4
Joined: 2/7/2008
Status: offline

'Script by TomRiddle 2008
'Read UserName that Office2003 uses for new documents. 
'Change UserName that Office2003 uses for new documents to be the same as user's AD DisplayName.
'Tested works on XPpro sp2 workstations

'Office uses this name to report to other users who has documents open. 
'Message:- xxx.doc is locked for editing by 'UserName'

'-----------------------------------------------------------------------
  const HKEY_CURRENT_USER = &H80000001
  Const HKEY_USERS  = &H80000003 
  strComputer = inputbox("Enter name of REMOTE PC to check the "&vbcrlf&"current user's office userName property "&vbcrlf&vbcrlf&"Press cancel to check THIS computer's"&vbcrlf&"Office2003 UserName Property")

if strComputer<>"" then
    'ACT ON REMOTE MACHINE ***********************************************
     CU=GetCurrentUser(strComputer)
     CUSID = GetSIDFromUser(CU)
     CUDisplayName=GetFullNameFromUser(CU) 
     Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" &_ 
        strComputer & "\root\default:StdRegProv")

strKeyPath = CUSID&"\Software\Microsoft\Office\11.0\Common\UserInfo"
     strValueName = "UserName"
     oReg.GetBinaryValue HKEY_USERS,strKeyPath,strValueName,strValue
 
     For i = lBound(strValue) to uBound(strValue)
        if strValue(i) <> "0" then
           hexUserName = hexUserName & "%" & hex(strValue(i))
        end if
     Next
     strOfficeUserName = hexDecode(hexUserName)
     'if lcase(strOfficeUserName) = lcase("mcs") then
     if lcase(strOfficeUserName) <> lcase(CUDisplayName) then
        LenCUDisplayName=len(CUDisplayName)
        For i=1 to LenCUDisplayName
           Binary = Binary & "&H" & hex(ASC(mid(CUDisplayName,i,1))) & ",&H00,"
        next
        Binary = Binary & "&H00" & ",&H00"
        arrayBinary=split(Binary, ",")
        oReg.SetBinaryValue HKEY_USERS,strKeyPath,strValueName,arrayBinary
        msgbox "Set Key" & vbcrlf &"Changed Office UserName "& hexDecode(hexUserName)&vbcrlf&"To "&CUDisplayName
     else
        msgbox "No change"&vbcrlf& hexDecode(hexUserName)&" is ok for user "&CUDisplayName
     end if

else

'ACT ON LOCAL MACHINE ***************************************************
     strComputer = "."
     CU=GetCurrentUser(strComputer)
     CUDisplayName=GetFullNameFromUser(CU) 
     Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" &_ 
        strComputer & "\root\default:StdRegProv")

strKeyPath = "Software\Microsoft\Office\11.0\Common\UserInfo"
     strValueName = "UserName"
     oReg.GetBinaryValue HKEY_CURRENT_USER,strKeyPath,strValueName,strValue
 
     For i = lBound(strValue) to uBound(strValue)
        if strValue(i) <> "0" then
           hexUserName = hexUserName & "%" & hex(strValue(i))
        end if
     Next
     strOfficeUserName = hexDecode(hexUserName)
     'if lcase(strOfficeUserName) = lcase("mcs") then
     if lcase(strOfficeUserName) <> lcase(CUDisplayName) then
        LenCUDisplayName=len(CUDisplayName)
        For i=1 to LenCUDisplayName
           Binary = Binary & "&H" & hex(ASC(mid(CUDisplayName,i,1))) & ",&H00,"
        next
        Binary = Binary & "&H00" & ",&H00"
        arrayBinary=split(Binary, ",")
        oReg.SetBinaryValue HKEY_CURRENT_USER,strKeyPath, strValueName, arrayBinary
        msgbox "Set Key" & vbcrlf &"Changed Office UserName "& hexDecode(hexUserName)&vbcrlf&"To "&CUDisplayName
     else
        msgbox "No change"&vbcrlf& hexDecode(hexUserName)&" is ok for user "&CUDisplayName
     end if
  end if

'-----------------------------------------------------------------------
function hexDecode(str)
'Convert HEX to a readable string
'http://www.philreeve.com/hexEncodeDecode.php
  dim strDecoded, i, hexValue
  strDecoded = ""
  for i = 2 to Len(str)
     hexValue = ""
     while Mid(str, i, 1) <> "%" and i <= Len(str)
        hexValue = hexValue + Mid(str, i, 1)
           i = i+1
     wend
     strDecoded = strDecoded + chr(CLng("&h" & hexValue))
  next
  
  hexDecode = strDecoded
end function
'-----------------------------------------------------------------------
Function GetCurrentUser(strComputer) 
'Input: strComputer = machine to query 
'Output: Current User as domain\logon 
'http://groups.google.com/group/microsoft.public.scripting.vbscript/msg/1bd0d208ef41dda7
  Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") 
  Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'explorer.exe'") 
  For Each objProcess in colProcessList 
     objProcess.GetOwner strUserName, strUserDomain 
  Next 
  GetCurrentUser = strUserDomain & "\" & strUserName 
End Function 
'-----------------------------------------------------------------------
Function GetSIDFromUser(UserName) 
'Input: UserName as domain\logon 
'Output: SID 
'http://groups.google.com/group/microsoft.public.scripting.vbscript/msg/1bd0d208ef41dda7

Dim DomainName, Result, WMIUser

If InStr(UserName, "\") > 0 Then 
   DomainName = Mid(UserName, 1, InStr(UserName, "\") - 1) 
   UserName = Mid(UserName, InStr(UserName, "\") + 1) 
 Else 
   DomainName = CreateObject("WScript.Network").UserDomain 
 End If

On Error Resume Next 
 Set WMIUser = GetObject("winmgmts:{impersonationlevel=impersonate}!" _ 
   & "/root/cimv2:Win32_UserAccount.Domain='" & DomainName & "'" _ 
   & ",Name='" & UserName & "'") 
 If Err = 0 Then Result = WMIUser.SID Else Result = ""

On Error GoTo 0 
 GetSIDFromUser = Result 
End Function 
'-----------------------------------------------------------------------
Function GetFullNameFromUser(UserName) 
'Input: UserName as domain\logon 
'Output: FullName 
 Dim DomainName, Result, WMIUser 
 If InStr(UserName, "\") > 0 Then 
   DomainName = Mid(UserName, 1, InStr(UserName, "\") - 1) 
   UserName = Mid(UserName, InStr(UserName, "\") + 1) 
 Else 
   DomainName = CreateObject("WScript.Network").UserDomain 
 End If

On Error GoTo 0 
 GetFullNameFromUser = Result 
End Function