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

'              '---------------------------------------------------------------------------------------
' 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