[Ozzyguy]

Glenn9999, on 15 March 2010 - 12:25 AM, said:

Ozzyguy, on 14 March 2010 - 09:40 PM, said:

Substituting Office 2010 location returns an error "Error reading registry key"

If anyone with delphi knowledge would mind checking it out, id be most happy.

I don't have Office 2010, so I don't have a way to test (but I would love to, I would like a good implementation of this in Delphi I know works). But I can look at the code and see what I see.

It appears from the script posted by Cluberti that you need to iterate through all the keys on the main path and then check the key from there. It appears you're just taking a full path and going straight into checking for the value itself, and not checking the branch for existence. Duplicate what is happening here and you should have better results.

Dim strKey, subkey, arrSubkeys2, strOfficeKey, strValue
strKey = "SOFTWARE\Microsoft\Office\14.0\Registration"

ScriptHelper.Registry.EnumKey HKEY_LOCAL_MACHINE, strKey, arrSubkeys2
If IsNull(arrSubkeys2) Then
    'Office 2010 not installed, skip it
    arrSubKeys(4,1) = ""
Else
    For Each subkey In arrSubkeys2
        ScriptHelper.Registry.GetBinaryValue HKEY_LOCAL_MACHINE, strKey & "\" & subkey, SEARCH_KEY, strValue
        If IsNull(strValue) Then
            strOfficeKey = ""
        Else
            strOfficeKey = strKey & "\" & subkey
            arrSubKeys(4,1) = strOfficeKey
        End If
    Next
End If

Thanks for your reply mate.

Yes im using my sub key branch at the moment just to test.

But, the algorithm either just doesnt work Office 2010 , or the location of the key has changed, ie the start offset (34H) and 15 byte length, which would return the Key read error.

My mate is the real programmer here, im just searching for some info on the 2010 DigitalProductID, as we have tried everything, and cant get the key to be displayed.

Every other Windows build, and office version is catered for, except this one.

2010 has us stumped at present.

[gunsmokingman]

This is how I do it in Vb.net

Quote

    '-> Reg Key Varible
    Dim RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\"

Quote

    Dim MsKeys() As String = { _
    "  Operating System Key  " & ARW & RegKey & "Windows NT\CurrentVersion", _
    "  Office 14 2010 Key    " & ARW & RegKey & "Office\14.0\Registration\{10140000-0011-0000-1000-0000000FF1CE}", _
    "  Office 12 2007 Key    " & ARW & RegKey & "Office\12.0\Registration", _
    "  Office 11 2003 Key    " & ARW & RegKey & "Office\11.0\Registration", _
    "  Office 10 XP Key      " & ARW & RegKey & "Office\10.0\Registration"}

Quote

    '-> Varible Used To Collect Various Microsoft Product Keys
    Dim TxtVar1
    Private Sub ListMSKeys()
        For Each K In MsKeys
            Dim Z1 = Split(K, ARW)
            Dim A1 = Z1(1) & DigProID
            Try
                GetKey(Act.RegRead(A1))
                TxtVar1 = TxtVar1 & Z1(0) & ARW & GetKey(Act.RegRead(A1)) & vbCrLf
            Catch ex As Exception
            End Try
        Next
        TextBox1.Text = TextBox1.Text & Lne & vB & TxtVar1
    End Sub

[CoffeeFiend]

Glenn9999, on 15 March 2010 - 12:25 AM, said:

It appears from the script posted by Cluberti that you need to iterate through all the keys on the main path and then check the key from there

That's not a MS Office 2010-specific thing. Even for older versions of Office (including 2003 and 2007) you must do this, as the path (GUID) changes with the language, SKU, service pack, etc. There's just no way around enumerating the subkeys (at least, to properly do it). And it's not uncommon that there are more than one subkey containing a DigitalProductID as well (e.g. for visio or the visual studio web authoring component).

And don't forget that with x64 versions of Windows, you also have to take into account reading from Wow6432Node or not (using KEY_WOW64_64KEY in your RegOpenKeyEx call; obviously you must check for a x64 OS first), especially since there is now a x64 version of Office 2010 which writes outside of it.

Also, I believe versions of MS Office activated using MAK keys (or was it KMS?) don't store keys that way (you'll just read something invalid). I haven't tested this very much though.

