VB获取本机XP序列号
怎样通过VB来获取本机XP的序列号，各位大侠帮帮忙。
[解决办法]
注册表会读罢
HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\ProductID
[解决办法]
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