VB获取本机XP序列号

Question

怎样通过VB来获取本机XP的序列号，各位大侠帮帮忙。

Answer 1

序列号？网卡序列号？CPU序列号？还是操作系统注册序列号？

Answer 2

注册表会读罢
HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\ProductID

Answer 3

就是在安装操作系统时，所输入的序列号。谢谢bestbadgood，在线等，急着用啊。

Answer 4

好像不是HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\ProductID这个值的，谢谢patrickkong

Answer 5

Option ExplicitPrivate 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                                                               '   Note   that   if   you   declare   the   lpData   parameter   as   String,   you   must   pass   it   By   Value.
Private Const REG_BINARY = 3
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const ERROR_SUCCESS = 0&
    
Private Function sGetXPCDKey() 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
                sGetXPCDKey = "无法读取注册信息"
                Exit Function
        End If
    Else
        sGetXPCDKey = "无法读取注册信息"
        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")
    bKeyChars(24) = 0
    
    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
    sGetXPCDKey = sCDKey
End FunctionPrivate Sub Form_Load()
    Text1.Text = sGetXPCDKey()
End Sub

Answer 6

WinXPKey.vbs内容：' WinXPKey.vbs
' Author: elffin 
' Edited from Script by Microsoft and Mark D. MacLachlan
' Version: 0.5
' Function: Display and change product key of Windows XP (Maybe Win2003)
'
' ChangLog:
' - Ver 0.5
' Add LineOut Function
' Add Name, version, etc. of Windows
' Add a little More Information
' Small change in getkey Function
' Break Line In source
' Change name of some Variables
' Add productKeyFound to deal with not installed key
' Add Ecplicit Option
' Change the methods of registry operate
' Add predefined variables at begining
' Add treatment when Pkey or PID not exist in registry
' Delete space of new key
' Add ExitScript
' - Ver 0.2
'
' Todo:
' Display the install date
'
' COMMENT: You can contact me if you find problem.
'           Please keep author and URL information if change the source.Option ExplicitON ERROR RESUME NEXT
Dim g_strComputer, g_objRegistry, g_EchoStringg_strComputer = "."
g_EchoString = ""private const L_MsgErrorPKey                          = "没有安装Windows序列号, 以下为注册表残留信息。"
private const L_MsgErrorRegPKey                       = "没有在注册表中找到Windows序列号."
private const L_MsgErrorRegPID                        = "没有在注册表中找到Windows产品ID."Private const L_MsgProductName                        = "系统："
private const L_MsgProductDesc                        = "系统描述: "
private const L_MsgVersion                            = "版本号: "
Private Const L_MsgServicePack                        = "补丁包："
Private Const L_MsgBuild                              = "编译代号："private const L_MsgProductKey                         = "序列号: "
private const L_MsgProductId                          = "产品ID: "
private const HKEY_LOCAL_MACHINE                      =  &H80000002
Private Const WindowsNTInfoPath                       = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
Dim Obj
Dim productKeyFound
Dim strActiveStatus, strEvalRemain
Dim strProductKey, strProductId, strProductVersion, strTmp
Dim strNewProductKey, Result
Dim bRegPKeyFound, bRegPIDFound       ' value exists in registry
'If this is the local computer, set everything immediately
If g_strComputer = "." Then
        Set g_objRegistry = GetObject("winmgmts:\\" & g_strComputer & "\root\default:StdRegProv")
End IfbRegPKeyFound = False : bRegPIDFound = False : productKeyFound = False
g_objRegistry.GetBinaryValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "DigitalProductId", strTmp
If Not IsNull(strTmp) Then
         strProductKey=GetKey(strTmp)
         bRegPKeyFound = True
End If
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "ProductId", strTmp
If Not IsNull(strTmp) Then
         strProductId = strTmp
         bRegPIDFound = True
End IfLineOut ""
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "ProductName", strTmp
LineOut GetResource("L_MsgProductName") & strTmp
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "CSDVersion", strTmp
If Not IsNull(strTmp) Then
         LineOut GetResource("L_MsgServicePack") & strTmp
