4/5 (1 avis)
Snippet vu 20 697 fois - Téléchargée 29 fois
'office.vbs version 2.00 ' 'script de modification du nom enregistré dans office par le nom de login windows de l'utilisateur 'Vérification de la version office installée 'modification par supresssion et modification de la clef registre "HKCU\Software\Microsoft\Office\x.0\Common\UserInfo\UserName" 'traces des modifications effectuées dans le fichier office.log situé sous \\serveur\partage On error resume next 'déclaration des variables Dim wscr, WshShell, tempread, key, valhex Dim refRegistry, arrValueData, strValueData, strSKPath, strValueName, i Dim oFSys, Filelog Dim sResult, sNomOffice, sOfficeVer, sVersionOffice 'déclaration des objets Set wscr = CreateObject("wscript.shell") Set netw = CreateObject("WScript.Network") Set objWord = CreateObject("Word.Application") Set oFSys = CreateObject("Scripting.FileSystemObject") Set WshShell = WScript.CreateObject("WScript.Shell") 'déclaration constante Const HKEY_CURRENT_USER = &H80000001 Const strComputer = "." sRegHKCU="HKCU\" sregHKLM="HKLM\" sRegCommun="SOFTWARE\Microsoft\Office\" sregPost1="\Common\UserInfo" sRegPost = "\Common\InstallRoot\" strValueName = "UserName" 'HKLM\SOFTWARE\Microsoft\Office\11.0\Common\InstallRoot ' Office 2003 'HKLM\SOFTWARE\Microsoft\Office\10.0\Common\InstallRoot ' Office 2002 (XP) 'HKLM\SOFTWARE\Microsoft\Office\9.0\Common\InstallRoot ' Office 2000 'HKLM\SOFTWARE\Microsoft\Office\8.0\Common\InstallRoot ' Office 97 Function GetOfficeVer() Select Case True Case RegKeyExists(sRegPre & "11.0" & sRegPost) sOfficeVer = "11.0" sVersionOffice = "Office 2003" Case RegKeyExists(sRegPre & "10.0" & sRegPost) sOfficeVer = "10.0" sVersionOffice = "Office 2002" Case RegKeyExists(sRegPre & "9.0" & sRegPost) sOfficeVer = "9.0" sVersionOffice = "Office 2000" Case RegKeyExists(sRegPre & "8.0" & sRegPost) sOfficeVer = "8.0" sVersionOffice = "Office 97" Case Else sOfficeVer = "pas d'office" sVersionOffice = "pas d'office" End Select GetOfficeVer= sOfficeVer 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 End Function 'declaration des chaines clef de registre sRegPre = sregHKLM & sRegCommun ' "HKLM\SOFTWARE\Microsoft\Office\" strSKPath = sRegCommun & GetOfficeVer & sregPost1 '"Software\Microsoft\Office\9.0\Common\UserInfo" key = sRegHKCU & strSKPath & "\" & strValueName '"HKCU\Software\Microsoft\Office\9.0\Common\UserInfo\UserName" 'Lecture des données utilisateur et test d'égalité pour ne pas faire de modification si username =user office Sub LoginUtilisateur 'WScript.Echo "Version office installée : " & sOfficeVer sNomOffice = objWord.UserName If netw.UserName=objWord.UserName Then Call Fichier End Sub 'Transformation du nom login utilisateur en chaine hexa pour la clef office Sub ASCIIHEXA Dim aAscii() Dim aChaine() Dim iLenChaine Dim k Dim aHexa() sChaine = netw.UserName sResult = "" ' taille iLenChaine = Len(sChaine) ' la chaine en tableau ReDim aChaine(iLenChaine) 'premiere valeur null non utilisée... indice 0 For k = 1 To iLenChaine aChaine(k) = Mid(sChaine, k, 1) Next ' ascii integer en tableau ReDim aAscii(iLenChaine) For k = 1 To iLenChaine aAscii(k) = Asc(aChaine(k)) Next ' ascii hexa en tableau + result ReDim aHexa(iLenChaine) For k = 1 To iLenChaine aHexa(k) = Hex(aAscii(k)) sResult = sResult & CStr(aHexa(k)) & "-00-" Next ' on ajoute le dernier chr(0) sResult = sResult & "00-00" End Sub 'Lecture de la clef de registre pour user office Sub lecture Set refRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") If refRegistry.GetBinaryValue(HKEY_CURRENT_USER, strSKPath , strValueName, arrValueData) = 0 Then For i = LBound(arrValueData) to UBound (arrValueData) strValueData = strValueData & Right("00" & Hex(arrValueData(i)),2) & "-" Next strValueData = Left(strValueData, Len(strValueData) - 1) Else Call Fichier End If Set refRegistry = Nothing End Sub 'Ecriture base de registre et fichier log Sub Fichier 'cas egalité username et user office If netw.UserName=objWord.UserName Then Set FileLog = oFSys.OpenTextFile("c:\office.log", 8, True) FileLog.writeLine ("PC :" & netw.ComputerName & " Nom utilisateur :" & netw.UserName & " Nom office :" & objWord.UserName & " Compte Identique" & "; Version office : " & sVersionOffice) FileLog.close Exit Sub End If 'cas différence username et user office If netw.UserName <> objWord.UserName Then WshShell.RegDelete key Dim refRegistry, arrValueData, strValueData, l, k ReDim arrValueData(Len(sResult)* 2 + 1) k = 0 For l = 1 To Len(sResult) arrValueData(k) = Asc(Mid(sResult,l,1)) k = k + 1 arrValueData(k) = 0 k = k + 1 Next arrValueData(k) = 0 k = k + 1 arrValueData(k) = 0 Set refRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") refRegistry.SetBinaryValue HKCU, strSKPath, strValueName, arrValueData Set refRegistry = Nothing 'Ecriture fichier log sur c:\ Set FileLog = oFSys.OpenTextFile("c:\office.log", 8, True) FileLog.writeLine ("PC :" & netw.ComputerName & " Nom utilisateur :" & netw.UserName & " Nom office :" & sNomOffice & " Modification effectuée" & "; Version office : " & sVersionOffice) FileLog.close Set netw = Nothing Set objWord =Nothing Set oFSys = Nothing Set WshShell = Nothing Set FileLog= Nothing End If End Sub 'procédure principale LoginUtilisateur ASCIIHEXA Lecture Fichier
26 juil. 2007 à 13:20
Je l'utilise dans le cadre cité en description (pour savoir qui est en train de travailler sur un fichier)
Bravo, 10/10
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.