寻找已安装软件丢失的产品序列号(CD-KEY)

Option Explicit
 
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
 
Class RegistryItem
  Public ValueName
  Public Value
  Public ValueType
End Class
 
Class WinInfo
  Private strComputer
  Private Registry
  Private OriginalSnap
  Private PendingChanges
  Private strKeyPath
 
  Private Sub Class_Initialize()
    strComputer = "."
    strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
 
    Set Registry = GetObject(_
      "winmgmts:{impersonationLevel=impersonate}!\\" &_
      strComputer & "\root\default:StdRegProv")
 
    Set OriginalSnap = WScript.CreateObject("Scripting.Dictionary")
    Set PendingChanges = WScript.CreateObject("Scripting.Dictionary")
  End Sub
 
  Private Sub Class_Terminate()
    PendingChanges.RemoveAll
    OriginalSnap.RemoveAll
    Set PendingChanges = Nothing
    Set OriginalSnap = Nothing
    Set Registry = Nothing
  End Sub
 
  ' 解码序列号，貌似Win2008 Server R2下解码不正确
  ' parseProductId函数来自elffin ( http://hi.baidu.com/elffin )
  Private Function parseProductId(rpk)
    Const rpkOffset=52
    Dim dwAccumulator, szPossibleChars
    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
      parseProductId=mid(szPossibleChars,dwAccumulator+1,1) & parseProductId
      If (((29-i) Mod 6)=0) And (i<>-1) Then
        i=i-1
        parseProductId="-"&parseProductId
      End If
    Loop While i>=0 'Goto Rep1
  End Function
 
  Private Function parseLicenseInfo(arrBinaryDigits)
    Dim i
    For i = lBound(arrBinaryDigits) to uBound(arrBinaryDigits)
      parseLicenseInfo = parseLicenseInfo & " " & Hex(arrBinaryDigits(i))
    Next
    parseLicenseInfo = Trim(parseLicenseInfo)
  End Function
 
  Public Function getKeyCollection()
    getKeyCollection = OriginalSnap.Keys
  End Function
 
  Public Function getCount()
    getCount = OriginalSnap.Count
  End Function
 
  Public Function getItem(ByVal sName)
    If OriginalSnap.Exists(sName) Then
      Set getItem = OriginalSnap.Item(sName)
    End If
  End Function
 
  Private Function parseInstallDate(lngValue)
  parseInstallDate = DateAdd("s", lngValue, "01/01/1970 00:00:00")
  End Function
 
  Public Function getItemValue(ByVal sName)
    If OriginalSnap.Exists(sName) Then
      getItemValue = OriginalSnap.Item(sName).Value
      Select Case sName
      Case "DigitalProductId","DigitalProductId4"
        getItemValue = parseProductId(getItemValue)
      Case "LicenseInfo"
        getItemValue = parseLicenseInfo(getItemValue)
      Case "InstallDate"
        getItemValue = parseInstallDate(getItemValue)
      End Select
    End If
  End Function
 
  Public Function getItemType(ByVal sName)
    If OriginalSnap.Exists(sName) Then
      getItemType = OriginalSnap.Item(sName).ValueType
    End If
  End Function
 
  ' 加载设置
  Public Function load()
    Dim item, strValue
    Dim i, arrValueNames, arrValueTypes
    Registry.EnumValues HKEY_LOCAL_MACHINE, strKeyPath,_
      arrValueNames, arrValueTypes
 
    For i=0 To UBound(arrValueNames)
      Set item = New RegistryItem
        item.ValueName = arrValueNames(i)
        item.ValueType = arrValueTypes(i)
 
        Select Case arrValueTypes(i)
          Case REG_SZ
            Registry.GetStringValue HKEY_LOCAL_MACHINE,_
              strKeyPath,_
              arrValueNames(i),_
              strValue
          Case REG_EXPAND_SZ
            Registry.GetExpandedStringValue HKEY_LOCAL_MACHINE,_
              strKeyPath,_
              arrValueNames(i),_
              strValue
          Case REG_BINARY
            Registry.GetBinaryValue HKEY_LOCAL_MACHINE,_
              strKeyPath,_
              arrValueNames(i),_
              strValue
          Case REG_DWORD
            Registry.GetDWORDValue HKEY_LOCAL_MACHINE,_
              strKeyPath,_
              arrValueNames(i),_
              strValue
          Case REG_MULTI_SZ
            Registry.GetMultiStringValue HKEY_LOCAL_MACHINE,_
              strKeyPath,_
              arrValueNames(i),_
              strValue
        End Select
        item.Value = strValue
        OriginalSnap.Add arrValueNames(i), item
      Set item = Nothing
    Next
  End Function
 
  ' 保存设置开始，尚未实现！
  Public Function setItem(ByVal sName, ByVal sValue)
    If OriginalSnap.Exists(sName) Then
 
    End If
  End Function
 
  Public Function setItemType(ByVal sName, ByVal sValue)
 
  End Function
 
  Public Function save()
 
  End Function
  ' 保存设置结束
End Class
 
Function VBMain()
  ON ERROR RESUME NEXT
  Dim Info, Keys
  Set Info = New WinInfo
  Info.load
 
  Keys = Info.getKeyCollection
 
  Dim i, s
  For i = 0 To Info.getCount - 1
      s = s & Keys(i) & " = " & Info.getItemValue(Keys(i)) & vbCrLf
  Next
  MsgBox s
  Set Info = Nothing
 
  If Err Then Err.Clear
End Function
 
Call WScript.Quit(VBMain)