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

[解决办法]
注册表会读罢
HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\ProductID
[解决办法]

VB code

Option ExplicitPrivate Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPrivate Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As LongPrivate 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 = 3Private Const HKEY_LOCAL_MACHINE = &H80000002Private 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 = sCDKeyEnd FunctionPrivate Sub Form_Load()    Text1.Text = sGetXPCDKey()End Sub
[解决办法]
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 Explicit

ON ERROR RESUME NEXT
Dim g_strComputer, g_objRegistry, g_EchoString

g_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 If

bRegPKeyFound = 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 If

LineOut ""
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 = True

LineOut "主机名称：" & 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
Next

LineOut ""
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 If

LineOut ""
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 If

g_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
Next

ExitScript 0

  

  


Private Function GetKey(rpk)   'Decode the product key

Const rpkOffset=52
Dim dwAccumulator, szPossibleChars, szProductKey
dim i,j

i=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