Jose
(Seasoned Scripter)
2005-06-23 11:59 PM
Cd Key lookup.

Korgers:
I am looking after the Cd Key number placed in the XP sticker that is used for activation, ussually you need a 3rd party tool such as:

http://www.product-key.com/
http://www.magicaljellybean.com/keyfinder.shtml

In wich best practice with Kix would be:
http://www.winkeyfinder.com
But it is still 3rd party.

Maybe someone have solved only using Kix.

Thanks.


note:
Win32_WindowsProductActivation ProductID brings only the OEM itself.


NTDOCAdministrator
(KiX Master)
2005-06-24 02:29 AM
Re: Cd Key lookup.

Jose,

Well I hope you're not up to something that might get you into trouble, that said... here are some links you may find valuable.

This site here has presented technical information on the method used.
Licenturion - Fully Licensed GmbH, Rudower Chaussee 29, 12489 Berlin, Germany

How to change the Windows XP Product Activation Key Code

Unlocking WinXP's setupp.ini

How to change the Volume Licensing product key on a Windows XP SP1-based computer

XP Serial Change

Windows XP Prompts You to Re-activate After You Restore Your Computer

CD Key Reader

RockXP


Jose
(Seasoned Scripter)
2005-06-24 03:39 AM
Re: Cd Key lookup.

Thanks for the tips DOC.
I´ll take a look at thos links .

I am not after something illegal, just wanna cross the information in the stickers with the ones already registered cause there have been some problems while activating XP´s in an untidy way, FE not sticking the number to the PC.

BTW jlo?
I was wondering if your KixBin can read and translate this value?
Code:
  
$ToKixBin=ReadValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\", "DigitalProductId")


Its something like this:
a40000000300000035353639302d4f454d2d303035303133352d34323
63836002d0000004132322d303030303100000000000000bcc3c33bfe
e41d444fd346478197030000000000d89701418485080002000000000
000000000000000000000000000000000000033373232310000000000
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
00000000000000000000000000000000000a506bfe4a4000000030000
0035353639302d4f454d2d303035303133352d3432363836002d00000
04132322d303030303100000000000000bcc3c33bfee41d444fd34647
8197030000000000d8970141848508000200000000000000000000000
000000000000000000000003337323231000000000000007b180000b3
3d8260fe000000c01f000000000000000000000000000000000000000
000000000000000000000a506bfe4a40000000300000035353639302d
4f454d2d303035303133352d3432363836002d0000004132322d30303
0303100000000000000bcc3c33bfee41d444fd3464781970300000000
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
0000000003337323231000000000000007b180000b33d8260fe000000
c01f00000000000000000000000000000000000000000000000000000
0000000a506bfe4

I have been trying but cannot do it, how about it?


Vincent
(Fresh Scripter)
2005-06-24 03:47 AM
Re: Cd Key lookup.

Being able to do this from Kixtart during the login script would be very useful. We haven't been very diligent in keeping track of the Office 2003 activation code that is associated with the Office installation on a PC.

Being able to automate collecting this information with Kixtart help immensely when we have to reload PCs and therefor Office.

Has anything done anything like this with Kixtart?

V/


Jose
(Seasoned Scripter)
2005-06-24 05:53 AM
Re: Cd Key lookup.

I see the need towards pure admin soltion to prevent certain me$.$.$.$.up´s.......causing dangerous harm to owrselfs. je je je.

Althoght there is a Microsoft´s way of doing it, as DOC pointed above, we are in peace.


Vincent
(Fresh Scripter)
2005-06-24 10:08 PM
Re: Cd Key lookup.


I found a program called ProduKey that will extract the Windows and Office activation codes to a text file via the command line. I am now calling this program from Kixtart to track our product keys.

V/


NTDOCAdministrator
(KiX Master)
2005-06-25 01:13 AM
Re: Cd Key lookup.

My guess would be the one from the link above which is from the guys who helped MS come up with this scheme

Perhaps a link and further info from you would be nice.

 


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 03:00 AM
Re: Cd Key lookup.

k, for the key jose gave, this snippet should give you a cdKey:
Code:

$ToKixBin=ReadValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\", "DigitalProductId")
for $=17 to 61 step 2
$cdKey = $cdKey + "" + chr(val("&"+substr($ToKixBin,$,2)))
next
$cdKey ?
get $



AllenAdministrator
(KiX Supporter)
2005-06-27 03:47 AM
Re: Cd Key lookup.

Tried your code, and it does produce the key that shows up on the General Tab in System Properties... but Jose was looking for the...

Quote:

...Cd Key number placed in the XP sticker that is used for activation




The one he is looking for is a 25 character alpha-numeric code.


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 04:08 AM
Re: Cd Key lookup.

ja, realized that myself too...
and started searching for it in this value.
it's there.
screwing with the bytearray gives weirdly different values.
I even suspected, it could be base36()
but no, maybe base32.
anyways, not interested enough to go on with searching the correct "encryption" algorithm.


AllenAdministrator
(KiX Supporter)
2005-06-27 04:27 AM
Re: Cd Key lookup.

