1 Тема от abasov

  • abasov
  • Разработчик
  • Неактивен

Тема: VBScript: Формирование ФИО в авторе Office 2003 из AD

Исправляет некорректное имя автора в Office 2003 на ФИО (displayName) из AD.
Собственно баг в кодировке при добавлении в реестр. Коллеги как исправить?

Set fs = CreateObject("Scripting.FileSystemObject")
set WshShell = WScript.CreateObject("WScript.Shell")
' get UserName
strName = WshShell.ExpandEnvironmentStrings("%USERNAME%")

On Error Resume Next

' Constants for the NameTranslate object.
Const ADS_NAME_INITTYPE_DOMAIN = 1
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1179 = 1

Set objNetwork = CreateObject("Wscript.Network")

' Determine DNS domain name from RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
If Err.Number <> 0 Then
    Wscript.Quit
End If
strDNSDomain = objRootDSE.Get("defaultNamingContext")

' Use the NameTranslate object to find the NetBIOS domain name from the
' DNS domain name.
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_TYPE_NT4, strDNSDomain
objTrans.Set ADS_NAME_TYPE_1179, strDNSDomain
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
' Remove trailing backslash.
strNetBIOSDomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1)

' Use the NameTranslate object to convert the NT user name to the
' Distinguished Name required for the LDAP provider.
objTrans.Init ADS_NAME_INITTYPE_DOMAIN, strNetBIOSDomain
objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "\" & strName 
strUserDN = objTrans.Get(ADS_NAME_TYPE_1179)

' Bind to the user object in Active Directory with the LDAP provider.
Set objUser = GetObject("LDAP://" & strUserDN)

'Get Common name
strUsername=objUser.Get("displayName") & ", " & objUser.Get("telephoneNumber")
'strUsername= objUser.cn
'WScript.Echo strUsername
'Convert Initials to HEX
For i = 1 to Len(strName)
 strInitialsHex = strInitialsHex & "," & Hex(Asc(Mid(strName, i, 1))) & ",00"
Next
strInitialsHex = Right(strInitialsHex , Len(strInitialsHex ) -1)
strInitialsHex = strInitialsHex & ",00,00"

'Convert Username to HEX
For i = 1 to Len(strUsername)
 strUsernameHex = strUsernameHex & "," & Hex(Asc(Mid(strUsername, i, 1))) & ",00"
Next
strUsernameHex = Right(strUsernameHex, Len(strUsernameHex) -1)
strUsernameHex = strUsernameHex & ",00,00"

' Create temporary registry file
Const OverwriteIfExist = -1
Const FailIfExist      = 0
Const OpenAsASCII   =  0
Const OpenAsUnicode = -1
Const OpenAsDefault    = -2
sTmpFile = WshShell.ExpandEnvironmentStrings("%TEMP%") & "\UserInfo.reg"
Set fFile = fs.CreateTextFile(sTmpFile, OverwriteIfExist, OpenAsASCII)


' Write to the temporary registry file
fFile.WriteLine "Windows Registry Editor Version 5.00"
fFile.WriteLine
fFile.WriteLine "[HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\UserInfo]"
fFile.WriteLine """UserName""=hex:" & strUsernameHex
fFile.WriteLine """UserInitials""=hex:" & strInitialsHex 
fFile.Close

' Import the registry file
WshShell.Run "regedit /s " & sTmpFile, 0, True

' Delete the temporary registry file
fs.DeleteFile sTmpFile

2 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Я бы предложил иной вариант. После

'Get Common name
strUsername=objUser.Get("displayName") & ", " & objUser.Get("telephoneNumber")

вместо остального сделать так:

Const HKEY_CURRENT_USER = &H80000001
Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")

strUsername = strUsername & Chr(0)
ReDim arrValues(LenB(strUsername) - 1)