MS Office 2010 apps (and a few others) indeed use a new type of DigitalProductID4 which is a little bit different. I figured I'd finally share some of the infos (although it's still subject to change until it RTMs): to decode those, you have to change your offset from 52 to 0x328 (obviously you need a bigger buffer to hold the new larger DigitalProductId) and then decode it the old way. Getting the "edition" of the suite can be tricky (I don't use the registry for this) as ProductName isn't always there.

Sorry, I'm not sharing my code It's not Delphi or VB either ways.

[Ozzyguy]

Thanks for the heads up on the offset info, thats what i was looking for mate, and, in fact all ill need. Excellent.

Yes, we have all other Os'es and platforms covered. The offset info was what had us beat ill say mate.

Will try that out in my existing code, and report back....again...Many thanks...

[Ozzyguy]

@ CoffeeFiend.

Mate, our lil app now works like a charm, due to the proper offset being used. Fantastic.

We have been able to determine the byte size of the new key, and display it correctly.

Do ya have any idea where MAK keys are stored ? I know you said you havent researched it much, but would be nice to be able to detect their presence also.

Anyways mate, thanks heaps for the assistance.

[markdmac]

I found this forum while trying to resolve an issue with my own VBScript that uses the same GetKey function listed in the source code of this tool. I have found that this function does not work on x64 systems. In fact you can't use VBScript to read the DigitalProductID on an x64 system.

I switched to using WMI to get the OS.SerialNumber and that works great, however when I pass this information on to the function it errors out. I am wondering if anyone knows why that would be the case. The function works fine on x86 systems and I don't understand why the conversion would no longer work.

In testing the above tool I have found it too does not display the original CD Key as reported. Anyone have any ideas?

Here is my vbscript:

'==========================================================================
' NAME: GetCDKeyandSerialNumber.vbs
'==========================================================================
Set WshShell = CreateObject("wscript.Shell")
Set env = WshShell.environment("Process")
strComputer = env.Item("Computername")
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)
For Each objItem in colItems
    report = report &  "Original CD Key:"& GetKey(objItem.SerialNumber) & vbCrLf
    report = report &  "SerialNumber: " & objItem.SerialNumber & vbCrLf
Next
MsgBox report
Function GetKey(rpk)
	Const rpkOffset=52: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

This post has been edited by gunsmokingman: 20 March 2010 - 11:36 AM
Reason for edit: Added Code Tags

[gunsmokingman]

I just tried this script on Win7 x64 and it reports the correct Key.

Quote

 Dim Act :Set Act = CreateObject("WScript.Shell")
  MsgBox GetKey(Act.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId"))
   Function GetKey(rpk)
    Const rpkOffset=52:i=28
    szPossibleChars="BCDFGHJKMPQRTVWXY2346789"
    Do
     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
    GetKey=szProductKey
   End Function

If you are going to use WMI to read the registry you should read This Link

[CoffeeFiend]

markdmac, on 20 March 2010 - 09:57 AM, said:

Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)

You have to remove ",,48" from this for it to work (otherwise colItems can't even be evaluated, so there is nothing to pass to the GetKey function)

However, the SerialNumber property of that WMI class returns the ProductId, NOT the DigitalProductId so it won't work regardless (you can't "decode" that)

[gunsmokingman]

I have tested this on Windows 7 x64 and it works. This is for people who want a simple script that gets the OS key, install date, last boot, system uptime.
Save As Oskey.vbs

Quote