Would this be of any use?

Windows or Office Product Key Retrieval

or
Inside Windows Product Activation


NTDOCAdministrator
(KiX Master)
2005-06-27 05:04 AM
Re: Cd Key lookup.

The first link I provided is the Company that worked on it for Microsoft. Which is also referenced in your 2nd link Al. I'm sure that with the help of KiXbinary it could be done, but still a time consuming task to digest all the information and come up with solid working KiXtart code.
 


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 11:57 AM
Re: Cd Key lookup.

like said to jose, no, I don't see any reason there is need for kixBinary.
kixBinary is merely a provider, just like your readvalue(), it won't crack stuff for you.


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 12:29 PM
Re: Cd Key lookup.

hmm...
the delphi code looks ok otherwise but...
if I read it right, it gets the first 15 bytes of the dword value.
now, those 15 bytes don't hold the value.
instead, it seems (according to my cracks) that around the middle of the value is the needed data.
why this difference, I do not know.


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 03:52 PM
Re: Cd Key lookup.

or then I'm being fooled.
richie, oh thee byte guru, this looks like something you could have your say in...
dword, is it 8 bytes?


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 04:17 PM
Re: Cd Key lookup.

and then...
shl - shift left.
used in the code with: A shl 8
that means, from the integer a, shift some 8 bytes to left.
well, is there bytes in integer?
even the delphi basics knows to tell that shl shouldn't be used but with binary data


Richard H.Administrator
(KiX Supporter)
2005-06-27 04:52 PM
Re: Cd Key lookup.

Quote:

dword, is it 8 bytes?




No. Fire up "calc" in advanced mode, switch to binary, select DWORD and subtract "1" - now count the "1"s.

Quote:

that means, from the integer a, shift some 8 bytes to left.
well, is there bytes in integer?




No, that's 8 bits.

A simple way of doing an 8 bit shift left is to multiply the number by 256.

For example, 13=1101 in binary.

13 * 256 = 3328, which is 110100000000 in binary - you will see that the 1101 has been shifted 8 bits to the left.


Jose
(Seasoned Scripter)
2005-06-27 07:59 PM
Re: Cd Key lookup.

Thanks very much for the support guys...specially Jooel the challenger man!!.

Myself I have worked out with ProduKey.exe to a txt as Vincent suggested.

I would be happy to help on the issue but I dont have much of a clue on it. Sorry.


LonkeroAdministrator
(KiX Master Guru)
2005-06-27 08:39 PM
Re: Cd Key lookup.

replaced with new reply as the board screwed up the html.

LonkeroAdministrator
(KiX Master Guru)
2005-06-27 09:06 PM
Re: Cd Key lookup.

couldn't get this working but...
it has a "base"
Code:

dim $binString, $binCode, $DecodedKey[24],$i,$j,$KeyChars,$Result

