anarquiles

Windows Key Backup

Mar 3rd, 2021
961
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. 'Ruta del registro
  6. Path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
  7. 'Valor de llave de Registro
  8. DigitalID = objshell.RegRead(Path & "DigitalProductId")
  9. Dim ProductName,ProductID,ProductKey,ProductData
  10. 'leer Nombre del producto, ID del Producto, Licencia del Producto
  11. ProductName = "Nombre del Producto: " & objshell.RegRead(Path & "ProductName")
  12. ProductID = "ID del Producto: " & objshell.RegRead(Path & "ProductID")
  13. ProductKey = "Licencia Instalada: " & ConvertToKey(DigitalID)  
  14. ProductData = ProductName  & vbNewLine & ProductID  & vbNewLine & ProductKey
  15. 'Mostrar mensaje de Guardado  
  16. If vbYes = MsgBox(ProductData  & vblf & vblf & "Guardar a Archivo?", vbYesNo + vbQuestion, "Respaldo de Licencia de Windows") then
  17.    Save ProductData  
  18. End If
  19.  
  20.  
  21.  
  22. 'Convertir Binarios a Letras
  23. Function ConvertToKey(Key)
  24.     Const KeyOffset = 52
  25.     Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
  26.     'Verifica si el OS es Windows 8
  27.    isWin8 = (Key(66) \ 6) And 1
  28.     Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
  29.     i = 24
  30.     Maps = "BCDFGHJKMPQRTVWXY2346789"
  31.     Do
  32.            Current= 0
  33.         j = 14
  34.         Do
  35.            Current = Current* 256
  36.            Current = Key(j + KeyOffset) + Current
  37.            Key(j + KeyOffset) = (Current \ 24)
  38.            Current=Current Mod 24
  39.             j = j -1
  40.         Loop While j >= 0
  41.         i = i -1
  42.         KeyOutput = Mid(Maps,Current+ 1, 1) & KeyOutput
  43.         Last = Current
  44.     Loop While i >= 0  
  45.      
  46.     If (isWin8 = 1) Then
  47.         keypart1 = Mid(KeyOutput, 2, Last)
  48.         insert = "N"
  49.         KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
  50.         If Last = 0 Then KeyOutput = insert & KeyOutput
  51.     End If    
  52.      
  53.  
  54.     ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)
  55.    
  56.      
  57. End Function
  58. 'Guardar a archivo
  59. Function Save(Data)
  60.     Dim fso, fName, txt,objshell,UserName
  61.     Set objshell = CreateObject("wscript.shell")
  62.     'Tomar Usuario Actual  
  63.    UserName = objshell.ExpandEnvironmentStrings("%UserName%")  
  64.     'Crear archivo e escritorio  
  65.    fName = "C:\Users\" & UserName & "\Desktop\RespaldoLicencia.txt"
  66.     Set fso = CreateObject("Scripting.FileSystemObject")
  67.     Set txt = fso.CreateTextFile(fName)
  68.     txt.Writeline Data
  69.     txt.Close
  70. 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.

×