En este caso realizaremos un Activador "Genuine" de Windows XP, simplemente lo que realizara nuestro programa es, mediante a un modulo, tomar datos del registro de windows y luego escribir en él.
Para ello utilizaremos una libreria incluida en Windows XP llamada "advapi32.dll", luego trabajaremos con la ruta de registro "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion"; en esta ruta se encuentra nuestro serial codificado, que luego decodificaremos y a su ves codificaremos el nuevo serial.
(http://3.bp.blogspot.com/-DtO3csFh5z0/T5x8IvjcnkI/AAAAAAAAA9Y/YNouYOP8tjY/s1600/01.PNG)
Utilizaremos básicamente dos botones "Verificar" llamado "cmdComprobar" y "Registrar" llamado "CmdInsertar", luego dos labels, uno corresponderá a la versión llamado "lblVersion" y otro a la licencia "Label3", también un ComboBox llamado "cbSerial" el cual estará oculto. Los demás son simplemente para darle un aspecto mas provechoso al programa.
Bien, comenzaremos por el formulario principal (Main.frm):
Private Sub Form_Load()
Centrar Me
DatosActuales
CargarSeriales
End Sub
Aquí primero centraremos el formulario en la pantalla. Luego:
Private Sub cmdComprobar_Click()
DatosActuales
If lblClave.Caption = "BVXT3-HMX82-3T69H-9WC87-7JJKW" Then
Label3.Caption = "Genuine"
Label3.ForeColor = vbBlue
Else
Label3.Caption = "Copia"
Label3.ForeColor = vbRed
End If
End Sub
Tomaremos los datos actuales del windows y verificaremos si tiene el serial genuino, si es que no es copia.
Private Sub DatosActuales()
lblVersion.Caption = VerVersion
lblClave.Caption = SacarClave
End Sub
Private Sub CargarSeriales()
cbSerial.Clear
cbSerial.AddItem "BVXT3-HMX82-3T69H-9WC87-7JJKW" 's
cbSerial.ListIndex = 0
End Sub
Luego definimos las variables para los datos actuales y cargamos un serial por defecto en el combobox.
Private Sub CmdInsertar_Click()
InsertarSerial Trim(cbSerial.Text)
End Sub
Por ultimo llamamos a la función para insertar el serial correspondiente en el registro de windows.
Bien, ahora vamos al modulo, agregaremos un modulo llamado "modulo.bas":
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Const REG_BINARY = 3
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1
' Ruta del registro donde Windows guarda la clave (codificada) y la versión
Private Const RUTA_REGISTRO = "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion"
' Obtenemos la clave actual
Public Function SacarClave() As String
Dim bID(164) As Byte, bKey(14) As Byte, bAsc(24) As Byte
Dim lBit As Long, hKey As Long
If RegOpenKey(HKEY_LOCAL_MACHINE, RUTA_REGISTRO, hKey) = 0 Then
If RegQueryValueEx(hKey, "DigitalProductId", 0&, REG_BINARY, bID(0), 164) = 0 Then
For lBit = 52 To 66
bKey(lBit - 52) = bID(lBit)
Next lBit
Else
SacarClave = "No se puede leer la clave."
Exit Function
End If
Else
SacarClave = "No se puede acceder al registro."
Exit Function
End If
'Descodificar la clave
bAsc(0) = Asc("B"): bAsc(1) = Asc("C"): bAsc(2) = Asc("D")
bAsc(3) = Asc("F"): bAsc(4) = Asc("G"): bAsc(5) = Asc("H")
bAsc(6) = Asc("J"): bAsc(7) = Asc("K"): bAsc(8) = Asc("M")
bAsc(9) = Asc("P"): bAsc(10) = Asc("Q"): bAsc(11) = Asc("R")
bAsc(12) = Asc("T"): bAsc(13) = Asc("V"): bAsc(14) = Asc("W")
bAsc(15) = Asc("X"): bAsc(16) = Asc("Y"): bAsc(17) = Asc("2")
bAsc(18) = Asc("3"): bAsc(19) = Asc("4"): bAsc(20) = Asc("6")
bAsc(21) = Asc("7"): bAsc(22) = Asc("8"): bAsc(23) = Asc("9")
Dim i As Integer, j As Integer, sClave As String
For lBit = 24 To 0 Step -1
i = 0
For j = 14 To 0 Step -1
i = i * 256 Xor bKey(j)
bKey(j) = Int(i / 24)
i = i Mod 24
Next j
sClave = Chr(bAsc(i)) & sClave
If lBit Mod 5 = 0 And lBit <> 0 Then sClave = "-" & sClave
Next lBit
SacarClave = sClave
End Function
' Obtenemos la clave actual
Public Function VerVersion()
Dim lRet As Long
RegOpenKey HKEY_LOCAL_MACHINE, RUTA_REGISTRO, lRet
VerVersion = SacarValorRegistro(lRet, "ProductName")
RegCloseKey lRet
RegOpenKey HKEY_LOCAL_MACHINE, RUTA_REGISTRO, lRet
VerVersion = VerVersion & " - " & SacarValorRegistro(lRet, "CSDVersion")
RegCloseKey lRet
End Function
' Leer valor de registro
Function SacarValorRegistro(ByVal HKLM As Long, ByVal sValor As String) As String
Dim lRet As Long, lInfoValor As Long
Dim lLen As Long, sBuffer As String
lRet = RegQueryValueEx(HKLM, sValor, 0, lInfoValor, ByVal 0, lLen)
If lRet = 0 Then
If lInfoValor = REG_SZ Then
sBuffer = String(lLen, Chr$(0))
lRet = RegQueryValueEx(HKLM, sValor, 0, 0, ByVal sBuffer, lLen)
If lRet = 0 Then
SacarValorRegistro = Left$(sBuffer, InStr(1, sBuffer, Chr$(0)) - 1)
End If
ElseIf lInfoValor = REG_BINARY Then
Dim strData As Integer
lRet = RegQueryValueEx(HKLM, sValor, 0, 0, strData, lLen)
If lRet = 0 Then SacarValorRegistro = strData
End If
End If
End Function
' Cambiar serial del registro
Public Sub InsertarSerial(Serial As String)
On Error Resume Next
Dim TodoOk As Boolean
TodoOk = True
If Serial = "" Then
MsgBox "Complete el Número de Serie que quiere insertar!", vbExclamation, "Nº de Serie inválido"
TodoOk = False
XPReg.cbSerial.SetFocus
Else
If Len(Serial) <> 29 Then
MsgBox "El Número de Serie a Insertar debe poseer 29 dígitos" & vbCrLf & "Controle", vbExclamation, "Nº de Serie inválido"
TodoOk = False
XPReg.cbSerial.SetFocus
End If
End If
If TodoOk = True Then
Dim VOL_PROD_KEY As String
VOL_PROD_KEY = Replace(Serial, "-", "")
For Each obj In GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("win32_WindowsProductActivation")
result = obj.SetProductKey(VOL_PROD_KEY)
If Err <> 0 Then
MsgBox Err.Description, "0x" & Hex(Err.Number)
Err.Clear
End If
Next
MsgBox "¡Su Microsoft Windows XP es Genuino!" & vbCrLf & vbCrLf & "Verifíquelo pulsando el botón Verificar", vbInformation, "Registro Exitoso!"
XPReg.cmdComprobar.SetFocus
End If
End Sub
' Centrar el formulario
Public Sub Centrar(Frm As Form)
Frm.Left = (Screen.Width / 2) - (Frm.Width / 2)
Frm.Top = (Screen.Height / 2) - (Frm.Height / 2) - 600
End Sub
Un modulo lo podemos utilizar para declarar funciones, acciones, variables y realizar calculos y llamarlos con tan solo poner el nombre de la funcion, en este caso la función "SacarClave" la utilizamos para decodificar y mover el serial a una variable que luego comparamos con el serial original y damos como genuino o no al serial. A su ves también tenemos la función de "VerSerial", la cual solamente toma datos del registro; entre otras más...
FUENTE: http://www.nochesdecode.com.ar/2012/04/activador-de-windows-xp-en-visual-basic.html (http://www.nochesdecode.com.ar/2012/04/activador-de-windows-xp-en-visual-basic.html)