$KeyChars = 'B','C','D','F','G','H','J','K','M','P','Q','R','T','V','W','X','Y','2','3','4','6','7','8','9'
$binString=ucase(ReadValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\", "DigitalProductId")) ;16 bytes
$binCode=""+baseconverter(left($binString,2),16,2)+baseconverter(substr($binString,3,2),16,2)+baseconverter(substr($binString,5,2),16,2)+baseconverter(substr($binString,7,2),16,2)

For $i=24 to 0
$A = 0
For $j=14 to 0 ;we want the first 15 bytes, right?
; $A = (A shl 8) + substr($binCode,$j,1) , not sure about this. shift left but should the resulting number have extra zeros added or not?
$A = $A*256 + baseconverter(substr($binCode,1+$j*8,8),2,10)
; $binCode=left($binCode,$j*8) + baseconverter($A/24,10,2) + substr($binCode,$j*8+9)
$A = $A mod 24
next
$DecodedKey[$i] = $KeyChars[$A]
next

For $i = 0 to 24
$Result = $Result + $DecodedKey[$i]
if (($i + 1) mod 5 = 0) and ($i < 24)
$Result = $Result + '-'
endif
next

$Result ?
"press any-key"
get $

Function BaseConverter($v,$f,$t)
dim $,$e,$y,$n,$x,$z
$=0
$t=$+$t
$f=$+$f
$e=($f>36)|($t>36)|($f<2)|($t<2)
$y=1.
for $n=len($v) to 1 step -1
$x=ASC(UCASE(substr($v,$n,1)))
$z=($x-48-($x>64)*7)
IF ($z<0)|(($x>57)&($x<65))|$e|($z>($f-1))
EXIT 1
ENDIF
$=$y*$z+$
$y=$y*$f
next
$n=""
While $
$x=INT($-(INT($/$t)*$t))
$=($-$x)/$t
$n=CHR($x+48+($x>9)*7)+$n
Loop
$BaseConverter=$n
Endfunction



Jose
(Seasoned Scripter)
2005-06-27 09:25 PM
Re: Cd Key lookup.


Very logical lonkero´s style. je je. Me trying to understand it.


Richard H.Administrator
(KiX Supporter)
2005-06-29 02:08 AM
Re: Cd Key lookup.

Got this far with it:
Code:
Break ON
$=SetOption("WrapAtEOL","ON")

Dim $aiKeyChars[24]
Dim $sProductID
Dim $ilByte
Dim $i

$i=0
For Each $c In Split("B C D F G H J K M P Q R T V W X Y 2 3 4 6 7 8 9")
$aiKeyChars[$i]=Asc($c)
$i=$i+1
Next

$sProductID=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Windows NT\CurrentVersion","DigitalProductID")

Dim $bProductKey[15]
For $i = 52*2-1 To 66*2-1 Step 2
$bProductKey[($i-(52*2-1))/2]=Execute("Exit &"+SubStr($sProductId,$i,2))
Next

;Now we are going to 'base24' decode the Product Key

For $ilByte = 24 To 0 Step -1
;Step through each character in the CD key
$nCur = 0.0

For $i=14 To 0 Step -1
;Step through each byte in the Product Key
$nCur = $nCur * 256 ^ (CInt($bProductKey[$i])& &FF) ; NOTE THE XOR!
$bProductKey[$i] = Int($nCur / 24)
$nCur = $nCur Mod 24
Next

$sCDKey = Chr($aiKeyChars[$nCur]) + $sCDKey
If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
Next
$sCDKey ?

; vim600: sw=4 ts=4 ai fdc=4 fdm=marker



Unfortunately I have to deal with an Exchange 5.5 restore so I'm not going to take it any further - somethings not quite right, either I'm picking up the wrong offset of the math is screwy.

Note the "^" - this resquires 4.50 RC1 which has XOR built in.


AllenAdministrator
(KiX Supporter)
2005-07-03 06:16 AM
Re: Cd Key lookup.

Lonk, Richard... any luck figuring this out?

LonkeroAdministrator
(KiX Master Guru)
2005-07-03 07:20 AM
Re: Cd Key lookup.

nah, been too busy with my video scroll trough that haven't been able to do anything usefull.

CJPinder
(Lurker)
2005-09-08 02:21 PM
Re: Cd Key lookup.

Hi All,

I fixed a couple of things in Richard's code. The working script is below...
Code:

Break ON
$=SetOption("WrapAtEOL","ON")

Dim $aiKeyChars[24]
Dim $sProductID
Dim $ilByte
Dim $i

$i=0
For Each $c In Split("B C D F G H J K M P Q R T V W X Y 2 3 4 6 7 8 9")
$aiKeyChars[$i]=Asc($c)
$i=$i+1
Next

$sProductID=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Windows NT\CurrentVersion","DigitalProductID")

Dim $bProductKey[15]
For $i = 53*2-1 To 67*2-1 Step 2
$bProductKey[($i-(53*2-1))/2]=Execute("Exit &"+SubStr($sProductId,$i,2))
Next

;Now we are going to 'base24' decode the Product Key

For $ilByte = 24 To 0 Step -1
;Step through each character in the CD key
$nCur = 0

For $i=14 To 0 Step -1
;Step through each byte in the Product Key
$nCur = $nCur * 256 ^ $bProductKey[$i] ; NOTE THE XOR!
$bProductKey[$i] = Int($nCur / 24)
$nCur = $nCur Mod 24
Next
$sCDKey = Chr($aiKeyChars[$nCur]) + $sCDKey
If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
Next

$sCDKey ?



I hope that helps.
Regards,
Christian


LonkeroAdministrator
(KiX Master Guru)
2005-09-08 02:31 PM
Re: Cd Key lookup.

you missed the "get $" but otherwise, nice...

thanks.


Richard H.Administrator
(KiX Supporter)
2005-09-08 02:44 PM
Re: Cd Key lookup.

Thanks for finishing that off Christian, the offset count was giving me a headache!

AllenAdministrator
(KiX Supporter)
2005-09-08 04:07 PM
Re: Cd Key lookup.

Very nice! Christian, Richard... Do one of you want to add this to the UDF collection?

CJPinder
(Lurker)
2005-09-08 04:48 PM
Re: Cd Key lookup.

Here's a slightly modified version packaged in a function.
Code:

Break ON
$=SetOption("WrapAtEOL","ON")

function get_product_key ($sProductID)
Dim $aiKeyChars[24]
Dim $ilByte
Dim $i
Dim $bProductKey[15]
Dim $sCDKey

$aiKeyChars = 'B','C','D','F','G','H','J','K','M','P','Q','R','T','V','W','X','Y','2','3','4','6','7','8','9'

for $i = 0 to 14
$bProductKey[$i] = val("&"+substr($sProductID,$i*2+105,2))
next

$sCDKey = ""
For $ilByte = 24 To 0 Step -1
$nCur = 0

For $i=14 To 0 Step -1
$nCur = $nCur * 256 | $bProductKey[$i]
$bProductKey[$i] = Int($nCur / 24)
$nCur = $nCur Mod 24
Next
$sCDKey = $aiKeyChars[$nCur] + $sCDKey
If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
Next
$get_product_key = $sCDKey
endfunction

$dpi=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Windows NT\CurrentVersion","DigitalProductID")
$key = get_product_key($dpi)
? "Windows Product Key: " + $key

? "Press any key..."
get $



Does anyone have any suggestions on the most appropriate name for the function?

Regards,
Christian.


LonkeroAdministrator
(KiX Master Guru)
2005-09-08 05:10 PM
Re: Cd Key lookup.

now...
what product keys this works with?


CJPinder
(Lurker)
2005-09-08 05:50 PM
Re: Cd Key lookup.

It works with Office 2003 and SQL Server 2000, some quick code to do this is shown below. Finding the location of the Office 2003 key is a bit of a hack, there may be a more elegant way. The code would need error checking added before being put in to production use.
Code:

$offkey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\11.0\Registration"
$offkey = $offkey + "\" + EnumKey($offkey,0)
$dpi = ReadValue($offkey, "DigitalProductID")
$key = get_product_key($dpi)
? "Office 2003 Product Key: " + $key

$dpi=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Microsoft SQL Server\80\Registration","DigitalProductID")
$key = get_product_key($dpi)
? "SQL Server 2000 Product Key: " + $key



It probably works with other Microsoft products but I don't have any others installed to try it with.

Regards,
Christian.


LonkeroAdministrator
(KiX Master Guru)
2005-09-08 06:53 PM
Re: Cd Key lookup.

w2k - works.

Chris S.
(MM club member)
2005-09-08 09:28 PM
Re: Cd Key lookup.

Just to golf it down a little...

Code:

Break ON
$=SetOption("WrapAtEOL","ON")

function get_product_key ($sProductID)
Dim $aiKeyChars[24],$bProductKey[15],$ilByte,$i,$sCDKey

$aiKeyChars = Split('B,C,D,F,G,H,J,K,M,P,Q,R,T,V,W,X,Y,2,3,4,6,7,8,9',',')

for $i = 0 to 14
$bProductKey[$i] = val("&"+substr($sProductID,$i*2+105,2))
next

$sCDKey = ""
For $ilByte = 24 To 0 Step -1
$nCur = 0

For $i=14 To 0 Step -1
$nCur = $nCur * 256 | $bProductKey[$i]
$bProductKey[$i] = Int($nCur / 24)
$nCur = $nCur Mod 24
Next
$sCDKey = $aiKeyChars[$nCur] + $sCDKey
If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
Next
$get_product_key = $sCDKey
endfunction

$dpi=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Windows NT\CurrentVersion","DigitalProductID")
$key = get_product_key($dpi)
? "Windows Product Key: " + $key

? "Press any key..."
get $




NTDOCAdministrator
(KiX Master)
2005-09-08 10:19 PM
Re: Cd Key lookup.

Thanks Christian - works well on my system. Thanks for Registering to post this.

Code:

Internet Explorer (appears to be the same as Windows key)
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Registration

Microsoft Office Professional Edition 2003
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\11.0\Registration\{90110409-6000-11D3-8CFE-0150048383C9}

Microsoft Office Visio Professional 2003
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\11.0\Registration\{90510409-6000-11D3-8CFE-0150048383C9}

Windows Product Activation (appears to be the same as Windows key)
HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\WPA\Key-CJ27J3P2XV9J9JCPB4DVT

Windows Product Activation (appears to be the same as Windows key)
HKEY_LOCAL_MACHINE\SYSTEM\WPA\Key-CJ27J3P2XV9J9JCPB4DVT




AllenAdministrator
(KiX Supporter)
2005-09-08 11:05 PM
Re: Cd Key lookup.

I'd like to see the UDF include "known product" registry locations. ie... getproductkey(1) = XP, getproductkey(2) = OfficeXP, etc. But also leave it open to future registry locations that can be typed in like it is now.

But for my use I'll probably only use this for the XP key.


Code:
 
Break ON
$=SetOption("WrapAtEOL","ON")

function GetProductKey (optional $sProductID)
Dim $aiKeyChars[24],$bProductKey[15],$ilByte,$i,$sCDKey
if $sProductID=""
$sProductID=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Windows NT\CurrentVersion","DigitalProductID")
endif
$aiKeyChars = Split('B,C,D,F,G,H,J,K,M,P,Q,R,T,V,W,X,Y,2,3,4,6,7,8,9',',')

for $i = 0 to 14
$bProductKey[$i] = val("&"+substr($sProductID,$i*2+105,2))
next

$sCDKey = ""
For $ilByte = 24 To 0 Step -1
$nCur = 0

For $i=14 To 0 Step -1
$nCur = $nCur * 256 | $bProductKey[$i]
$bProductKey[$i] = Int($nCur / 24)
$nCur = $nCur Mod 24
Next
$sCDKey = $aiKeyChars[$nCur] + $sCDKey
If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
Next
$GetProductKey = $sCDKey
endfunction

;$dpi=ReadValue("HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Windows NT\CurrentVersion","DigitalProductID")
;$key = get_product_key($dpi)
? "Windows Product Key: " + getproductkey()

? "Press any key..."
get $



LonkeroAdministrator
(KiX Master Guru)
2005-09-08 11:11 PM
Re: Cd Key lookup.

well, sadly that's not XP key, but windows' cdkey

AllenAdministrator
(KiX Supporter)
2005-09-08 11:20 PM
Re: Cd Key lookup.

I stand corrected... the Windows XP key, is what I'll use this for

NTDOCAdministrator
(KiX Master)
2005-09-08 11:40 PM
Re: Cd Key lookup.

Well putting a couple of UDFs together we can search for ALL the products and have them output the ProductName and Key something like this

  • Microsoft Office Professional Edition 2003: XY7HB-8K3T4-KWLXC-KCTWW-VKKPM
  • Microsoft Office Visio Professional 2003: M58HJ-B4WW3-6X5MR-G8HD3-XSQSY
  • Microsoft Windows XP: RJTHT-PPKPY-EE7R6-DRGSB-KJMRT



Using the SearchReg() UDF from Kholm
http://www.kixtart.org/ubbthreads/showflat.php?Cat=0&Number=83331

and the updated one from Christian and Golfed by Chris I came up with this.


 
Break On
Dim $SO
$SO=SetOption('Explicit','On')
$SO=SetOption('NoVarsInStrings','On')

Dim $RegArray,$Value,$Product,$Key
$RegArray = SearchReg("HKLM\Software\Microsoft","DigitalProductID",2)
If @Error
'No matching items found' ?
Else
For Each $Value In $RegArray
If $Value
$Product = ReadValue(Join(Split($value,'<=>DigitalProductId'),''),'ProductName')
If $Product
$Key = Get_Product_Key(ReadValue(Join(Split($value,'<=>DigitalProductId'),''), 'DigitalProductID'))
$Product + ': ' + $Key ?
EndIf
EndIf
Next
EndIf

Function SearchReg($Key,$Str,$SrcIn)
Dim $Idx,$vName,$Value,$num,$SubKey,$fArr,$mbr
$SearchReg = ''
$num = 0
$Idx = 0
$vName = EnumValue($Key,$Idx)
Do
$mbr = ''
If $SrcIn & 1
$Value = ReadValue($Key,$vName)
If InStr($Value,$Str)
$mbr = $Key + "<=>" + IIf($vName,$vName,'<Default>')
EndIf
EndIf
If ($SrcIn & 2) And InStr($vName,$Str)
$mbr = $Key + "<=>" + $vName
EndIf
If $mbr
ReDim Preserve $SearchReg[$num]
$SearchReg[$num] = $mbr
$num = $num + 1
EndIf
$Idx = $Idx + 1
$vName = EnumValue($Key,$Idx)
Until @Error
$Idx = 0
$SubKey = EnumKey($Key,$Idx)
While $SubKey
If ($SrcIn & 4) And InStr($SubKey,$Str)
ReDim Preserve $SearchReg[$num]
$SearchReg[$num] = $Key + '\' + $SubKey + "<=><KeyName>"
$num = $num + 1
EndIf
$fArr = SearchReg($Key + "\" + $SubKey,$Str,$SrcIn)
If @Error = 0
For Each $mbr In $fArr
ReDim Preserve $SearchReg[$num]
$SearchReg[$num] = $mbr
$num = $num + 1
Next
EndIf
$Idx = $Idx + 1
$SubKey = EnumKey($Key,$Idx)
Loop
Exit VarType($SearchReg) = 8
EndFunction

Function Get_Product_Key($sProductID)
Dim $aiKeyChars[24],$bProductKey[15],$ilByte,$i,$sCDKey,$nCur
$aiKeyChars = Split('B,C,D,F,G,H,J,K,M,P,Q,R,T,V,W,X,Y,2,3,4,6,7,8,9',',')
For $i = 0 To 14
$bProductKey[$i] = Val("&"+SubStr($sProductID,$i*2+105,2))
Next
$sCDKey = ""
For $ilByte = 24 To 0 Step -1
$nCur = 0
For $i=14 To 0 Step -1
$nCur = $nCur * 256 | $bProductKey[$i]
$bProductKey[$i] = Int($nCur / 24)
$nCur = $nCur Mod 24
Next
$sCDKey = $aiKeyChars[$nCur] + $sCDKey
If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
Next
$Get_Product_Key = $sCDKey
EndFunction

 


LonkeroAdministrator
(KiX Master Guru)
2007-04-23 05:59 PM
Re: Cd Key lookup.

thanks again for this awesome script!

AllenAdministrator
(KiX Supporter)
2011-03-10 06:39 AM
Re: Cd Key lookup.

This needed a little updating for x64 systems and to take in consideration the newer DigitalProductID for Office 2010. I couldn't figure out the Golfed version's math, so I reverted to the original version above.

Office 2010 does not have a ProductID to give you easy way out for the Product Name, so I did the best I could. If someone knows a better way, please update this.

  Dim $RegArray, $RegView, $Value,$Product,$Key, $rc, $Array2,$guid
  $RegView=setoption("WOW64AlternateRegView","On")
  $RegArray = SearchReg("HKLM\Software\Microsoft","DigitalProductID",2)
  if @onwow64
    $Array2 = SearchReg("HKLM\Software\WOW6432NODE\Microsoft","DigitalProductID",2)
    $RegArray=ArrayAdd($RegArray,$Array2)
  endif
  If ubound($RegArray)<0
      ? 'No matching items found'
  Else
    For Each $Value In $RegArray
      If $Value
        $Product = ReadValue(Join(Split($value,'<=>DigitalProductId'),''),'ProductName')
        If $product=""
          $guid="{" + split(split($value,"{")[1],"}")[0] + "}"
          if instr($value,"WOW6432Node")
            $product=readvalue("HKLM\Software\WOW6432Node\Microsoft\Windows\CurrentVersion\Uninstall\" + $guid,"DisplayName")
          else
            $product=readvalue("HKLM\Software\Microsoft\Windows\CurrentVersion\Uninstall\" + $guid,"DisplayName")
          endif
        endif
        If $Product
          $Key = Get_Product_Key(ReadValue(Join(Split($value,'<=>DigitalProductId'),''), 'DigitalProductID'))
            ? $Product + ': ' + $Key 
        EndIf
      EndIf
    Next
  EndIf
  $RegView=setoption("WOW64AlternateRegView",$RegView)


function Get_Product_Key($sproductid)
  Dim $aiKeyChars[24], $ilByte, $i, $iLOffset, $iUOffset, $bProductKey[15], $c, $nCur, $sCDKey
  For Each $c In Split("B C D F G H J K M P Q R T V W X Y 2 3 4 6 7 8 9")
    $aiKeyChars[$i]=Asc($c)
    $i=$i+1
  Next
  if len($sProductID)=2544
    $iLOffset=809
    $iUOffset=823
  else
    $iLOffset=53
    $iUOffset=67
  endif
  For $i = $iLOffset*2-1 To $iUOffset*2-1 Step 2
    $bProductKey[($i-($iLOffset*2-1))/2]=Execute("Exit &"+SubStr($sProductId,$i,2))
  Next
  For $ilByte = 24 To 0 Step -1
    $nCur = 0
    For $i=14 To 0 Step -1
      $nCur = $nCur * 256 ^ $bProductKey[$i] ; NOTE THE XOR! 
      $bProductKey[$i] = Int($nCur / 24)
      $nCur = $nCur Mod 24
    Next
    $sCDKey = Chr($aiKeyChars[$nCur]) + $sCDKey
    If $ilByte Mod 5 = 0 And $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
  Next
  $Get_Product_Key=$sCDKey
EndFunction
 
Function SearchReg($Key,$Str,$SrcIn) Dim $Idx,$vName,$Value,$num,$SubKey,$fArr,$mbr $SearchReg = '' $num = 0 $Idx = 0 $vName = EnumValue($Key,$Idx) Do $mbr = '' If $SrcIn & 1 $Value = ReadValue($Key,$vName) If InStr($Value,$Str) $mbr = $Key + "<=>" + IIf($vName,$vName,'<Default>') EndIf EndIf If ($SrcIn & 2) And InStr($vName,$Str) $mbr = $Key + "<=>" + $vName EndIf If $mbr ReDim Preserve $SearchReg[$num] $SearchReg[$num] = $mbr $num = $num + 1 EndIf $Idx = $Idx + 1 $vName = EnumValue($Key,$Idx) Until @Error $Idx = 0 $SubKey = EnumKey($Key,$Idx) While $SubKey If ($SrcIn & 4) And InStr($SubKey,$Str) ReDim Preserve $SearchReg[$num] $SearchReg[$num] = $Key + '\' + $SubKey + "<=><KeyName>" $num = $num + 1 EndIf $fArr = SearchReg($Key + "\" + $SubKey,$Str,$SrcIn) If @Error = 0 For Each $mbr In $fArr ReDim Preserve $SearchReg[$num] $SearchReg[$num] = $mbr $num = $num + 1 Next EndIf $Idx = $Idx + 1 $SubKey = EnumKey($Key,$Idx) Loop Exit VarType($SearchReg) = 8 EndFunction
Function ArrayAdd($Array1, $Array2) ;Returns a new $Array1 Dim $n,$i $n = UBound($Array1) + 1 REDIM PRESERVE $Array1[$n+UBound($Array2)] For $i = 0 to UBound($Array2) $Array1[$n+$i] = $Array2[$i] Next $ArrayAdd = $Array1 EndFunction


NTDOCAdministrator
(KiX Master)
2011-03-13 07:55 AM
Re: Cd Key lookup.

Thanks Allen,

I don't have 2010 on here at the moment but if I remember I'll check it out when I do put it on.


LonkeroAdministrator
(KiX Master Guru)
2013-02-25 11:33 PM
Re: Cd Key lookup.

dont work for win7 64bit.
if someone has more free time than I, could looky at:
http://www.vbforums.com/showthread.php?622160-RESOLVED-DigitalProductId-VB-2010-on-Win7-x64

otherwise I need to come back and take a crack at it.
the original code returns BBBBBBBBBBBBBBBBBB and allen's version returns nothing.


AllenAdministrator
(KiX Supporter)
2013-02-25 11:34 PM
Re: Cd Key lookup.

What version of Office. I've used this repeatedly with XP, Vista, Win7 32bit or 64bit.

Edit... just saw you say Win7 64 itself.... ah... not sure about that...


LonkeroAdministrator
(KiX Master Guru)
2013-02-26 06:39 AM
Re: Cd Key lookup.

yea, works with winXP. but I need win7 \:\)

LonkeroAdministrator
(KiX Master Guru)
2013-02-26 03:26 PM
Re: Cd Key lookup.

it seems to work on win7 too now... at least for some.
that is odd.


AllenAdministrator
(KiX Supporter)
2013-11-29 06:05 PM
Re: Cd Key lookup.

FYI... I have not had time to hunt down the info on how it has changed, but I know that none of the versions posted above work with Office 2013 or Windows 8.

LonkeroAdministrator
(KiX Master Guru)
2013-11-29 06:20 PM
Re: Cd Key lookup.

windows 8?
is someone already using it?

/sent from my home vista laptop/


AllenAdministrator
(KiX Supporter)
2013-12-01 10:03 PM
Re: Cd Key lookup.

If anyone want to take a stab at merging this with the versions above, here is a vbscript that gets the Windows 8 product key. I have yet to find any information on how to get Office 2013 keys.

 Code:
Option Explicit 

Dim strComputer, objWMIService, objItem, Caption, colItems
'Create wscript.shell object 
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)
For Each objItem in colItems
    Caption = objItem.Caption  
Next

If InStr(Caption,"Microsoft Windows 8") > 0  Then 
	Dim objshell,path,DigitalID, Result 
	Set objshell = CreateObject("WScript.Shell")
	'Set registry key path
	Path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
	'Registry key value
	DigitalID = objshell.RegRead(Path & "DigitalProductId")
	Dim ProductName,ProductID,ProductKey,ProductData
	'Get ProductName, ProductID, ProductKey
	ProductName = "Product Name: " & objshell.RegRead(Path & "ProductName")
	ProductID = "Product ID: " & objshell.RegRead(Path & "ProductID")
	ProductKey = "Installed Key: " & ConvertToKey(DigitalID) 
	ProductData = ProductName  & vbNewLine & ProductID  & vbNewLine & ProductKey
	'Show messbox if save to a file 
	If vbYes = MsgBox(ProductData  & vblf & vblf & "Save to a file?", vbYesNo + vbQuestion, "BackUp Windows Key Information") then
	   Save ProductData 
	End If
 
Else
	MsgBox "Please run this script in Windows 8.x"	
End If 


'Convert binary to chars
Function ConvertToKey(Key)
    Const KeyOffset = 52
    Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
    'Check if OS is Windows 8
    isWin8 = (Key(66) \ 6) And 1
    Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
    i = 24
    Maps = "BCDFGHJKMPQRTVWXY2346789"
    Do
       	Current= 0
        j = 14
        Do
           Current = Current* 256
           Current = Key(j + KeyOffset) + Current
           Key(j + KeyOffset) = (Current \ 24)
           Current=Current Mod 24
            j = j -1
        Loop While j >= 0
        i = i -1
        KeyOutput = Mid(Maps,Current+ 1, 1) & KeyOutput
        Last = Current
    Loop While i >= 0 
    keypart1 = Mid(KeyOutput, 2, Last)
    insert = "N"
    KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
    If Last = 0 Then KeyOutput = insert & KeyOutput
    ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)
   
    
End Function
'Save data to a file
Function Save(Data)
    Dim fso, fName, txt,objshell,UserName
    Set objshell = CreateObject("wscript.shell")
    'Get current user name 
    UserName = objshell.ExpandEnvironmentStrings("%UserName%") 
    'Create a text file on desktop 
    fName = "C:\Users\" & UserName & "\Desktop\WindowsKeyInfo.txt"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txt = fso.CreateTextFile(fName)
    txt.Writeline Data
    txt.Close
End Function



LonkeroAdministrator
(KiX Master Guru)
2013-12-02 01:10 AM
Re: Cd Key lookup.

to me the only thing that seems to be valuable from that code are these two lines:
 Code:
    isWin8 = (Key(66) \ 6) And 1
    Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)