Option Explicit
 Dim Act :Set Act = CreateObject("WScript.Shell")
 Dim Tme :Set Tme = CreateObject("WbemScripting.SWbemDateTime")
 Dim Wmi :Set Wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
 Dim Obj
 Dim Id, It, Ky, L1, Ld, Lt, T1, Ut, Vt
 Vt = vbTab 
 Ky = " Sys Install Key    " & Vt & GetKey(Act.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId"))
    For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem") 
     Tme.Value = Obj.InstallDate
      T1 = Split(Tme.GetVarDate, " ")
      Id = " Sys Install Date   " & Vt & MonthName(Tme.Month) & ", " & WeekdayName(Weekday(Tme.GetVarDate)) & " " & Tme.Day & " " & Tme.Year
      It = " Sys Install Time   " & Vt & T1(1) & " " & T1(2)
     Tme.Value = Obj.LastBootUpTime
      T1 = Split(Tme.GetVarDate, " ")
      Ld = " Sys LastBoot Date  " & Vt & MonthName(Tme.Month) & ", " & WeekdayName(Weekday(Tme.GetVarDate)) & " " & Tme.Day & " " & Tme.Year
      Lt = " Sys LastBoot Time  " & Vt & T1(1) & " " & T1(2)
      L1 = Tme.GetVarDate
     If DateDiff("h", L1, Now) <= 1 Then Ut = " Sys Uptime Minutes " & Vt & DateDiff("n", L1, Now)
     If DateDiff("h", L1, Now) >= 2 Then Ut = " Sys Uptime Hours   " & Vt & DateDiff("h", L1, Now)
    Next
    Dim Info :Info = Ky & vbCrLf & Id & vbCrLf & It & vbCrLf & Ld & vbCrLf & Lt & vbCrLf & Ut     
    If MsgBox(Info & vbCrLf & vbCrLf &  " Would You Like To Save This Information To A Text File?", 4132,"Save Information") = 6 Then 
     Dim Fso, Ts, Tx 
      Set Fso = CreateObject("Scripting.FileSystemObject")
      Tx = Act.SpecialFolders("Desktop") & "\" & Act.ExpandEnvironmentStrings("%ComputerName%") & "_BasicInfo.txt"
      Set Ts = Fso.CreateTextFile(Tx)
      Ts.WriteLine Info
      Ts.Close
      Act.Run(Chr(34) & Tx & Chr(34)),1,True
    End If 
   Function GetKey(rpk)
    Dim i, j, DwAcum,ProKey,SzPosChar
    Const rpkOffset=52:i=28
    SzPosChar="BCDFGHJKMPQRTVWXY2346789"
    Do
     DwAcum=0 : j=14
     Do
      DwAcum=DwAcum*256
      DwAcum=rpk(j+rpkOffset)+DwAcum
      rpk(j+rpkOffset)=(DwAcum\24) and 255
      DwAcum=DwAcum Mod 24
      j=j-1
    Loop While j>=0
       i=i-1 : ProKey=mid(SzPosChar,DwAcum+1,1)&ProKey
      If (((29-i) Mod 6)=0) And (i<>-1) Then 
       i=i-1 : ProKey="-"&ProKey
      End If
     Loop While i>=0
    GetKey=ProKey
   End Function

[Yzöwl]

gunsmokingman, on 20 March 2010 - 04:26 PM, said:

I have tested this on Windows 7 x64 and it works. This is for people who want a simple script that gets the OS key, install date, last boot, system uptime.
Save As Oskey.vbs

This is the result on both Vista x86 and Xp x86

[gunsmokingman]

Thanks Yzöwl
Here is the line that is causing problems

Quote

      It = " Sys Install Time   " & Vt & T1(1) & " " & T1(2)

Which means that it might fail on this line also

Quote

      Lt = " Sys LastBoot Time  " & Vt & T1(1) & " " & T1(2)

Could you run this script and post it results and also change this to test both
Test One

     
     Tme.Value = Obj.InstallDate
     For Each Col In Split(Tme.GetVarDate, " ")

Test Two

     Tme.Value = Obj.LastBootUpTime
     For Each Col In Split(Tme.GetVarDate, " ")

Quote

 Dim Act :Set Act = CreateObject("WScript.Shell")
 Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")
 Dim Tme :Set Tme = CreateObject("WbemScripting.SWbemDateTime")
 Dim Wmi :Set Wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
 Dim C1, Col, Obj, Var, Ts, Tx
 C1 = 0
    For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem") 
     Tme.Value = Obj.InstallDate
     For Each Col In Split(Tme.GetVarDate, " ")
      Var = Var & vbCrLf & C1 & " : " & Col
      C1 = C1 + 1
     Next 
    Next 
  Tx = Act.SpecialFolders("Desktop") & "\TestOutput.txt" 
  Set Ts = Fso.CreateTextFile(Tx)
   Ts.WriteLine Var
   Ts.Close
   Act.Run(Chr(34) & Tx & Chr(34)),1,True
  Fso.DeleteFile(Tx),True

[spriditis]

It fails because not everyone uses US regional settings:
For me GetVarDate returns data in format "yyyy.MM.dd. HH:mm:ss"

Therefore there is no T1(2) - either way you should build you date string from seperate parts, not split unknown format. Like:
GetVarDate is ok for output, but to compare values, build it from parts.

Anyhow this will return value as "yyyy.MM.dd. HH:mm:ss" no matter what settings are configured.

dt.Year & "." & Right("00" & dt.Month, 2) & "." & Right("00" & dt.Day, 2) & ". " & _
       Right("00" & dt.Hours, 2) & ":" & Right("00" & dt.Minutes, 2) & _
       ":" & Right("00" & dt.Seconds, 2)

Uptime function - minor modification by me, not sure what was original:

Function TimeSpan(dt1, dt2)
Dim seconds, minutes, hours, days
    If (isDate(dt1) And IsDate(dt2)) = False Then
        TimeSpan = ""
        Exit Function
    End If 

    seconds = Abs(DateDiff("S", dt1, dt2))
    minutes = seconds \ 60
    hours = minutes \ 60
    days = hours \ 24
    hours = hours mod 24
    minutes = minutes mod 60
    seconds = seconds mod 60

    TimeSpan = days & " days " & _
      Right("00" & hours, 2) & "h " & _
      Right("00" & minutes, 2) & "m " & _
      Right("00" & seconds, 2) & "s"
End Function

This post has been edited by spriditis: 22 March 2010 - 12:29 PM

[florydude]

I ported the GetKey() function to a simple VBS script:

' 
'  GetKey.vbs v1.0 by flory
' 
'
'***************************************************************************
'
'
Option Explicit
'Use VbCrLf 
ON ERROR RESUME NEXT

Dim WSHShell, KEY, ID
Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim strResultKey, strResultId

Dim Tme
Set Tme = WScript.CreateObject("WbemScripting.SWbemDateTime")

Dim objWMIService
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")

'-> Text Output Objects
Dim ARW 
ARW = Chr(160) & Chr(187) & Chr(160)

Dim RegKey
RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\"

Dim strProductKey, strProductID, strProductOS
strProductKey = RegKey & "Windows NT\CurrentVersion\DigitalProductId"
strProductID = RegKey & "Windows NT\CurrentVersion\ProductId"

Dim strDefault
strDefault = "ProductId"	

    '-> Get The TimeDate Server Key	
    Function GetKey(ByVal rpk)
        Dim i, j
        Dim dwAccumulator, KeyProductID
        dwAccumulator = ""
		KeyProductID = ""
        Const rpkOffset = 52 : i = 28
        Dim szPossibleChars
        szPossibleChars = "BCDFGHJKMPQRTVWXY2346789"		
        Do
            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 : KeyProductID = Mid(szPossibleChars, dwAccumulator + 1, 1) & KeyProductID
            If (((29 - i) Mod 6) = 0) And (i <> -1) Then
                i = i - 1 : KeyProductID = "-" & KeyProductID
            End If
        Loop While i >= 0
        GetKey = KeyProductID
        KEY = "      " & ARW & KeyProductID
    End Function

if WScript.arguments.count<1 then
    strResultKey = GetKey(WSHShell.RegRead(strProductKey)) 
	strResultId = Left(Replace(WSHShell.RegRead(strProductID),"-",""),8)
	
	MsgBox "ProductKey: " & strResultKey & VbCrLf & "Product PID: " & strResultId, vbinformation, "Windows Install Check"	
else 
    WScript.echo "Correct usage: Cscript GetKey.vbs"
	WScript.quit
end if

I'm wondering how can such function list all key / values from a simple registry key as for example:

strTimeServersKey = RegKey & "Windows\CurrentVersion\DateTime\Servers"

for let's say an array of 6 values
:

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\DateTime\Servers]
@="2"
"1"="time.windows.com"
"2"="time.nist.gov"
"3"="timekeeper.isi.edu"
"4"="usno.pa-x.dec.com"
"5"="tock.usno.navy.mil"
"6"="tick.usno.navy.mil"

