Изменение имени пользователя, логина, pop3 user, адреса почты в Outlook через скрипт vbs.

Вот понадобилось в связи со сменой домена. Наваял такой вот скриптик.

Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const KEY_QUERY_VALUE = &H0001
const KEY_SET_VALUE = &H0002
const KEY_CREATE_SUB_KEY = &H0004
Const DELETE = &H00010000
Const ORIGINAL_DOMAIN = "olddomain.ru"
Const NEW_DOMAIN = "newdomain.ru"
'Const ORIGINAL_DOMAIN = "olddomain.ru"
'Const NEW_DOMAIN = "newdomain.ru"

strComputer = "."
Set oWSnetwork = WScript.CreateObject("WScript.Network")
Set oWMI = GetObject("winmgmts://" & strComputer & "\root\cimv2")
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
strKeyPath2 = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\"
getrightaccount(strKeyPath2)



Function HexStringToAsciiString(HexStr)
For i = 1 To Int(Len(HexStr)/3)+1
str1 = str1 & Chr("&H" & Mid(HexStr,3*i-2,2))
Next
HexStringToAsciiString=str1
End Function

Function StingToHexString(AString)
max = len(AString)
For intLoop = 1 to max step 1
asciiName = asc(mid(AString, intLoop, 1))
if newAsciiName = "" and newAsciiInitials = "" Then
newAsciiName = asciiName
Else
newAsciiName = newAsciiName & "," & "00" & "," & asciiName
end If
If intLoop <= 2 then
newAsciiInitials = newAsciiName & "," & "00"
End If
Next
updateName = Split(newAsciiName,",")
StingToHexString=updateName
End Function

Function getrightaccount(strKeyPath3)
If oReg.EnumKey(HKEY_CURRENT_USER, strKeyPath3, arrSubKeys) = 0 Then
If IsArray(arrSubKeys) Then
For Each subkey In arrSubKeys
If oReg.EnumKey(HKEY_CURRENT_USER, strKeyPath3 & "\" & subkey, arrSubKeys2) = 0 Then
If IsArray(arrSubKeys2) then
For Each subkey2 In arrSubKeys2
If oReg.EnumValues(HKEY_CURRENT_USER, strKeyPath3 & "\" & subkey & "\" & subkey2, arrSubNames, arrSubTypes) = 0 Then
If IsArray(arrSubNames) Then
For Each subkey3 In arrSubNames
If lcase(subkey3) = "email" then
startrenaming(strKeyPath3 & "\" & subkey & "\" & subkey2)
End If
Next
End If
End if
Next
End If
End If
Next
End if
Else
WScript.Echo "failed"
End If
End Function

Function startrenaming(Bstring)
strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\00000001"
If oReg.GetBinaryValue (HKEY_CURRENT_USER,Bstring,"Email",binValue) = 0 Then
For i = LBound(binValue) to UBound (binValue)
strEmail = strEmail & Right("" & Hex(binValue(i)),2) & " "
Next
If 1=1 Then
ast = Replace(Lcase(HexStringToAsciiString(Replace(strEmail," 0 "," "))),ORIGINAL_DOMAIN,NEW_DOMAIN)
ast2 = oReg.SetBinaryValue(HKEY_CURRENT_USER,Bstring,"Email",StingToHexString(ast))
End If
Else
WScript.Echo "failed"
End If

If oReg.GetBinaryValue (HKEY_CURRENT_USER,Bstring,"POP3 User",binValue) = 0 Then
For i = LBound(binValue) to UBound (binValue)
struser = struser & Right("" & Hex(binValue(i)),2) & " "
Next
If 1=1 Then
ast = Replace(Lcase(HexStringToAsciiString(Replace(struser," 0 "," "))),ORIGINAL_DOMAIN,NEW_DOMAIN)
ast2 = oReg.SetBinaryValue(HKEY_CURRENT_USER,Bstring,"POP3 User",StingToHexString(ast))
End If
Else
WScript.Echo "failed"
End If

End Function