J House Consulting

' This script will add the Users' correct Username and UserInitials to the MS Office
' registry key to prevent the first time prompt when a user runs up a program in the
' Office suite.
'
' Simply set all Office versions you are using in the arrVersions array.
'
' Note that all Office versions before 2007 (12.0) used a Binary value, hence the
' reason for needing to use the ConvertStringToBinary() function.
'
' It derives the Users' initials from their username based on common naming standards.
'   For Example:
'             If the username is Jeremy.Saunders, the initials will be JS
'             If the username is jsaunders, the initals will also be JS
' This is easy to change/add/modify should you be using a different naming standard
' that follows a different pattern.
'
' Release 1.0
' Written by Jeremy@jhouseconsulting.com on 19th April 2009.
'
Option Explicit

Dim arrBinaryValue(), strUsername, strUserInitials, strTemp, intNumberOfChars, objWSHNetwork
Dim objShell, strComputer, objReg, strKeyRoot, strKeyPath, arrVersions, Version, return
Dim strUsernameInBinary, strUserInitialsInBinary

Const HKEY_CURRENT_USER = &H80000001
strComputer = "."

arrVersions = Array("10.0","11.0","12.0")
' Note that...
' - Office 2000 = 9.0
' - Office XP/2002 = 10.0
' - Office 2003 = 11.0
' - Office 2007 = 12.0

Set objShell = WScript.CreateObject("WScript.Shell")
Set objWSHNetwork = WScript.CreateObject("WScript.Network")
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
  strComputer & "\root\default:StdRegProv")

strUsername = objWSHNetwork.UserName
If instr(strUsername, ".") > 0 Then
  strTemp = Split(strUsername, ".")
  strUserInitials = ucase(Left(strTemp(0), 1)) & ucase(Left(strTemp(1), 1))
Else
  strUserInitials = ucase(Left(strUsername, 2))
End If

If IsArray(arrVersions) Then
  For Each Version in arrVersions
    strKeyRoot = "HKCU\"
    strKeyPath = "Software\Microsoft\Office\"

    If Version = "9.0" OR Version = "10.0" OR Version = "11.0" Then

      strKeyPath = "Software\Microsoft\Office\" & Version

      If RegKeyExists(strKeyRoot & strKeyPath) Then

        If NOT RegKeyExists(strKeyRoot & strKeyPath & "\Common") Then
          return = objReg.CreateKey (HKEY_CURRENT_USER, strKeyPath & "\Common")
        End If
        If NOT RegKeyExists(strKeyRoot & strKeyPath & "\Common\UserInfo") Then
          return = objReg.CreateKey (HKEY_CURRENT_USER, strKeyPath & "\Common\UserInfo")
        End If

        strKeyPath = strKeyPath & "\Common\UserInfo"

        strUsernameInBinary = ConvertStringToBinary(strUsername)
        objReg.SetBinaryValue HKEY_CURRENT_USER, strKeyPath, "UserName", strUsernameInBinary

        strUserInitialsInBinary = ConvertStringToBinary(strUserInitials)
        objReg.SetBinaryValue HKEY_CURRENT_USER, strKeyPath, "UserInitials", strUserInitialsInBinary

      End If

    Else

      If RegKeyExists(strKeyRoot & strKeyPath & Version) Then

        If NOT RegKeyExists(strKeyRoot & strKeyPath & "\Common") Then
          return = objReg.CreateKey (HKEY_CURRENT_USER, strKeyPath & "\Common")
        End If
        If NOT RegKeyExists(strKeyRoot & strKeyPath & "\Common\UserInfo") Then
          return = objReg.CreateKey (HKEY_CURRENT_USER, strKeyPath & "\Common\UserInfo")
        End If

        strKeyPath = strKeyPath & "\Common\UserInfo"

        objReg.SetStringValue HKEY_CURRENT_USER, strKeyPath, "UserName", strUsername
        objReg.SetStringValue HKEY_CURRENT_USER, strKeyPath, "UserInitials", strUserInitials

      End If
    End If
  Next
End If

Set objWSHNetwork = Nothing
Set objShell = Nothing
Set objReg = Nothing

wscript.quit(0)

Function ConvertStringToBinary(strString)
  ReDim arrBinaryValue(len(strString) * 2 + 1)
  For intNumberOfChars = 0 To Len(strString) - 1
    If intNumberOfChars = 0 Then
      arrBinaryValue(0) = Asc(Mid(strString, intNumberOfChars + 1, 1))
      arrBinaryValue(1) = 0
    Else
      arrBinaryValue(intNumberOfChars * 2) = Asc(Mid(strString, intNumberOfChars + 1, 1))
      arrBinaryValue(intNumberOfChars * 2 + 1) = 0
    End If
  Next
  arrBinaryValue(Len(strString) * 2) = 0
  arrBinaryValue(Len(strString) * 2 + 1) = 0
  ConvertStringToBinary = arrBinaryValue
End Function

Function RegKeyExists(ByVal sRegKey)
' Returns True or False based on the existence of a registry key.
  Dim sDescription, oShell
  Set oShell = CreateObject("WScript.Shell")
  RegKeyExists = True
  sRegKey = Trim (sRegKey)
  If Not Right(sRegKey, 1) = "\" Then
    sRegKey = sRegKey & "\"
  End If
  On Error Resume Next
  oShell.RegRead "HKEYNotAKey\"
  sDescription = Replace(Err.Description, "HKEYNotAKey\", "")
  Err.Clear
  oShell.RegRead sRegKey
  RegKeyExists = sDescription <> Replace(Err.Description, sRegKey, "")
  On Error Goto 0
  Set oShell = Nothing
End Function