End If
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "CurrentVersion", strProductVersion
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "CurrentBuildNumber", strTmp
strProductVersion=strProductVersion & "." & strTmp
LineOut GetResource("L_MsgVersion") & strProductVersion
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "BuildLabEx", strTmp
If IsNull(strTmp) Then
         g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "BuildLab", strTmp
End If
LineOut GetResource("L_MsgBuild") & strTmp For Each Obj in GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf ("win32_WindowsProductActivation")productKeyFound = TrueLineOut "主机名称：" & obj.ServerName
If Obj.ActivationRequired <> 0 Then
         strActiveStatus = "需要激活" & "(宽限期剩余" & Obj.RemainingGracePeriod & "天)"
Else
         strActiveStatus = "Windows 系统已经激活"
End If
LineOut strActiveStatus
If Obj.RemainingEvaluationPeriod <> 2147483647 Then
         strEvalRemain = Obj.RemainingEvaluationPeriod & "天"
Else
         strEvalRemain = "无限期"
End If
LineOut "剩余有效期：" & strEvalRemain
NextLineOut ""
If productKeyFound <> True Then
         LineOut GetResource("L_MsgErrorPKey")
End If
If bRegPKeyFound Then
         LineOut GetResource("L_MsgProductKey") & strProductKey
Else
         LineOut GetResource("L_MsgErrorRegPKey")
End If
If bRegPIDFound Then
         LineOut GetResource("L_MsgProductId") & strProductId
Else
         LineOut GetResource("L_MsgErrorRegPID")
End IfLineOut ""
LineOut "本程序将自动替换Windows XP(2003)序列号" & "(OEM版无效，默认版本为VLK)"LineOut ""
LineOut ""
LineOut "请在下面输入新的序列号："If Wscript.arguments.count<1 Then
         strNewProductKey=InputBox(g_EchoString, "Windows XP 序列号查看替换器", _
        "MRX3F-47B9T-2487J-KWKMF-RPWBY")
        If strNewProductKey = "" Then
                 Wscript.quit
        End If
Else
         strNewProductKey = Wscript.arguments.Item(0)
End Ifg_EchoString = ""
strNewProductKey = replace(strNewProductKey, Space(1), "")   'delete the space of new key
strTmp = strNewProductKey
strNewProductKey = Replace(strNewProductKey,"-","") 'remove hyphens if any
For Each Obj in GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf ("win32_WindowsProductActivation")
result = Obj.SetProductKey(strNewProductKey)
If Err = 0 Then
         LineOut "序列号成功替换为 " & strTmp & " ！"
End If
If Err <> 0 Then
         LineOut "替换序列号为 " & strTmp & " 失败！" & vbNewline & "可能序列号有误或与当前系统版本不匹配。错误代码：0x" & Hex(Err.Number)
         Err.Clear
End If
NextExitScript 0  
Private Function GetKey(rpk)   'Decode the product keyConst rpkOffset=52
Dim dwAccumulator, szPossibleChars, szProductKey
dim i,ji=28 : szPossibleChars="BCDFGHJKMPQRTVWXY2346789"
Do 'Rep1
         dwAccumulator=0 : j=14
        Do
                 dwAccumulator=dwAccumulator*256
                 dwAccumulator=rpk(j+rpkOffset)+dwAccumulator
                 rpk(j+rpkOffset)=(dwAccumulator\24) and 255
                 dwAccumulator=dwAccumulator Mod 24
                 j=j-1
        Loop While j>=0
         i=i-1 : szProductKey=mid(szPossibleChars,dwAccumulator+1,1)&szProductKey
        If (((29-i) Mod 6)=0) and (i<>-1) Then
                 i=i-1 : szProductKey="-"&szProductKey
        End If
Loop While i>=0 'Goto Rep1
GetKey=szProductKey
End Function
Private Sub ExitScript(retval)
if (g_EchoString <> "") Then
        MsgBox g_EchoString, 0, "Windows XP 序列号查看替换器"
End If
WScript.Quit retval
End Sub
Private Sub LineOut(str)
g_EchoString = g_EchoString & str & vbNewLine
End Sub ' Get the resource string with the given name using the built-in default.
Private Function GetResource(name)
GetResource = Eval(name)
End Function

Answer 7

谢谢大家帮忙，用了bestbadgood的代码，可以获取到了。
同样谢谢caozhy和patrickkong，谢谢大家。