Kërko
Tema Fundit
identifikimi
Kush është në linjë
4 përdorues në linjë: 0 anëtarë 0 të fshehur 4 vizitorë Asnjë
Rekord i përdoruesve në linjë ishte 23 më Tue Jun 16, 2020 2:53 pm
Vbscript Windows Cd
Faqja 1 e 1
Vbscript Windows Cd
I want to be able to run this vbscript which will send me the pc's windows key and office key via email. I have got this much of the code which i grabbed from a website.
' ##############################################################
' # #
' # VBScript to retrieve Microsoft Product Keys #
' # from the registry by decoding DigitalProductID's #
' # #
' # -------------------------------------------------- #
' # Created by: X-PeRsOnI #
' # #
' ##############################################################
'
CONST HKEY_LOCAL_MACHINE = &H80000002
CONST SEARCH_KEY = "DigitalProductID"
Dim arrSubKeys(4,1)
Dim foundKeys
Dim iValues, arrDPID
foundKeys = Array()
iValues = Array()
arrSubKeys(0,0) = "Microsoft Windows Product Key"
arrSubKeys(0,1) = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
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 Exchange Product Key"
arrSubKeys(4,1) = "SOFTWARE\Microsoft\Exchange\Setup"
' <--------------- Open Registry Key and populate binary data into an array -------------------------->
strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\default:StdRegProv")
For x = LBound(arrSubKeys, 1) To UBound(arrSubKeys, 1)
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
MsgBox("Finished")
' <----------------------------------------- Return the Product Key --------------------------------------------------->
Function decodeKey(iValues, strProduct)
Dim arrDPID
arrDPID = Array()
' <--------------- extract bytes 52-66 of the DPID -------------------------->
For i = 52 to 66
ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
arrDPID( UBound(arrDPID) ) = iValues(i)
Next
' <--------------- Create an array to hold the valid characters for a microsoft Product Key -------------------------->
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")
' <--------------- The clever bit !!! (decode the base24 encoded binary data)-------------------------->
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)
MsgBox strProduct & vbNewLine & vbNewLine & foundKeys(strKey)
End Function
' ##############################################################
' # #
' # VBScript to retrieve Microsoft Product Keys #
' # from the registry by decoding DigitalProductID's #
' # #
' # -------------------------------------------------- #
' # Created by: X-PeRsOnI #
' # #
' ##############################################################
'
CONST HKEY_LOCAL_MACHINE = &H80000002
CONST SEARCH_KEY = "DigitalProductID"
Dim arrSubKeys(4,1)
Dim foundKeys
Dim iValues, arrDPID
foundKeys = Array()
iValues = Array()
arrSubKeys(0,0) = "Microsoft Windows Product Key"
arrSubKeys(0,1) = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
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 Exchange Product Key"
arrSubKeys(4,1) = "SOFTWARE\Microsoft\Exchange\Setup"
' <--------------- Open Registry Key and populate binary data into an array -------------------------->
strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\default:StdRegProv")
For x = LBound(arrSubKeys, 1) To UBound(arrSubKeys, 1)
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
MsgBox("Finished")
' <----------------------------------------- Return the Product Key --------------------------------------------------->
Function decodeKey(iValues, strProduct)
Dim arrDPID
arrDPID = Array()
' <--------------- extract bytes 52-66 of the DPID -------------------------->
For i = 52 to 66
ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
arrDPID( UBound(arrDPID) ) = iValues(i)
Next
' <--------------- Create an array to hold the valid characters for a microsoft Product Key -------------------------->
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")
' <--------------- The clever bit !!! (decode the base24 encoded binary data)-------------------------->
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)
MsgBox strProduct & vbNewLine & vbNewLine & foundKeys(strKey)
End Function
kujti1- Admin
- Numri i postimeve : 106
Join date : 20/11/2010
Faqja 1 e 1
Drejtat e ktij Forumit:
Ju nuk mund ti përgjigjeni temave të këtij forumi
|
|
Tue Jan 31, 2012 5:04 pm nga Gon!
» Univers No Limit
Tue Jan 31, 2012 4:39 pm nga Gon!
» UFO - ALIEN
Tue Jan 31, 2012 4:31 pm nga Gon!
» Telefonata nga persona te vdekur
Tue Jan 31, 2012 3:20 pm nga Gon!
» Kush janë masonët? NWO?
Tue Oct 25, 2011 11:02 am nga Gon!
» Bio Shkenca
Tue Oct 25, 2011 10:13 am nga Gon!
» Tulipani numër 49 është shqiptar
Tue Oct 25, 2011 10:03 am nga Gon!
» Populli me fuqi të mbinatyrshme
Tue Oct 25, 2011 10:01 am nga Gon!
» E VËRTETA SHKENCORE MBI KOSOVËN
Mon Oct 24, 2011 10:49 am nga Gon!