Attached File(s)

•  GetKey_vbs.zip (1.02K)
  Number of downloads: 10

This post has been edited by florydude: 11 June 2011 - 11:10 PM

[Sp0iLedBrAt]

Quote

I ported the GetKey() function to a simple VBS script

Works here. You could also attach it as a .vbs file (like other members in this sub-forum do) to avoid possible problems with undesired empty spaces or transfer of lines.

Cheers

[florydude]

Done with the attach. Also worked on how the get the servers list for syncronising the time-date:

' 
' TimeDate Server List Script - ServersList.vbs
' 
'
'***************************************************************************
Option Explicit

Dim WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")

Dim Tme
Set Tme = WScript.CreateObject("WbemScripting.SWbemDateTime")

Dim objWMIService
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")

'-> Text Output Objects
Dim ARW 
ARW = Chr(160) & Chr(187) & Chr(160)

Dim RegKey, strDefault, strList
RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\"

Dim strTimeServersKey
strTimeServersKey = RegKey & "Windows\CurrentVersion\DateTime\Servers"

'-> Read RegistryKey/DefaultValue
Function GetList (strTimeServersKey, strDefault)
	On Error Resume Next
	Dim i,j,k
	Dim Servers
	Servers = " "		
	k = 0
    Do 	
	    k = k + 1	
        WSHShell.RegRead(strTimeServersKey & "\" & k)	
    Loop While err.number = 0
    Err.Clear	
	j = k - 1
	Dim ServersDigit()
    For i = strDefault to j
    Do 
	    i = i + 1	 
        ReDim Preserve ServersDigit(i) 
        ServersDigit(i) = WSHShell.RegRead(strTimeServersKey & "\" & i)		
		Servers = Servers & VbCrLf & i & ARW & ServersDigit(i)

	Loop While err.number = 0
	Next	
        GetList = Servers 
        strList  = " DateTime Servers List " & ARW & ServersDigit	
End Function  
	
if WScript.arguments.count<1 then
    strList = GetList(strTimeServersKey, 0)	
	MsgBox "Date-Time Servers: " & strList, vbinformation, "DateTime Servers" 
else
	MsgBox "Usage: CScript ServersList.vbs", vbinformation, "DateTime Servers"
	WScript.quit
end if

Can be fixed a little more on how the array is builded etc.

Attached File(s)

•  ServersList.zip (1.16K)
  Number of downloads: 4