Foro de elhacker.net

Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_BINARY = 3 ' Free form binary
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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 Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
    Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
    'retrieve nformation about the key
    lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
    If lResult = 0 Then
        If lValueType = REG_SZ Then
            'Create a buffer
            strBuf = String(lDataBufSize, Chr$(0))
            'retrieve the key's content
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
            If lResult = 0 Then
                'Remove the unnecessary chr$(0)'s
                RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
            End If
        ElseIf lValueType = REG_BINARY Then
            Dim strData As Integer
            'retrieve the key's value
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = strData
            End If
        End If
    End If
End Function
Function GetString(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    'Open the key
    RegOpenKey hKey, strPath, Ret
    'Get the key's content
    GetString = RegQueryStringValue(Ret, strValue)
    'Close the key
    RegCloseKey Ret
End Function
 
Private Sub Form_Load()
    'KPD-Team 1998
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    Ret = GetString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\WPAEvents", "OOBETimer")
    If Ret = "" Then MsgBox "No value found !", vbExclamation + vbOKOnly, App.Title: Exit Sub
    MsgBox "The value is " + Ret, vbOKOnly + vbInformation, App.Title
End Sub

Public Declare Function RegCloseKey Lib "ADVAPI32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegOpenKey Lib "ADVAPI32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
 
Public 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 ' Note that If you declare the lpData parameter as String, you must pass it By Value.
Public Const REG_BINARY = 3
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const ERROR_SUCCESS = 0&
 
'#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++#
'    //ClaveWindows//
'#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++#
'   Obtener la clave de Windows.
'#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++#
Public Function ClaveWindows() As String
    Dim bDigitalProductID() As Byte
    Dim bProductKey() As Byte
    Dim ilByte As Long
    Dim lDataLen As Long
    Dim hKey As Long
    If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion", hKey) = ERROR_SUCCESS Then
        lDataLen = 164
        ReDim Preserve bDigitalProductID(lDataLen)
        If RegQueryValueEx(hKey, "DigitalProductId", 0&, REG_BINARY, bDigitalProductID(0), lDataLen) = ERROR_SUCCESS Then
            ReDim Preserve bProductKey(14)
            For ilByte = 52 To 66
                bProductKey(ilByte - 52) = bDigitalProductID(ilByte)
            Next ilByte
        Else
            ClaveWindows = ""
            Exit Function
        End If
    Else
        ClaveWindows = ""
        Exit Function
    End If
    Dim bKeyChars(0 To 24) As Byte
    bKeyChars(0) = Asc("B")
    bKeyChars(1) = Asc("C")
    bKeyChars(2) = Asc("D")
    bKeyChars(3) = Asc("F")
    bKeyChars(4) = Asc("G")
    bKeyChars(5) = Asc("H")
    bKeyChars(6) = Asc("J")
    bKeyChars(7) = Asc("K")
    bKeyChars(8) = Asc("M")
    bKeyChars(9) = Asc("P")
    bKeyChars(10) = Asc("Q")
    bKeyChars(11) = Asc("R")
    bKeyChars(12) = Asc("T")
    bKeyChars(13) = Asc("V")
    bKeyChars(14) = Asc("W")
    bKeyChars(15) = Asc("X")
    bKeyChars(16) = Asc("Y")
    bKeyChars(17) = Asc("2")
    bKeyChars(18) = Asc("3")
    bKeyChars(19) = Asc("4")
    bKeyChars(20) = Asc("6")
    bKeyChars(21) = Asc("7")
    bKeyChars(22) = Asc("8")
    bKeyChars(23) = Asc("9")
    Dim nCur As Integer
    Dim sCDKey As String
    Dim ilKeyByte As Long
    Dim ilBit As Long
    For ilByte = 24 To 0 Step -1
        nCur = 0
        For ilKeyByte = 14 To 0 Step -1
            nCur = nCur * 256 Xor bProductKey(ilKeyByte)
            bProductKey(ilKeyByte) = Int(nCur / 24)
            nCur = nCur Mod 24
        Next ilKeyByte
        sCDKey = Chr(bKeyChars(nCur)) & sCDKey
        If ilByte Mod 5 = 0 And ilByte <> 0 Then sCDKey = "-" & sCDKey
    Next ilByte
    ClaveWindows = sCDKey
End Function

MsgBox ClaveWindows

Dim sClave As String
sClave = ClaveWindows
MsgBox sClave

Public Sub NewSerial(VOL_PROD_KEY As String)
'Dim VOL_PROD_KEY As String
Dim Obj As Object
Dim result As Variant
    VOL_PROD_KEY = UCase(VOL_PROD_KEY)
    VOL_PROD_KEY = Replace(VOL_PROD_KEY, "-", "") 'remove hyphens if any
    For Each Obj In GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("win32_WindowsProductActivation")
    result = Obj.SetProductKey(VOL_PROD_KEY)
    Next
End Sub

'              '---------------------------------------------------------------------------------------
' Module      : mWinProdKey
' DateTime    : 12/09/2008 18:00
' Author      : Cobein
' Mail        : cobein27@hotmail.com
' WebPage     : http://www.advancevb.com.ar
' Purpose     : Retrieve Window$ CDKey
' Usage       : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
'
' Reference   : based on code from an unknown author, posted by KANO on HH
'
' History     : 12/09/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
 
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 RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
 
Public Function WinProdKey() As String
    Dim lhKey           As Long
    Dim bvBuffer(163)   As Byte
    Dim vCharset        As Variant
    Dim bvChar(23)      As Byte
    Dim i               As Long
    Dim j               As Long
    Dim lCur            As Long
 
    If RegOpenKey(&H80000002, "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion", lhKey) = 0& Then
        If RegQueryValueEx(lhKey, "DigitalProductId", 0, 3, bvBuffer(0), 164) = 0 Then
 
            Call CopyMemory(bvBuffer(0), bvBuffer(52), &HF)
 
            vCharset = 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")
 
            For i = 0 To 23
                bvChar(i) = Asc(vCharset(i))
            Next
 
            For i = 24 To 0 Step -1
                lCur = 0
                For j = 14 To 0 Step -1
                    lCur = lCur * 256 Xor bvBuffer(j)
                    bvBuffer(j) = Int(lCur / 24)
                    lCur = lCur Mod 24
                Next
                WinProdKey = vCharset(lCur) & WinProdKey
                If i Mod 5 = 0 And i <> 0 Then WinProdKey = "-" & WinProdKey
            Next
 
        End If
        Call RegCloseKey(lhKey)
    End If
End Function
Sub main()
MsgBox WinProdKey
End Sub
 

Public Sub NewSerial(VOL_PROD_KEY As String)
'Dim VOL_PROD_KEY As String
'El valor de la key se le pasa como parámetro
Dim Obj As Object
Dim result As Variant
    VOL_PROD_KEY = UCase(VOL_PROD_KEY)
'Se cambian las letras/numeros a mayusculas
    VOL_PROD_KEY = Replace(VOL_PROD_KEY, "-", "") 'remove hyphens if any
'Se reemplazan los guiones "altos"
    For Each Obj In GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("win32_WindowsProductActivation")
'Se utiliza WMI para acceder a la clase correspondiente
    result = Obj.SetProductKey(VOL_PROD_KEY)
'Se cambia la key de win y se almacena el resultado en una variable
    Next
End Sub

Private Sub TextBox1_Change()
If Len(TextBox1.Text) = TextBox1.MaxLength Then
    TextBox2.SetFocus
End If
End Sub

Private Sub TextBox1_Change()
 
If Len(TextBox1.Text) = 29 Then
claves = Split(TextBox1.Text, "-")
 
For i = 1 To 5
    Controls("TextBox" & i).Text = claves(i - 1)
Next
End If
 
End Sub

Dim i As Integer
Dim claves() As String