Guest User

Untitled

a guest
Mar 8th, 2019
268
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Explicit  
  2.  
  3. Dim objshell,path,DigitalID, Result  
  4. Set objshell = CreateObject("WScript.Shell")
  5. 'Set registry key path
  6. Path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
  7. 'Registry key value
  8. DigitalID = objshell.RegRead(Path & "DigitalProductId")
  9. Dim ProductName,ProductID,ProductKey,ProductData
  10. 'Get ProductName, ProductID, ProductKey
  11. ProductName = "Product Name: " & objshell.RegRead(Path & "ProductName")
  12. ProductID = "Product ID: " & objshell.RegRead(Path & "ProductID")
  13. ProductKey = "Installed Key: " & ConvertToKey(DigitalID)  
  14. ProductData = ProductName  & vbNewLine & ProductID  & vbNewLine & ProductKey
  15. 'Show messbox if save to a file  
  16. If vbYes = MsgBox(ProductData  & vblf & vblf & "Save to a file?", vbYesNo + vbQuestion, "BackUp Windows Key Information") then
  17.    Save ProductData  
  18. End If
  19.  
  20. 'Convert binary to chars
  21. Function ConvertToKey(Key)
  22.     Const KeyOffset = 52
  23.     Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
  24.     'Check if OS is Windows 8
  25.     isWin8 = (Key(66) \ 6) And 1
  26.     Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
  27.     i = 24
  28.     Maps = "BCDFGHJKMPQRTVWXY2346789"
  29.     Do
  30.            Current= 0
  31.         j = 14
  32.         Do
  33.            Current = Current* 256
  34.            Current = Key(j + KeyOffset) + Current
  35.            Key(j + KeyOffset) = (Current \ 24)
  36.            Current=Current Mod 24
  37.             j = j -1
  38.         Loop While j >= 0
  39.         i = i -1
  40.         KeyOutput = Mid(Maps,Current+ 1, 1) & KeyOutput
  41.         Last = Current
  42.     Loop While i >= 0  
  43.      
  44.     If (isWin8 = 1) Then
  45.         keypart1 = Mid(KeyOutput, 2, Last)
  46.         insert = "N"
  47.         KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
  48.         If Last = 0 Then KeyOutput = insert & KeyOutput
  49.     End If    
  50.      
  51.     ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)
  52.      
  53. End Function
  54. 'Save data to a file
  55. Function Save(Data)
  56.     Dim fso, fName, txt,objshell,UserName
  57.     Set objshell = CreateObject("wscript.shell")
  58.     'Get current user name  
  59.     UserName = objshell.ExpandEnvironmentStrings("%UserName%")  
  60.     'Create a text file on desktop  
  61.     fName = "C:\Users\" & UserName & "\Desktop\WindowsKeyInfo.txt"
  62.     Set fso = CreateObject("Scripting.FileSystemObject")
  63.     Set txt = fso.CreateTextFile(fName)
  64.     txt.Writeline Data
  65.     txt.Close
  66. End Function
RAW Paste Data

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×