For i = 1 To Len(strUsername)
    intDValue      = AscW(Mid(strUsername, i, 1))
    intBigValue    = intDValue \ &HFF
    intLittleValue = (intDValue - intBigValue) Mod &HFF
    
    arrValues(i * 2 - 2) = intLittleValue
    arrValues(i * 2 - 1) = intBigValue
Next

errReturn = objRegistry.SetBinaryValue _
    (HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Common\UserInfo", "UserName", arrValues)

Set objRegistry = Nothing

Здесь в реестр пишется только в UserName, насчёт UserInitials можно сделать по аналогии.

3 Ответ от abasov

  • abasov
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

alexii пишет:

Я бы предложил иной вариант. . .

Вариант рабочий, благодарю, только не пойму почему в старом варианте ломалась кодировка?

4 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

А шут его знает. Я поглядел Ваш скрипт, запустил его, посмотрел, что кодировка не та, поглядел скрипт ещё раз, дошёл до конвертирования, завяз в разборе, увидел промежуточный файл реестра, подумал, а можно ли напрямую, начал пробовать, ещё пробовать, потом ещё немного, пока не получилось.

5 Ответ от a154802 (изменено: a154802, 2011-01-30 14:12:35)

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Прошу помочь.

Как из вышеукащанного преобразования сделать массив функции?

Если правильно понял, то конвертация происходит только здесь:

strUsername = strUsername & Chr(0)
ReDim arrValues(LenB(strUsername) - 1)

For i = 1 To Len(strUsername)
    intDValue      = AscW(Mid(strUsername, i, 1))
    intBigValue    = intDValue \ &HFF
    intLittleValue = (intDValue - intBigValue) Mod &HFF
    
    arrValues(i * 2 - 2) = intLittleValue
    arrValues(i * 2 - 1) = intBigValue
Next

Пытаюсь преобразовать в вид:

function arrBinary( sString)
dim s, i
s = ""
for i = 1 to len( sString)
s = s & "," & asc(mid( sString, i, 1)) & "," & "00"
next
arrBinary = split( mid( s & ",00,00", 2), ",")
end function

Пытаюсь видоизменить этот скрипт: http://forum.tsure.ru/index.php?showtopic=50459

Декомпилятор для Java, C# и Python

6 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

a154802, Ваш вопрос не понятен. Укажите конечную цель.

7 Ответ от a154802 (изменено: a154802, 2011-01-30 19:32:58)

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Конечная цель:
Сделать его как обработчик, что бы можно было указать, к примеру, arrBinary( sCompany) и выполнилось преобразование данных sCompany и получить обработанные данные.
Добавить универсальность, что бы данная функция выполняла много разных обработок, а не для каждого значения свой обработчик городить.

P.S.
На основе Ваших замечаний и исходниками abasov, модифицировал для себя, но преобразование в бинарный вид происходит 2 раза, для strUsername и strCompany, а так можно было бы обойтись одним, заменяя нужные переменные "на лету".

Set fs = CreateObject("Scripting.FileSystemObject") 
set WshShell = WScript.CreateObject("WScript.Shell") 
' get UserName 
strName = WshShell.ExpandEnvironmentStrings("%USERNAME%") 

On Error Resume Next 

' Constants for the NameTranslate object. 
Const ADS_NAME_INITTYPE_DOMAIN = 1 
Const ADS_NAME_TYPE_NT4 = 3 
Const ADS_NAME_TYPE_1179 = 1 

Set objNetwork = CreateObject("Wscript.Network") 

' Determine DNS domain name from RootDSE object. 
Set objRootDSE = GetObject("LDAP://RootDSE") 
If Err.Number <> 0 Then 
Wscript.Quit 
End If 
strDNSDomain = objRootDSE.Get("defaultNamingContext") 

' Use the NameTranslate object to find the NetBIOS domain name from the 
' DNS domain name. 
Set objTrans = CreateObject("NameTranslate") 
objTrans.Init ADS_NAME_TYPE_NT4, strDNSDomain 
objTrans.Set ADS_NAME_TYPE_1179, strDNSDomain 
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4) 
' Remove trailing backslash. 
strNetBIOSDomain = Left(strNetBIOSDomain, Len(strNetBIOSDomain) - 1) 

