bifido 76
Silver Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору 'Option Explicit On Error Resume Next Dim OEM , objWMIService , colItems , objItem , verItems, ver , name Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2") Set verItems = objWMIService.ExecQuery( _ "SELECT * FROM Win32_OperatingSystem",,48) For Each objItem in verItems ver = objItem.Version name = Replace (objItem.Caption,"Microsoft ","") Next Set colItems = objWMIService.ExecQuery( _ "SELECT * FROM SoftwareLicensingService",,48) For Each objItem in colItems OEM = objItem.OA3xOriginalProductKey Next If OEM = "" Then If CLng(Replace(ver,".","")) < 630000 Then OEM = name & " not supported" Else OEM = "Key not present in firmware" End If End If Set WshShell = CreateObject("WScript.Shell") Key = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\" DigitalID = WshShell.RegRead(key & "DigitalProductId") ProductName = "Product Name: " & vbTab & WshShell.RegRead(Key & "ProductName") & vbNewLine ProductID = "Product ID: " & vbTab & WshShell.RegRead(Key & "ProductID") & vbNewLine ProductKey = "Installed Key: " & vbTab & ConvertToKey(DigitalID) Product = ProductName & ProductID & ProductKey & vbNewLine & "OEM Key: " & vbTab & OEM If vbYes = MsgBox(Product & vbNewLine & vbNewLine & vbNewLine & vbNewLine & "Save to a file?", vbYesNo + vbInformation, "ShowKey: Windows Product Key Information") then Save(Product) End if Function ConvertToKey(Key) Const KeyOffset = 52 isWin8 = (Key(66) \ 6) And 1 Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4) i = 24 Chars = "BCDFGHJKMPQRTVWXY2346789" Do Cur = 0 X = 14 Do Cur = Cur * 256 Cur = Key(X + KeyOffset) + Cur Key(X + KeyOffset) = (Cur \ 24) Cur = Cur Mod 24 X = X -1 Loop While X >= 0 i = i -1 KeyOutput = Mid(Chars, Cur + 1, 1) & KeyOutput Last = Cur Loop While i >= 0 If (isWin8 = 1) Then keypart1 = Mid(KeyOutput, 2, Last) insert = "N" KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0) If Last = 0 Then KeyOutput = insert & KeyOutput End If a = Mid(KeyOutput, 1, 5) b = Mid(KeyOutput, 6, 5) c = Mid(KeyOutput, 11, 5) d = Mid(KeyOutput, 16, 5) e = Mid(KeyOutput, 21, 5) ConvertToKey = a & "-" & b & "-" & c & "-" & d & "-" & e End Function Function Save(Data) Const ForWRITING = 2 Const asASCII = 0 Dim fso, f, fName, ts fName = "Windows Key.txt" Set fso = CreateObject("Scripting.FileSystemObject") fso.CreateTextFile fName Set f = fso.GetFile(fName) Set f = f.OpenAsTextStream(ForWRITING, asASCII) f.Writeline Data f.Close End Function | Всего записей: 2474 | Зарегистр. 08-04-2016 | Отправлено: 16:39 30-05-2016 | Исправлено: bifido 76, 05:14 31-05-2016 |
|