so, the last bit is mingled with if windows 8 is the OS.
otherwise the code is exactly the same?


BillBarnard
(Starting to like KiXtart)
2016-04-01 02:26 PM
Re: Cd Key lookup.

Are we certain that the above VB code works?
I have tried it on Windows 10 32-bit and 64-bit and got varying results.
I assume 10 is not that different from 8 as far as the DigitalProductID is concerned.

@dos on Win 10 now gives a value of 10.0, when Win 10 first came out it was 6.2, the same as Win 8.x (I think, as I never got into 8).
Cheers,


Arend_
(MM club member)
2016-04-02 10:42 PM
Re: Cd Key lookup.

I wrote a keyfinder a long(!) time ago in KixForms (the non-.net version) based on some of Lonk's code. Might be of some help.

 Code:
Break On
$System = CreateObject("Kixtart.System")

;KD START

$Form = $System.Form()
$Form.BackColor = 235,233,237
$Form.FontSize = 8,25
$Form.Height = 255
$Form.Text = "KeyFinder"
$Form.Width = 455
$Button1 = $Form.Controls.Button()
$Button1.FontSize = 8,25
$Button1.Height = 33
$Button1.Left = 15
$Button1.Text = "Exit"
$Button1.Top = 165
$Button1.Width = 420
$Button1.OnClick = "$$=$$Form.Hide()"
$ListViewEx1 = $Form.Controls.ListView()
$ListViewEx1.FontSize = 8,25
$ListViewEx1.Height = 134
$ListViewEx1.Left = 15
$ListViewEx1.Top = 15
$ListViewEx1.Width = 420
$=$ListViewEx1.Columns.Add("Product",200)
$=$ListViewEx1.Columns.Add("Key Code",215)