' Use the NameTranslate object to convert the NT user name to the 
' Distinguished Name required for the LDAP provider. 
objTrans.Init ADS_NAME_INITTYPE_DOMAIN, strNetBIOSDomain 
objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "\" & strName 
strUserDN = objTrans.Get(ADS_NAME_TYPE_1179) 

' Bind to the user object in Active Directory with the LDAP provider. 
Set objUser = GetObject("LDAP://" & strUserDN) 

'Get Common name 
strUsername=objUser.Get("displayName") ' & ", " & objUser.Get("telephoneNumber") 
'strUsername= objUser.cn 

'Имя организации
strCompany = "Название организации"

'WScript.Echo strUsername 
'Convert Initials to HEX 
Const HKEY_CURRENT_USER = &H80000001 
Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv") 

'----------------
strUsername = strUsername & Chr(0) 
ReDim arrValues(LenB(strUsername) - 1) 

For i = 1 To Len(strUsername) 
intDValue = AscW(Mid(strUsername, i, 1)) 
intBigValue = intDValue \ &HFF 
intLittleValue = (intDValue - intBigValue) Mod &HFF 

arrValues(i * 2 - 2) = intLittleValue 
arrValues(i * 2 - 1) = intBigValue 
Next 

'----------------
strCompany = strCompany & Chr(0) 
ReDim arrCompany(LenB(strCompany) - 1) 

For i = 1 To Len(strCompany) 
intDValue = AscW(Mid(strCompany, i, 1)) 
intBigValue = intDValue \ &HFF 
intLittleValue = (intDValue - intBigValue) Mod &HFF 

arrCompany(i * 2 - 2) = intLittleValue 
arrCompany(i * 2 - 1) = intBigValue 
Next 

'------------------

