Серый форум — VBScript: Формирование ФИО в авторе Office 2003 из AD

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

null@example.com (alexii) — Sun, 17 Apr 2011 10:51:16 +0000

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 не используется в качестве разделителя между символами, Вы путаете. У латинских символов в юникоде старшее слово равно нулю.

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

null@example.com (TAOSoft) — Sat, 16 Apr 2011 20:00:42 +0000

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

Подскажите пожалуйста, как получить значение параметра реестра (тип 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

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

null@example.com (a154802) — Tue, 01 Feb 2011 07:38:01 +0000

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

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

null@example.com (alexii) — Tue, 01 Feb 2011 07:29:32 +0000

Кажись, теперь начинаю припоминать , зачем в #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

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

null@example.com (a154802) — Tue, 01 Feb 2011 02:04:53 +0000

alexii пишет:

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

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

a154802 пишет:

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

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

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

null@example.com (alexii) — Mon, 31 Jan 2011 19:36:09 +0000

a154802 пишет:

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

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

a154802 пишет:

alexii пишет:
a154802 пишет:
Появилась проблемка, при конвертации получается правильная последовательность, но либо не хватает окончания, либо обрузаются последние знаки кодировки.
Приведите подробный пример.
Исправляется если добавить в раздел реестра необходимые 00 00 , тогда ошибок нету.

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

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

null@example.com (a154802) — Mon, 31 Jan 2011 17:00:51 +0000

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

OFF

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

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

null@example.com (alexii) — Mon, 31 Jan 2011 08:56:30 +0000

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. Какой-то очень странный метод получения имени Вы выбрали.

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

null@example.com (a154802) — Mon, 31 Jan 2011 06:16:33 +0000

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

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

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

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

null@example.com (alexii) — Sun, 30 Jan 2011 18:12:40 +0000

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

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

null@example.com (a154802) — Sun, 30 Jan 2011 16:49:39 +0000

alexii пишет:

a154802 пишет:
Добавить универсальность, что бы данная функция выполняла много разных обработок, а не для каждого значения свой обработчик городить.
Вы про это, что ли?!
…

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

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

null@example.com (alexii) — Sun, 30 Jan 2011 16:31:06 +0000

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. Без каких-либо проверок.

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

null@example.com (a154802) — Sun, 30 Jan 2011 15:05:42 +0000

Конечная цель:
Сделать его как обработчик, что бы можно было указать, к примеру, 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.

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

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

null@example.com (alexii) — Sun, 30 Jan 2011 14:40:10 +0000

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

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

null@example.com (a154802) — Sun, 30 Jan 2011 10:10:58 +0000

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

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

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

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