;KD END

$Form.Show
StartScript
While $Form.Visible
   $=Execute($Form.DoEvents())
Loop
Exit 1

Function StartScript()
  $Form.Text = "KeyFinder - SEARCHING!!!!"
  $ListViewEx1.Items.Clear
  $ListViewEx1.Enabled = 0
  $ListViewEx1.BeginUpdate
  Dim $RegArray,$Value,$Product,$Key
  $RegArray = SearchReg("HKLM\Software\Microsoft","DigitalProductID",2)
  If @Error
  'No matching items found' ?
  Else
    For Each $Value In $RegArray
      If $Value
        $Product = ReadValue(Join(Split($value,'<=>DigitalProductId'),''),'ProductName')
        If $Product
          $Key = Get_Product_Key(ReadValue(Join(Split($value,'<=>DigitalProductId'),''), 'DigitalProductID'))
          $Item = $ListViewEx1.Items.Add($Product)
          $Item.SubItems(1).Text = $Key
;         $Product + ': ' + $Key ?
        EndIf
      EndIf
    Next
  EndIf
  $ListViewEx1.EndUpdate
  $ListViewEx1.Enabled = 1
  $Form.Text = "KeyFinder - Finished!"
EndFunction
  
Function SearchReg($Key,$Str,$SrcIn)
  Dim $Idx,$vName,$Value,$num,$SubKey,$fArr,$mbr
  $SearchReg = ''
  $num = 0
  $Idx = 0
  $vName = EnumValue($Key,$Idx)
  Do
    $mbr = ''
    If $SrcIn & 1
    $Value = ReadValue($Key,$vName)
     If InStr($Value,$Str)
       $mbr = $Key + "<=>" + IIf($vName,$vName,'<Default>')
     EndIf
    EndIf
    If ($SrcIn & 2) AND InStr($vName,$Str)
      $mbr = $Key + "<=>" + $vName
    EndIf
    If $mbr
      ReDim Preserve $SearchReg[$num]
      $SearchReg[$num] = $mbr
      $num = $num + 1
    EndIf
    $Idx = $Idx + 1
    $vName = EnumValue($Key,$Idx)
  Until @Error
  $Idx = 0
  $SubKey = EnumKey($Key,$Idx)
  While $SubKey
    If ($SrcIn & 4) AND InStr($SubKey,$Str)
      ReDim Preserve $SearchReg[$num]
      $SearchReg[$num] = $Key + '\' + $SubKey + "<=><KeyName>"
      $num = $num + 1
    EndIf
    $fArr = SearchReg($Key + "\" + $SubKey,$Str,$SrcIn)
    If @Error = 0
      For Each $mbr In $fArr
        ReDim Preserve $SearchReg[$num]
        $SearchReg[$num] = $mbr
        $num = $num + 1
      Next
    EndIf
    $Idx = $Idx + 1
    $SubKey = EnumKey($Key,$Idx)
  Loop
  Exit VarType($SearchReg) = 8
EndFunction
  
Function Get_Product_Key($sProductID)
  Dim $aiKeyChars[24],$bProductKey[15],$ilByte,$i,$sCDKey,$nCur
  $aiKeyChars = Split('B,C,D,F,G,H,J,K,M,P,Q,R,T,V,W,X,Y,2,3,4,6,7,8,9',',')
  For $i = 0 To 14
    $bProductKey[$i] = Val("&"+SubStr($sProductID,$i*2+105,2))
  Next
  $sCDKey = ""
  For $ilByte = 24 To 0 Step -1
    $nCur = 0
    For $i=14 To 0 Step -1
      $nCur = $nCur * 256 | $bProductKey[$i]
      $bProductKey[$i] = Int($nCur / 24)
      $nCur = $nCur Mod 24
    Next
    $sCDKey = $aiKeyChars[$nCur] + $sCDKey
    If $ilByte Mod 5 = 0 AND $ilByte <> 0 $sCDKey = "-" + $sCDKey EndIf
  Next
  $Get_Product_Key = $sCDKey
EndFunction


BillBarnard
(Starting to like KiXtart)
2016-04-06 04:11 PM
Re: Cd Key lookup.

Thanks Arend_ I'll try it out.
Cheers,