用来查看和替换Windows 7 / Vista序列号的脚本

2010-11-27 王健宇转载

方法：将下面代码复制到文本编辑程序（如记事本）中，保存为扩展名vbs的文件（如Win7Key.vbs）。
双击运行即可。代码是明文的，因此绝对可以放心使用。

Win7Key.vbs

内容：

' Win7Key.vbs
' Author: elffin
' Edited from Script by Microsoft and Mark D. MacLachlan
' Version: 0.36
' Function: Display and change product key of Windows 7 (Maybe Vista)
'
' ChangLog:
' - Ver 0.36
' Add UAC process
' Add Option check and prompt
' Add System Version check
' - Ver 0.3
' Add Reigistry information
' Fix a little display bug
' Add More Message when error
' delete the space of new key
' - Ver 0.2
'
' TODO: Is WindowsAppId always same for all Windows ?
'        Retrieve key when registry is clear.
'        Display install date
'
' COMMENT: You can contact me if you find problem.
'          Please keep author and URL information if change the source.

Option Explicit

Dim g_objWMIService, g_strComputer, g_objRegistry, g_EchoString
Dim g_serviceConnected
g_serviceConnected = False

g_strComputer = "."
g_EchoString = ""

' Messages

private const L_MsgInstalledPKey                      = "成功安装产品序列号 %PKEY% !"
private const L_MsgErrorPKey                          = "没有安装Windows序列号, 以下为注册表残留信息。"
private const L_MsgErrorRegPKey                       = "没有在注册表中找到Windows序列号."
private const L_MsgErrorRegPID                        = "没有在注册表中找到Windows产品ID."
Dim L_MsgErrorInstallPKey
L_MsgErrorInstallPKey                                       = "安装序列号 %PKEY% 出现错误!" & _
vbNewLine & "请查看运行权限，并检查序列号是否正确。" & _
vbNewLine & "（可使用Windows 7 PID Key Checker 或 PIDX Check 检查序列号）" & _
vbNewLine & "使用命令 'slui 0x2a 错误代码' 可查看错误详细信息。错误代码: "

Private Const L_MsgErrorOption                        = "参数错误！正确用法 'win7key.vbs [新序列号]' 。更多信息请看 http://hi.baidu.com/elffin "
Private Const L_MsgErrorOSVersion                     = "本程序适用于Windows Vista系列及以后版本，不适用于 %PRODUCTNAME% ！"
private const L_MsgErrorText_8                        = "出现错误！使用命令 'slui 0x2a 错误代码' 可查看错误详细信息。错误代码: "

private const L_MsgLicenseStatusUnlicensed            = "Windows 处于未许可状态"
private const L_MsgLicenseStatusVL                    = "批量激活将于 %ENDDATE% 过期"
private const L_MsgLicenseStatusTBL                   = "基于时间的激活将于 %ENDDATE% 过期"
private const L_MsgLicenseStatusLicensed              = "电脑已经永久激活."
private const L_MsgLicenseStatusInitialGrace          = "初始宽限期将于 %ENDDATE% 到期"
private const L_MsgLicenseStatusAdditionalGrace       = "附加宽限期将于 %ENDDATE% 到期(KMS授权过期或者更换硬件)"
private const L_MsgLicenseStatusNonGenuineGrace       = "非正版宽限期将于 %ENDDATE% 到期"
private const L_MsgLicenseStatusNotification          = "Windows 处于通知模式"
private const L_MsgLicenseStatusExtendedGrace         = "延长宽限期将于 %ENDDATE% 到期"

private const L_MsgLicenseStatusUnknown               = "未知的授权状态"
private const L_MsgLicenseStatusEvalEndData           = "评估结束日期: "
private const L_MsgProductName                        = "系统："
private const L_MsgProductDesc                        = "系统描述: "
private const L_MsgVersion                            = "版本号: "
Private Const L_MsgServicePack                        = "补丁包："
Private Const L_MsgBuild                              = "编译代号："
private const L_MsgCurrentTrustedTime                 = "授权时间: "

private const L_MsgProductKey = "序列号: "
private const L_MsgProductId = "产品ID: "

private const L_MsgUndeterminedPrimaryKey             = "警告: 无法验证Windows当前产品序列号的正确性，请更新到最新补丁包(SP)."
private const L_MsgUndeterminedPrimaryKeyOperation    = "警告: 该操作可能影响超过一个目标授权，请核对结果."
private const L_MsgUndeterminedOperationFormat        = "正在处理以下产品授权 %PRODUCTDESCRIPTION% (%PRODUCTID%)."

' Registry constants
private const HKEY_LOCAL_MACHINE = &H80000002