'--------for MS Office 2003-----------------------------------
errReturn = objRegistry.SetBinaryValue (HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Common\UserInfo", "UserName", arrValues) 
errReturn = objRegistry.SetBinaryValue (HKEY_CURRENT_USER, "Software\Microsoft\Office\11.0\Common\UserInfo", "Company", arrCompany) 


'--------for MS Office 2007-----------------------------------
errReturn = objRegistry.SetStringValue (HKEY_CURRENT_USER, "Software\Microsoft\Office\Common\UserInfo", "UserName", strUsername) 
errReturn = objRegistry.SetStringValue (HKEY_CURRENT_USER, "Software\Microsoft\Office\Common\UserInfo", "Company", strCompany)
errReturn = objRegistry.SetStringValue (HKEY_CURRENT_USER, "Software\Microsoft\Office\Common\UserInfo", "CompanyName", strCompany) 
'errReturn = objRegistry.SetStringValue (HKEY_CURRENT_USER, "Software\Microsoft\Office\Common\UserInfo", "UserInitials", strInitial) 



Set objRegistry = Nothing

P.P.S.

Не совсем разобрался как сделать инициалы с разделением в виде точек.

Декомпилятор для Java, C# и Python

8 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

a154802 пишет:

Добавить универсальность, что бы данная функция выполняла много разных обработок, а не для каждого значения свой обработчик городить.

Вы про это, что ли?!

Function Str2HexArray(strValue)
    ReDim arrValues(LenB(strValue) - 1)
    
    Dim i
    Dim intDValue
    Dim intBigValue, intLittleValue
    
    For i = 1 To Len(strValue)
        intDValue      = AscW(Mid(strValue, i, 1))
        intBigValue    = intDValue \ &HFF
        intLittleValue = (intDValue - intBigValue) Mod &HFF
        
        arrValues(i * 2 - 2) = intLittleValue
        arrValues(i * 2 - 1) = intBigValue
    Next
    
    Str2HexArray = arrValues
End Function

P.S. Без каких-либо проверок.

9 Ответ от a154802

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

alexii пишет:
a154802 пишет:

Добавить универсальность, что бы данная функция выполняла много разных обработок, а не для каждого значения свой обработчик городить.

Вы про это, что ли?!
…

Спасибо!
То, что нужно

Декомпилятор для Java, C# и Python

10 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

a154802, избегайте излишнего цитирования. Я поправил Ваш предыдущий пост.

11 Ответ от a154802 (изменено: a154802, 2011-01-31 10:18:07)

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Прошу прощения за цитирование.

А можно как-то добавить проверку (хотя не знаю, нужна она или нет).
Появилась проблемка, при конвертации получается правильная последовательность, но либо не хватает окончания, либо обрузаются последние знаки кодировки.

On Error Resume Next

'-------------------------------------
'Функция перевода строки в бинарный массив
'-------------------------------------

Function Str2HexArray(strValue) 

    ReDim arrValues(LenB(strValue) - 1)
    
    Dim d
    Dim intDValue
    Dim intBigValue, intLittleValue

    For d = 1 To Len(strValue)
        intDValue      = AscW(Mid(strValue, d, 1))
        intBigValue    = intDValue \ &HFF
        intLittleValue = (intDValue - intBigValue) Mod &HFF
        
        arrValues(d * 2 - 2) = intLittleValue
        arrValues(d * 2 - 1) = intBigValue
    Next
        Str2HexArray = arrValues
End Function


'-------------------------------------
'Функция записи в реестр
'-------------------------------------
function SetRegistration( sUserName, sUserInitials, sCompany) 
const HKCU = &H80000001

dim oReg
set oReg = getobject("winMgmts:\\.\root\default:StdRegProv")
dim sKey

'--------for MS Office 2003-----------------------------------
sKey = "Software\Microsoft\Office\11.0\Common\UserInfo"

oReg.SetBinaryValue HKCU, sKey, "UserName" , Str2HexArray( sUserName)
oReg.SetBinaryValue HKCU, sKey, "UserInitials" , Str2HexArray( sUserInitials)
oReg.SetBinaryValue HKCU, sKey, "Company" , Str2HexArray( sCompany)

oReg.SetDWORDValue HKCU, "Software\Microsoft\Office\11.0\MS Project\Options\General", "Is User Name Set", 0

'--------for MS Office 2007-----------------------------------
sKey = "Software\Microsoft\Office\Common\UserInfo"

oReg.SetStringValue HKCU, sKey, "UserName" , sUserName
oReg.SetStringValue HKCU, sKey, "UserInitials" , sUserInitials
oReg.SetStringValue HKCU, sKey, "Company" , sCompany
oReg.SetStringValue HKCU, sKey, "CompanyName" , sCompany

oReg.SetBinaryValue HKCU, "Software\Microsoft\Office\12.0\Common\UserInfo", "Company", Str2HexArray( sCompany)
oReg.SetDWORDValue HKCU, "Software\Microsoft\Office\12.0\MS Project\Options\General", "Is User Name Set", 0
end function 

'инициализация переменных
'-------------------------------------
'имя компьютера
strComputer = "."

'Имя организации
strCompany = "Название организации"

'Инициалы пользователя
strUserInitials = ""

'имя пользователя
strUserName = ""


'-------------------------------------
'получение данных пользователя
'-------------------------------------
'set WSHShell = WScript.CreateObject("WScript.Shell")
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")  
Set colComputer = objWMIService.ExecQuery("Select * from Win32_NetworkLoginProfile where FullName is not null",,48)
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv") 

For Each objComputer in colComputer
strUserName = objComputer.FullName
strUserInitials = objComputer.FullName 

Next 
strArray = Split(strUserInitials, " ", 3) 
For i = 0 To Ubound(strArray) 
    If i = 0 Then 
        strUserInitials = Left(strArray(i), 1) & "." 
    Else 
        strUserInitials = strUserInitials & Left(strArray(i), 1) & "." 
    End If 
Next 


SetRegistration strUserName, strUserInitials, strCompany
Декомпилятор для Java, C# и Python

12 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

a154802 пишет:

А можно как-то добавить проверку (хотя не знаю, нужна она или нет).

Ну, если вдруг надумаете передавать в функцию пустую строку или вовсе не строку — то можно.

a154802 пишет:

Появилась проблемка, при конвертации получается правильная последовательность, но либо не хватает окончания, либо обрузаются последние знаки кодировки.

Приведите подробный пример.

OFF:

Win32_NetworkLoginProfile class пишет:

Remarks
…
The calling process that uses this class must have the SE_RESTORE_NAME privilege on the computer in which the registry resides.
…

…{impersonationLevel=impersonate,(Restore)}…

Или сие специально было убрано, чтобы только текущего получить?

P.S. Какой-то очень странный метод получения имени Вы выбрали.

13 Ответ от a154802 (изменено: a154802, 2011-01-31 22:06:25)

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Не, тогда проверка точно не нужна, т.к. всегда используются только буквы или цифры.
Исправляется если добавить к полученным значениям необходимые 00 00 в конце, тогда ошибок нету.

http://teranyu.homeip.net/temp/vbs/error.PNG

OFF

Мне нужно получить только текущее имя пользователя, взятое из домена.

Декомпилятор для Java, C# и Python

14 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

a154802 пишет:

Мне нужно получить только текущее имя пользователя, взятое из домена.

Выберете отсюда подходящее Вам. И вообще посмотреть поиском по форуму по ключевому слову «ADSystemInfo».

a154802 пишет:
alexii пишет:
a154802 пишет:

Появилась проблемка, при конвертации получается правильная последовательность, но либо не хватает окончания, либо обрузаются последние знаки кодировки.

Приведите подробный пример.

Исправляется если добавить в раздел реестра необходимые 00 00 , тогда ошибок нету.

Меня интересовали исходные данные и пример, позволяющий воспроизвести то, что получается у Вас. Ну, ладно, коль Вы уже как-то решили — теперь не важно.

15 Ответ от a154802 (изменено: a154802, 2011-02-01 10:10:24)

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

alexii пишет:

Выберете отсюда подходящее Вам. И вообще посмотреть поиском по форуму по ключевому слову «ADSystemInfo».

Спасибо, анализирую данные

a154802 пишет:

Меня интересовали исходные данные и пример, позволяющий воспроизвести то, что получается у Вас. Ну, ладно, коль Вы уже как-то решили — теперь не важно.

Исходные данные ФИО пользователя из домена: Фамилия Имя Отчество.
Я так понял что получившийся массив либо не дописывает преобразования до конца, либо в Ms Office требуется ограничивать конец строки пустым символом.
Нет, я так и не решил данную проблему, при попытке выяснить причину обнаружил что строки должны заканчиваться с двумя пустыми знаками, т.е. иметь код 00 00.
По аналогии с исходным скриптом, который я выкладывал, добавить недостоющие знаки не получается, прошу помочь
Т.е. надо обязательно дописывать на выход преобразования "00,00"

Декомпилятор для Java, C# и Python

16 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Кажись, теперь начинаю припоминать , зачем в #2 было:

strUsername = strUsername & Chr(0)

Попробуйте добавить в функцию из #8 сие первой строкой, наподобие:

Function Str2HexArray(strValue)
    strValue = strValue & Chr(0)
    
    ReDim arrValues(LenB(strValue) - 1)
    
    Dim i
    Dim intDValue
    Dim intBigValue, intLittleValue
    
    For i = 1 To Len(strValue)
        intDValue      = AscW(Mid(strValue, i, 1))
        intBigValue    = intDValue \ &HFF
        intLittleValue = (intDValue - intBigValue) Mod &HFF
        
        arrValues(i * 2 - 2) = intLittleValue
        arrValues(i * 2 - 1) = intBigValue
    Next
    
    Str2HexArray = arrValues
End Function

17 Ответ от a154802 (изменено: a154802, 2011-02-01 18:15:32)

  • a154802
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

alexii пишет:

Кажись, теперь начинаю припоминать , зачем в #2 было:

strValue = strValue & Chr(0)

Спасибо, заработало

Тоже пытался это куда-нибудь засунуть, но не работало


Вот конечный вариант:

On Error Resume Next

'-------------------------------------
'Функция перевода строки в бинарный массив
'-------------------------------------

Function Str2HexArray(strValue) 
        strValue = strValue & Chr(0)
        
    ReDim arrValues(LenB(strValue) - 1)
    
    Dim d
    Dim intDValue
    Dim intBigValue, intLittleValue

    For d = 1 To Len(strValue)
        intDValue      = AscW(Mid(strValue, d, 1))
        intBigValue    = intDValue \ &HFF
        intLittleValue = (intDValue - intBigValue) Mod &HFF
        
        arrValues(d * 2 - 2) = intLittleValue
        arrValues(d * 2 - 1) = intBigValue
    Next
    
        Str2HexArray = arrValues
End Function

'-------------------------------------
'Функция записи в реестр
'-------------------------------------
function SetRegistration( sUserName, sUserInitials, sCompany) 
const HKCU = &H80000001

dim oReg
set oReg = getobject("winMgmts:\\.\root\default:StdRegProv")
dim sKey

'-------- Для MS Office 2000 -----------------------------------
sKey = "Software\Microsoft\Office\9.0\Common\UserInfo"

oReg.SetBinaryValue HKCU, sKey, "UserName" , Str2HexArray( sUserName)
oReg.SetBinaryValue HKCU, sKey, "UserInitials" , Str2HexArray( sUserInitials)
oReg.SetBinaryValue HKCU, sKey, "Company" , Str2HexArray( sCompany)

oReg.SetDWORDValue HKCU, "Software\Microsoft\Office\9.0\MS Project\Options\General", "Is User Name Set", 0

'-------- Для MS Office 2003 -----------------------------------
sKey = "Software\Microsoft\Office\11.0\Common\UserInfo"

oReg.SetBinaryValue HKCU, sKey, "UserName" , Str2HexArray( sUserName)
oReg.SetBinaryValue HKCU, sKey, "UserInitials" , Str2HexArray( sUserInitials)
oReg.SetBinaryValue HKCU, sKey, "Company" , Str2HexArray( sCompany)

oReg.SetDWORDValue HKCU, "Software\Microsoft\Office\11.0\MS Project\Options\General", "Is User Name Set", 0

'-------- Для MS Office 2007, 2010 -----------------------------
sKey = "Software\Microsoft\Office\Common\UserInfo"

oReg.SetStringValue HKCU, sKey, "UserName" , sUserName
oReg.SetStringValue HKCU, sKey, "UserInitials" , sUserInitials
oReg.SetStringValue HKCU, sKey, "Company" , sCompany
oReg.SetStringValue HKCU, sKey, "CompanyName" , sCompany

oReg.SetBinaryValue HKCU, "Software\Microsoft\Office\12.0\Common\UserInfo", "Company", Str2HexArray( sCompany)
oReg.SetDWORDValue HKCU, "Software\Microsoft\Office\12.0\MS Project\Options\General", "Is User Name Set", 0
end function 

'инициализация переменных
'-------------------------------------
'имя компьютера
strComputer = "."

'Имя организации
strCompany = "Название организации"

'Инициалы пользователя
strUserInitials = ""

'имя пользователя
strUserName = ""

'-------------------------------------
'получение данных пользователя
'-------------------------------------
Set objADSystemInfo = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objADSystemInfo.UserName)

