[Script] VBS para coletar LicenseKey dos Offices 2003,XP,2007,2010

Scripts diversos para automatizar tarefas em servidores ou auxilio com tarefas administrativas.
Avatar do usuário
marceloleaes
Administrator
Administrator
Mensagens: 1516
Registrado em: 10 Jun 2013 12:45
Localização: Novo Hamburgo
Idade: 41
Contato:
Status: Offline

[Script] VBS para coletar LicenseKey dos Offices 2003,XP,2007,2010

Mensagem por marceloleaes »

Segue codigo, salvar como .vbs e rodar na estacao de trabalho que necessita fazer a descoberta da licenca.

Código: Selecionar todos

' Coleta LicenseKey
' Script para coleta da chave de licenca do Microsoft Office versoes 2003,XP,2007 e 2010

If err.number <> 0 Then
    WScript.Echo ("Ocorreu um erro") 
    Wscript.Quit 1001
Else
     Set WshShell = CreateObject("WScript.Shell")
     CONST HKEY_LOCAL_MACHINE = &H80000002
     CONST SEARCH_KEY = "DigitalProductID"
     Dim arrSubKeys(6,1)
     Dim foundKeys
     Dim iValues, arrDPID
     foundKeys = Array()
     iValues = Array()
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
     & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colProcessors = objWMIService.ExecQuery("Select * from Win32_Processor")
    For Each objProcessor in colProcessors
      Select Case objProcessor.AddressWidth
                        Case 32
                            arrSubKeys(2,0) = "Microsoft Office XP"
                            arrSubKeys(2,1) = "SOFTWARE\Microsoft\Office\10.0\Registration"
                            arrSubKeys(1,0) = "Microsoft Office 2003"
                            arrSubKeys(1,1) = "SOFTWARE\Microsoft\Office\11.0\Registration"
                            arrSubKeys(3,0) = "Microsoft Office 2007"
                            arrSubKeys(3,1) = "SOFTWARE\Microsoft\Office\12.0\Registration"
                            arrSubKeys(4,0) = "Microsoft Office 2010"
                            arrSubKeys(4,1) = "SOFTWARE\Microsoft\Office\14.0\Registration"
                        Case 64
                            arrSubKeys(2,0) = "Microsoft Office XP"
                            arrSubKeys(2,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\10.0\Registration"
                            arrSubKeys(1,0) = "Microsoft Office 2003"
                            arrSubKeys(1,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\11.0\Registration"
                            arrSubKeys(3,0) = "Microsoft Office 2007"
                            arrSubKeys(3,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Registration"
                            arrSubKeys(4,0) = "Microsoft Office 2010"
                            arrSubKeys(4,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\14.0\Registration"
                    End Select
    next
    Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
    For x = 1 To 4
        oReg.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1), SEARCH_KEY, arrDPIDBytes
      If Not IsNull(arrDPIDBytes) Then
         call decodeKey(arrDPIDBytes, arrSubKeys(x,0))
      Else
       oReg.EnumKey HKEY_LOCAL_MACHINE, arrSubKeys(x,1), arrGUIDKeys
       If Not IsNull(arrGUIDKeys) Then
        For Each GUIDKey In arrGUIDKeys
         oReg.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1) & "\" & GUIDKey, SEARCH_KEY, arrDPIDBytes
         If Not IsNull(arrDPIDBytes) Then
          call decodeKey(arrDPIDBytes, arrSubKeys(x,0))

         End If
        Next
       End If
      End If
     Next
    Function decodeKey(iValues, strProduct)
        Dim arrDPID
        arrDPID = Array()


    For i = 52 to 66
       ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
       arrDPID( UBound(arrDPID) ) = iValues(i)
      Next
      Dim arrChars
      arrChars = Array("B","C","D","F","G","H","J","K","M","P","Q","R","T","V","W","X","Y","2","3","4","6","7","8","9")


      For i = 24 To 0 Step -1
       k = 0
       For j = 14 To 0 Step -1
        k = k * 256 Xor arrDPID(j)
        arrDPID(j) = Int(k / 24)
        k = k Mod 24
       Next
       strProductKey = arrChars(k) & strProductKey
       If i Mod 5 = 0 And i <> 0 Then strProductKey = "-" & strProductKey
      Next

      ReDim Preserve foundKeys( UBound(foundKeys) + 1 )
      foundKeys( UBound(foundKeys) ) = strProductKey
      strKey = UBound(foundKeys)
      wscript.echo ( "LicenseKey =  "   & foundKeys(strKey))
    End Function
    Wscript.Echo "LicenseKey coletada com sucesso."
    wscript.Quit(0) 
End If


"Transportai um punhado de terra todos os dias e fareis uma montanha." Confúcio

Voltar para “Scripts”