private const SLKeyPath                               = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\SoftwareProtectionPlatform"
private const SLKeyPath32                             = "SOFTWARE\Wow6432Node\Microsoft\Windows NT\CurrentVersion\SoftwareProtectionPlatform"
Private Const WindowsNTInfoPath                       = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"

' WMI class names
private const ServiceClass                            = "SoftwareLicensingService"
private const ProductClass                            = "SoftwareLicensingProduct"
private const WindowsAppId                            = "55c92734-d682-4d71-983e-d6ec3f16059f"

private const ProductIsPrimarySkuSelectClause         = "ID, ApplicationId, PartialProductKey, LicenseIsAddon, Description, Name"
Private const PartialProductKeyNonNullWhereClause     = "PartialProductKey <> null"
private const EmptyWhereClause                        = ""

private const wbemImpersonationLevelImpersonate = 3
private const wbemAuthenticationLevelPktPrivacy = 6

'If this is the local computer, set everything immediately
If g_strComputer = "." Then
Set g_objWMIService = GetObject("winmgmts:\\" & g_strComputer & "\root\cimv2")
Set g_objRegistry = GetObject("winmgmts:\\" & g_strComputer & "\root\default:StdRegProv")

    If Not g_serviceConnected Then
        g_serviceConnected = True
    End If
End If

Dim strProductVersion, StrProductName, strNewProductKey, unknownOption

g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "CurrentVersion", strProductVersion
g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "ProductName", strProductName

If Int(Left(strProductVersion, 1)) >= 6 Then ' if the major version later than Vista
    unknownOption = True
    If WScript.Arguments.Length = 0 Then
        unknownOption = False
        Call ExecCommand()
    Else
        strNewProductKey = Wscript.arguments.Item(0)

        If WScript.Arguments.Length = 1 Then
            unknownOption = False
            UACShell strNewProductKey
        Else
            If WScript.Arguments.Length = 2 Then
                If WScript.Arguments.Item(1) = "UAC_TAG" Then
                    unknownOption = False
                    InstallProductKey strNewProductKey
                End IF
            End If
        End If
    End If
    if unknownOption = True Then
        LineOut GetResource("L_MsgErrorOption")
    End If
Else
    LineOut Replace(GetResource("L_MsgErrorOSVersion"), "%PRODUCTNAME%", strProductName)
End If

ExitScript 0

Private Sub ExecCommand

Dim DisplayDate
Dim productKeyFound
Dim strProductKey, strProductId, strProductVersion
Dim objProduct, objService
Dim strDescription
Dim iIsPrimaryWindowsSku
Dim strNewProductKey, strTmp
Dim bRegPKeyFound, bRegPIDFound ' value exists in registry

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

For Each objProduct in GetProductCollection(ProductIsPrimarySkuSelectClause & ", " & _
"LicenseStatus, GracePeriodRemaining, EvaluationEndDate, TrustedTime", _
PartialProductKeyNonNullWhereClause)

iIsPrimaryWindowsSku = GetIsPrimaryWindowsSKU(objProduct)

' Warn if this can't be verified as the primary SKU
If (iIsPrimaryWindowsSku = 2) Then
OutputIndeterminateOperationWarning(objProduct)
End If

productKeyFound = True
strDescription = objProduct.Description

LineOut ""
LineOut GetResource("L_MsgProductName") & objProduct.Name
LineOut GetResource("L_MsgProductDesc") & strDescription

g_objRegistry.GetStringValue HKEY_LOCAL_MACHINE, WindowsNTInfoPath, "CSDVersion", strTmp
If Not IsNull(strTmp) Then
LineOut GetResource("L_MsgServicePack") & strTmp
End If
Set objService = GetServiceObject("Version")
LineOut GetResource("L_MsgVersion") & objService.Version
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

LineOut ""
ExpirationDatime(objProduct)

Set displayDate = CreateObject("WBemScripting.SWbemDateTime")
displayDate.Value = objProduct.EvaluationEndDate
If (displayDate.GetFileTime(false) <> 0) Then
LineOut GetResource("L_MsgLicenseStatusEvalEndData") & displayDate.GetVarDate
End If

If productKeyFound <> True Then
    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