strUserName = objUser.displayName
strUserInitials = objUser.displayName 

'------- Выделение инициалов --------------
strArray = Split(strUserInitials, " ", 3) 
For i = 0 To Ubound(strArray) 
    If i = 0 Then 
        strUserInitials = Left(strArray(i), 1) & "." 
    Else 
        strUserInitials = strUserInitials & Left(strArray(i), 1) & "." 
    End If 
Next 

'----------- Регистрация переменных -----------------
SetRegistration strUserName, strUserInitials, strCompany
Декомпилятор для Java, C# и Python

18 Ответ от TAOSoft

  • TAOSoft
  • Участник
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

Доброго времени суток уважаемые!

Подскажите пожалуйста, как получить значение параметра реестра (тип REG_BINARY). Т.е. после выполнения скрипта из 17 поста (при strUserName = "Иванов") в реестре параметр UserName принимает значение 18,04,32,04,30,04,3d,04,3e,04,32,04,00,00, если прочитать это значение через GetBinaryValue, получаю "кракозябры", а я хочу видеть Иванов. Подскажите, в какую сторону копать. Может быть, у кого есть готовое решение. Заранее благодарен

const HKEY_CURRENT_USER = &H80000001
 
'подключение к реестру 
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") 
If Err.Number <> 0 Then 
  WScript.Echo Err.Number & ": " & Err.Description 
  WScript.Quit 
End If 
' путь к разделу  
path = "Software\Microsoft\Office\11.0\Common\UserInfo" 
' параметр который нужно прочетать 
Param = "UserName"  
' чтение параметра 
intRes = ObjReg.GetBinaryValue(HKEY_CURRENT_USER, Path, Param, Value) 
If intRes <> 0 Then 
  strErr = StrErr & intRes & ": не удалась прочитать значение параметра ""HKEY_CURRENT_USER\"  & Path & "\" & Param & """" 
Else 
  For i = lBound(value) To UBound(Value) 
    'проверка т.к обычно 0 используется как разделитель между символами 
    If value(i) <> 0 Then 
      Temp = Temp & Chr(Value(i))
    End If 
  Next 
Wscript.Echo Temp
End If

19 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: Формирование ФИО в авторе Office 2003 из AD

TAOSoft, воспользуйтесь обратной функцией преобразования, наподобие:

Option Explicit

Const HKEY_CURRENT_USER = &H80000001

Dim objSWbemServicesEx
Dim objSWbemObjectEx

Dim arrValues


Set objSWbemServicesEx = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default")
Set objSWbemObjectEx   = objSWbemServicesEx.Get("StdRegProv")

If objSWbemObjectEx.GetBinaryValue(HKEY_CURRENT_USER, _
    "Software\Microsoft\Office\11.0\Common\UserInfo", "UserName", arrValues) = 0 Then
    
    WScript.Echo HexArray2Str(arrValues)
Else
    WScript.Echo "Error reading registry"
End If

Set objSWbemObjectEx   = Nothing
Set objSWbemServicesEx = Nothing

WScript.Quit 0
'=============================================================================

'=============================================================================
Function HexArray2Str(arrValues)
    Dim strValue
    Dim i
    Dim intDValue
    Dim intBigValue, intLittleValue
    
    
    strValue = ""
    
    For i = LBound(arrValues) To UBound(arrValues) Step 2
        intLittleValue = arrValues(i)
        intBigValue    = arrValues(i + 1)
        intDValue      = intBigValue * &H100 + intLittleValue
        
        strValue       = strValue & ChrW(intDValue)
    Next
    
    HexArray2Str = Left(strValue, Len(strValue) - 1)
End Function
'=============================================================================
TAOSoft пишет:

'проверка т.к обычно 0 используется как разделитель между символами

0 не используется в качестве разделителя между символами, Вы путаете. У латинских символов в юникоде старшее слово равно нулю.