End If

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的序列号(适用于Windows 7和Vista系列）."
LineOut "替换操作需要管理员权限，如果提示请允许"

LineOut ""
LineOut ""
LineOut "复制当前序列号或输入新的序列号："

strNewProductKey=InputBox(g_EchoString , "Windows 7 序列号查看替换器", strProductKey)
if strNewProductKey = "" then
Wscript.quit
end if

UACShell strNewProductKey

End Sub

' Call the UAC shell execute when without UAC_TAG
Sub UACShell(strProductKey)

Dim oShell
' Wscript.echo strProductKey
' strProductKey="TQ32R-WFBDM-GFHD2-QGVMH-3P9GC"

strProductKey = replace(strProductKey, Space(1), "") 'delete the space of new key
Set oShell = CreateObject("Shell.Application")
oShell.ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """" & " " & strProductKey & " UAC_TAG", "", "runas", 1
Wscript.Quit(0)
End Sub

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 QuitIfError()
If Err.Number <> 0 Then
LineOut GetResource("L_MsgErrorText_8") & "0x" & Hex(Err.Number)
ExitScript Err.Number
End If
End Sub

Private Sub InstallProductKey(strProductKey)
Dim objService, objProduct
Dim lRet, strDescription, strOutput, strVersion
Dim iIsPrimaryWindowsSku, bIsKMS

bIsKMS = False

On Error Resume Next

set objService = GetServiceObject("Version")
strVersion = objService.Version
objService.InstallProductKey(strProductKey)
' Display error information and quit if install key failed
If Err.Number <> 0 Then
LineOut Replace(GetResource("L_MsgErrorInstallPKey"), "%PKEY%", strProductKey) & "0x" & Hex(Err.Number)
ExitScript Err.Number
End If

' Installing a product key could change Windows licensing state.
' Since the service determines if it can shut down and when is the next start time
' based on the licensing state we should reconsume the licenses here.
objService.RefreshLicenseStatus()

For Each objProduct in GetProductCollection(ProductIsPrimarySkuSelectClause, PartialProductKeyNonNullWhereClause)
strDescription = objProduct.Description

iIsPrimaryWindowsSku = GetIsPrimaryWindowsSKU(objProduct)
If (iIsPrimaryWindowsSku = 2) Then
OutputIndeterminateOperationWarning(objProduct)
End If

If IsKmsServer(strDescription) Then
bIsKMS = True
Exit For
End If
Next

If (bIsKMS = True) Then
    ' Set the KMS version in the registry (64 and 32 bit versions)
    lRet = SetRegistryStr(HKEY_LOCAL_MACHINE, SLKeyPath, "KeyManagementServiceVersion", strVersion)
    If (lRet <> 0) Then
        QuitWithError Hex(lRet)
    End If

    If ExistsRegistryKey(HKEY_LOCAL_MACHINE, SLKeyPath32) Then
        lRet = SetRegistryStr(HKEY_LOCAL_MACHINE, SLKeyPath32, "KeyManagementServiceVersion", strVersion)
        If (lRet <> 0) Then
            QuitWithError Hex(lRet)
        End If
    End If
Else
    ' Clear the KMS version in the registry (64 and 32 bit versions)
    lRet = DeleteRegistryValue(HKEY_LOCAL_MACHINE, SLKeyPath, "KeyManagementServiceVersion")
    If (lRet <> 0 And lRet <> 2 And lRet <> 5) Then
        QuitWithError Hex(lRet)
    End If

    lRet = DeleteRegistryValue(HKEY_LOCAL_MACHINE, SLKeyPath32, "KeyManagementServiceVersion")
    If (lRet <> 0 And lRet <> 2 And lRet <> 5) Then
        QuitWithError Hex(lRet)
    End If
End If

strOutput = Replace(GetResource("L_MsgInstalledPKey"), "%PKEY%", strProductKey)
LineOut strOutput
End Sub

Private Sub ExpirationDatime(objProduct)
Dim ls, graceRemaining, strEnds
Dim strOutput
Dim strDescription, bTBL

ls = objProduct.LicenseStatus
graceRemaining = objProduct.GracePeriodRemaining
strEnds = DateAdd("n", graceRemaining, Now)

strOutput = ""
If ls = 0 Then
strOutput = GetResource("L_MsgLicenseStatusUnlicensed")
End If
If ls = 1 Then
If graceRemaining <> 0 Then

strDescription = objProduct.Description
bTBL = IsTBL(strDescription)

        If bTBL Then
            strOutput = Replace(GetResource("L_MsgLicenseStatusTBL"), "%ENDDATE%", strEnds)
        Else
            strOutput = Replace(GetResource("L_MsgLicenseStatusVL"), "%ENDDATE%", strEnds)
        End If
    Else
        strOutput = GetResource("L_MsgLicenseStatusLicensed")
    End If
End If

If ls = 2 Then
    strOutput = Replace(GetResource("L_MsgLicenseStatusInitialGrace"), "%ENDDATE%", strEnds)
End If
If ls = 3 Then
    strOutput = Replace(GetResource("L_MsgLicenseStatusAdditionalGrace"), "%ENDDATE%", strEnds)
End If
If ls = 4 Then
    strOutput = Replace(GetResource("L_MsgLicenseStatusNonGenuineGrace"), "%ENDDATE%", strEnds)
End If
If ls = 5 Then
    strOutput = GetResource("L_MsgLicenseStatusNotification")
End If
If ls = 6 Then
    strOutput = Replace(GetResource("L_MsgLicenseStatusExtendedGrace"), "%ENDDATE%", strEnds)
End If

If strOutput <> "" Then
Lineout strOutput
End If

End Sub

' Get the resource string with the given name using the built-in default.
Private Function GetResource(name)
GetResource = Eval(name)
End Function

Private Sub ExitScript(retval)
if (g_EchoString <> "") Then
MsgBox g_EchoString, 0, "Windows 7 序列号查看替换器"
End If
WScript.Quit retval
End Sub

' Functions Without Change Below

Private Sub LineOut(str)
g_EchoString = g_EchoString & str & vbNewLine
End Sub

Function GetProductCollection(strSelect, strWhere)
Dim colProducts

On Error Resume Next
If strWhere = EmptyWhereClause Then
    Set colProducts = g_objWMIService.ExecQuery("SELECT " & strSelect & " FROM " & ProductClass)
    QuitIfError()
Else
    Set colProducts = g_objWMIService.ExecQuery("SELECT " & strSelect & " FROM " & ProductClass & " WHERE " & strWhere)
    QuitIfError()
End If

set GetProductCollection = colProducts
End Function

Private Sub OutputIndeterminateOperationWarning(objProduct)
Dim strOutput

LineOut GetResource("L_MsgUndeterminedPrimaryKeyOperation")
strOutput = Replace(GetResource("L_MsgUndeterminedOperationFormat"), "%PRODUCTDESCRIPTION%", objProduct.Description)
strOutput = Replace(strOutput, "%PRODUCTID%", objProduct.ID)
LineOut strOutput
End Sub

Function GetIsPrimaryWindowsSKU(objProduct)
Dim iPrimarySku
Dim bIsAddOn

'Assume this is not the primary SKU
iPrimarySku = 0
'Verify the license is for Windows, that it has a partial key, and that
If (LCase(objProduct.ApplicationId) = WindowsAppId And objProduct.PartialProductKey <> "") Then
    'If we can get verify the AddOn property then we can be certain
On Error Resume Next
bIsAddOn = objProduct.LicenseIsAddon
If Err.Number = 0 Then
    If bIsAddOn = true Then
        iPrimarySku = 0
    Else
        iPrimarySku = 1
    End If
Else
    'If we can not get the AddOn property then we assume this is a previous version
    'and we return a value of Uncertain, unless we can prove otherwise
    If (IsKmsClient(objProduct.Description) Or IsKmsServer(objProduct.Description)) Then
        'If the description is KMS related, we can be certain that this is a primary SKU
        iPrimarySku = 1
    Else
        'Indeterminate since the property was missing and we can't verify KMS
        iPrimarySku = 2
    End If
End If
End If
GetIsPrimaryWindowsSKU = iPrimarySku
End Function

Private Function IsKmsClient(strDescription)
If InStr(strDescription, "VOLUME_KMSCLIENT") > 0 Then
IsKmsClient = True
Else
IsKmsClient = False
End If
End Function

Private Function IsKmsServer(strDescription)
If IsKmsClient(strDescription) Then
    IsKmsServer = False
Else
    If InStr(strDescription, "VOLUME_KMS") > 0 Then
        IsKmsServer = True
    Else
        IsKmsServer = False
    End If
End If
End Function

Private Function SetRegistryStr(hKey, strKeyPath, strValueName, strValue)
SetRegistryStr = g_objRegistry.SetStringValue(hKey, strKeyPath, strValueName, strValue)
End Function

Private Function DeleteRegistryValue(hKey, strKeyPath, strValueName)
DeleteRegistryValue = g_objRegistry.DeleteValue(hKey, strKeyPath, strValueName)
End Function

Private Function ExistsRegistryKey(hKey, strKeyPath)
Dim bGranted
Dim lRet

' Check for KEY_QUERY_VALUE for this key
lRet = g_objRegistry.CheckAccess(hKey, strKeyPath, 1, bGranted)

' Ignore real access rights, just look for existence of the key
If lRet<>2 Then
ExistsRegistryKey = True
Else
ExistsRegistryKey = False
End If
End Function

Function GetServiceObject(strQuery)
Dim objService
Dim colServices

On Error Resume Next
Set colServices = g_objWMIService.ExecQuery("SELECT " & strQuery & " FROM " & ServiceClass)
QuitIfError()

For each objService in colServices
QuitIfError()
Exit For
Next

set GetServiceObject = objService
End Function

标签: 替换Win7序列号脚本