PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Get product keys of Windows and Office products PB 5.20

https://www.purebasic.fr/english/viewtopic.php?t=37564

Page 1 of 2

Get product keys of Windows and Office products PB 5.20

Posted: Thu May 28, 2009 1:33 pm
by doctorized
Updated for 5.20+

View Windows and every single Office Product Key separately (as long as separate installation is done for each product).
The code has been updated for PB 5.20 and supports up to Office 2013 with multiple Office product support (in case we have lost the keys).

Code: Select all

Import ""
  GetNativeSystemInfo(*info)
EndImport

Global REG_BINARY.i=3
Procedure.s GetString(hKey.l, strPath.s, strValue.s, RegType.l=2)
;this procedure is reading the registry values when we know 
;exactly what we want to read and where to read
;OnErrorResume()
KeyHand.l:datatype.l:lResult.l
Dim strBuf.b(1):lDataBufSize.l
intZeroPos.l:tempV.l:mm.l
RegOpenKeyEx_(hKey, strPath, 0, $101, @KeyHand)
lResult = RegQueryValueEx_(KeyHand, strValue, 0, @lValueType, 0, @lDataBufSize)
If lDataBufSize > 0
	ReDim strBuf.b(lDataBufSize-1)
EndIf
lResult = RegQueryValueEx_(KeyHand, @strValue, 0, @RegType, @strBuf(), @lDataBufSize)
If lResult = #ERROR_SUCCESS
If lValueType = 4
tempV.l = 0
For i = 0 To lDataBufSize-1
tempV = tempV + (strBuf(i) & $FF) * Pow(16,(2 * i))
Next
ProcedureReturn StrU(tempV,#PB_Long)
EndIf
tmp.s
If RegType = #REG_MULTI_SZ
	For i=0 To lDataBufSize-1
		If strBuf(i)=0
			tmp + " , "
		Else
			tmp+ Chr(strBuf(i))
		EndIf
	Next
	For i=lDataBufSize-1 To 0 Step -1
		If Right(tmp,3)=" , ":tmp = Left(tmp,Len(tmp)-3):EndIf
	Next
	ProcedureReturn tmp + "."
EndIf
For i=0 To lDataBufSize-1
tmp+ Chr(strBuf(i))
Next
ProcedureReturn tmp
EndIf
EndProcedure

Procedure.s ReadReg(ReadKey.l, SubKey.s, ReadValue.s, ValueType.l, LookInSubFolders.l, HelpValue.s, HelpValueRead.s, Array ArrayToRecieveData.b(1), HelpFolder.s="", ReturnPath.l=0)
;this procedure is reading the registry values when we DO NOT know 
;exactly what we want to read and where to read
;OnErrorResume()
RequesySubKey.s: TempStr.s: RLen.l: Result.l
STime.FILETIME: MaxValLen.l: azz.l:tmp.s
MaxValNameLen.l: MaxSubKeyLen.l: MaxSubKeyLen2.l
SubKeys.l: Values.l: hKey.i: i.l
hKey1.l: hKey2.l:SKey.s:SKey2.s
Result = RegOpenKeyEx_(ReadKey, SubKey, 0, #KEY_ALL_ACCESS, @hKey)
If Result <> 0
	RegOpenKeyEx_(ReadKey, SubKey, 0, #KEY_ALL_ACCESS |$100, @hKey)
EndIf
Result = RegQueryInfoKey_(hKey, 0, 0, 0, @SubKeys, @MaxSubKeyLen, 0, @Values, @MaxValNameLen, @MaxValLen, 0, STime)
keynum = SubKeys
For i = 0 To keynum - 1
	TempStr = Space(255)
	RLen = 255
	Result = RegEnumKey_(hKey, i, @TempStr, @RLen)
	SKey = SubKey + "\" + TempStr
	If LookInSubFolders > 0
		For ii=1 To LookInSubFolders
			Result = RegOpenKeyEx_(ReadKey, SKey, 0, $101, @hKey1)
			Result = RegQueryInfoKey_(hKey1, 0, 0, 0, @SubKeys, @MaxSubKeyLen, 0, @Values, @MaxValNameLen, @MaxValLen, 0, STime)
			For iii=0 To SubKeys-1
				TempStr = Space(255): RLen = 255
				Result = RegEnumKey_(hKey1, iii, @TempStr, @RLen)
				SKey2 = SKey + "\" + TempStr
				If RegOpenKeyEx_(ReadKey, SKey2 + "\" + HelpFolder, 0, $101, @hKey2) = #ERROR_SUCCESS
					azz = 1
					RegCloseKey_(hKey2)
					Break
				EndIf
			Next
			If azz = 1
				RegCloseKey_(hKey1)
				RegCloseKey_(hKey)
				ProcedureReturn GetString(ReadKey,SKey2,ReadValue,ValueType)
			EndIf
		Next
	EndIf
	If HelpValue <> ""
		tmpp.s=GetString(ReadKey,SKey,HelpValue,#REG_SZ)
		If FindString(tmpp,HelpValueRead,1) = 0
			Goto ReadNext
		EndIf
	EndIf
	tmp = GetString(ReadKey, SKey, ReadValue,ValueType)
	If tmp<> "" 
		datalen.l;=164
		RegOpenKeyEx_(#HKEY_LOCAL_MACHINE, sKey, 0, $101, @hKey2)
		RegQueryValueEx_(hKey2, "DigitalProductID", 0, @lValueType, 0, @datalen)
		If datalen > 0
			ReDim ArrayToRecieveData.b(datalen-1)
		EndIf
		RegQueryValueEx_(hKey2, @"DigitalProductID", 0, @REG_BINARY, @ArrayToRecieveData(), @datalen)
		Result = RegCloseKey_(hKey2)
		Result = RegCloseKey_(hKey)
		
		If ReturnPath>0
			ProcedureReturn SKey
		Else
			ProcedureReturn tmp
		EndIf
	EndIf
ReadNext:
Next
EndProcedure


Procedure.s IsWin64()
  Protected Info.SYSTEM_INFO
  GetNativeSystemInfo(Info)
  If info\wProcessorArchitecture
    ProcedureReturn "Wow6432Node\"
  EndIf
EndProcedure

Procedure.s DecodeKey(Array KeyData.b(1), DecodeOffset.l)
;The reading Offset is 808 for Office 2010 and 52 for Windows and older Office versions.
Dim  bProductKey.a(14)
For ilByte = DecodeOffset To DecodeOffset + 14
	bProductKey(ilByte - DecodeOffset) = KeyData(ilByte)
Next
For i=0 To 14
	Debug Hex(bProductKey(i))
Next

Dim bKeyChars.b(24)
;Now we are going To 'base24' decode the Product Key
;Possible characters in the CD Key:
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")
nCur.i: sCDKey.s
ilKeyByte.i: ilBit.i
For ilByte = 24 To 0 Step -1
	;Step through each character in the CD key
	nCur = 0
	For ilKeyByte = 14 To 0 Step -1
		;Step through each byte in the Product Key
		nCur = (nCur * 256) ! bProductKey(ilKeyByte)
		bProductKey(ilKeyByte) = Int(nCur / 24)
		nCur = nCur % 24
	Next
	sCDKey = Chr(bKeyChars(nCur)) + sCDKey
	If (ilByte % 5) = 0 And ilByte <> 0 : sCDKey = "-" + sCDKey:EndIf
Next
ProcedureReturn sCDKey
EndProcedure

Procedure.s WindowsKeys(KeyType.l, KeyFix.s, Array DataArray.s(1))
ilByte.l: lDataLen.l = 1270: hKey.l: keyval.s: Dim TempStr.s(66)
Dim bDigitalProductID.b(lDataLen)
;The keytype tell us which key do we need.
;Each office product can be installed separately from the CD (in some cases)
;with its own key so we will take them all, if they exist.
ArrayCount.l=-1
Select KeyType
	Case 0 ;office key
		For i.l = 15 To 14 Step -1
			keyval = "SOFTWARE\" + IsWin64() + "Microsoft\Office\" + Str(i) + ".0\Registration"
			value.s=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",@REG_BINARY,0,"ProductNameNonQualified","Microsoft Office",bDigitalProductID(),"",0)
			If value <>""
				ArrayCount + 1
				If ArraySize(DataArray()) < ArrayCount: ReDim DataArray.s(ArrayCount): EndIf
				DataArray(ArrayCount) = RSet(Str(i),2,"0") + DecodeKey(bDigitalProductID(),52)
			EndIf
		Next
		For i.l = 12 To 1 Step -1
			keyval = "SOFTWARE\" + IsWin64() + "Microsoft\Office\" + Str(i) + ".0\Registration"
			value.s=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",@REG_BINARY,0,"SuiteName","Microsoft Office",bDigitalProductID(),"",0)
			If value <>""
				;Debug value
				ArrayCount + 1
				If ArraySize(DataArray()) < ArrayCount: ReDim DataArray.s(ArrayCount): EndIf
				DataArray(ArrayCount) = RSet(Str(i),2,"0") + DecodeKey(bDigitalProductID(),52)
			EndIf
		Next
		
	Case 1 To 13 ;Products
		For i.l = 15 To 14 Step -1
			keyval = "SOFTWARE\" + IsWin64() + "Microsoft\Office\" + Str(i) + ".0\Registration"
			value.s=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",@REG_BINARY,0,"ProductNameNonQualified","Microsoft Office" + KeyFix,bDigitalProductID(),"",0)
			If value <>""
				;Debug value
				ArrayCount + 1
				If ArraySize(DataArray()) < ArrayCount: ReDim DataArray.s(ArrayCount): EndIf
				DataArray(ArrayCount) = RSet(Str(i),2,"0") + DecodeKey(bDigitalProductID(),52)
			EndIf
		Next
		For i.l = 1 To 12
			keyval = "SOFTWARE\" + IsWin64() + "Microsoft\Office\" + Str(i) + ".0\Registration"
			;"ProductName" is needed to take the key for the correct product
			keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",@REG_BINARY,0,"ProductName","Microsoft Office " + KeyFix,bDigitalProductID(),"",1)
			If keyval <>""
				ArrayCount + 1
				If ArraySize(DataArray()) < ArrayCount: ReDim DataArray.s(ArrayCount): EndIf
				DataArray(ArrayCount) = RSet(Str(i),2,"0") + DecodeKey(bDigitalProductID(),52)
			EndIf
		Next
		FreeArray(bDigitalProductID())
		If ArrayCount = -1: DataArray(0) = "  Not Available": EndIf
EndSelect
EndProcedure

Procedure.s DecodeVersion(dta.l)
	Select dta
		Case 15
			ProcedureReturn "2013"
		Case 14
			ProcedureReturn "2010"
		Case 12
			ProcedureReturn "2007"
		Case 11
			ProcedureReturn "2003"
		Case 10
			ProcedureReturn "XP"
		Case 9
			ProcedureReturn"2000"
		Case 8
			ProcedureReturn"97"
		Case 7
			ProcedureReturn "95"
		Case 0
			ProcedureReturn ""
		Default
			ProcedureReturn Str(dta)
	EndSelect
EndProcedure
;show me results
If OpenWindow(0, 100, 200, 470, 360, "Product Keys", #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget)
	ListIconGadget(0,10,10,450,340,"Product",120,#PB_ListIcon_GridLines|#PB_ListIcon_FullRowSelect)
	AddGadgetColumn(0,1,"Version",80)
	AddGadgetColumn(0,2,"Key",220)
	
	;get the keys
	Dim DatArr.s(1)
	Dim Product.s(14)
	Product(0) = "Office"
	Product(1) = "Access"
	Product(2) = "Excel"
	Product(3) = "Outlook"
	Product(4) = "PowerPoint"
	Product(5) = "Word"
	Product(6) = "FrontPage"
	Product(7) = "InfoPath"
	Product(8) = "Publisher"
	Product(9) = "Visio"
	Product(10) = "OneNote"
	Product(11) = "Project"
	Product(12) = "SharePoint Designer"
	Product(13) = "SharePoint Workspace"
	;windows
	Dim bDigitalProductID.b(164):lDataLen.l = 164
	Select OSVersion() 
		Case #PB_OS_Windows_95, #PB_OS_Windows_98, #PB_OS_Windows_ME
			keyval.s = "SOFTWARE\Microsoft\Windows\CurrentVersion"
		Default
			keyval = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
	EndSelect
	RegOpenKeyEx_(#HKEY_LOCAL_MACHINE, keyval,0, $101, @hKey.i)
	RegQueryValueEx_(hKey, "DigitalProductID", 0, @REG_BINARY, @bDigitalProductID(), @lDataLen)
	Result = RegCloseKey_(hKey)
	DatArr(0) = DecodeKey(bDigitalProductID(),52)
	AddGadgetItem(0,-1,"Windows"+Chr(10)+ReplaceString(GetString(#HKEY_LOCAL_MACHINE,keyval,"ProductName"),"Windows ","")+Chr(10)+DatArr(0))
	;office
	For ii=0 To 13 
		FreeArray(DatArr())
		Dim DatArr.s(1)
		WindowsKeys(ii,Product(ii), DatArr())
		For i=0 To ArraySize(DatArr())
			If DatArr(i) <> ""
				;Debug Val(Left(DatArr(i),2))
				AddGadgetItem(0,-1,Product(ii)+Chr(10)+DecodeVersion(Val(Left(DatArr(i),2)))+Chr(10)+Right(DatArr(i),Len(DatArr(i))-2))
			EndIf
		Next	
		FreeArray(DatArr())
	Next
  Repeat
    EventID = WaitWindowEvent()

    If EventID = #PB_Event_CloseWindow
      Quit = 1
    EndIf

  Until Quit = 1
  
EndIf

Posted: Thu May 28, 2009 3:01 pm
by Rings
can you provide a version thats works under a actual (4.3) version ?
i can't compile the source without lots of compiler-syntax errors.
thx.

Posted: Thu May 28, 2009 3:29 pm
by doctorized
Rings wrote:can you provide a version thats works under a actual (4.3) version ?
i can't compile the source without lots of compiler-syntax errors.
thx.
All my codes are writen with PB 4.20. I haven't downloaded 4.30 yet.
Can you tell me some of the errors to find out what is wrong?

Posted: Thu May 28, 2009 3:44 pm
by dige
Quick'n dirty converted to PB4.31

Code: Select all

; Author: Wicker Man
; Date: May 22 2009
; OS: Windows
; Demo: No
; More codes at: www.geocities.com/kc2000labs/pb/pb.htm

Procedure.s GetString(hKey.l, strPath.s, strValue.s, RegType.l=2)
  ;this procedure is reading the registry values when we know
  ;exactly what we want to read and where to read
  ;OnErrorResume()
  KeyHand.l:datatype.l:lresult.l
  Dim strBuf.b(1):lDataBufSize.l
  intZeroPos.l:tempV.l:mm.l
  r = RegOpenKey_(hKey, strPath, @KeyHand)
  lresult = RegQueryValueEx_(KeyHand, strValue, 0, @lValueType, 0, @lDataBufSize)
  mm=lDataBufSize
  If lDataBufSize > 0
    Redim strBuf.b(lDataBufSize-1)
  EndIf
  lresult = RegQueryValueEx_(KeyHand, @strValue, 0, @RegType, @strBuf(), @lDataBufSize)
  If lresult = #ERROR_SUCCESS
    If lValueType = 4
      tempV.l = 0
      For i = 0 To lDataBufSize-1
        tempV = tempV + (strBuf(i) & $FF) * Pow(16,(2 * i))
      Next
      ProcedureReturn StrU(tempV,#PB_Long)
    EndIf
    tmp.s
    If RegType = #REG_MULTI_SZ
      For i=0 To lDataBufSize-1
        If strBuf(i)=0
          tmp + " , "
        Else
          tmp+ Chr(strBuf(i))
        EndIf
      Next
      For i=lDataBufSize-1 To 0 Step -1
        If Right(tmp,3)=" , ":tmp = Left(tmp,Len(tmp)-3):EndIf
      Next
      ProcedureReturn tmp + "."
    EndIf
    For i=0 To lDataBufSize-1
      tmp+ Chr(strBuf(i))
    Next
    ProcedureReturn tmp
  EndIf
EndProcedure

Procedure.s ReadReg(ReadKey.l, SubKey.s, ReadValue.s, ValueType.l, LookInSubFolders.l, HelpValue.s, HelpValueRead.s, Array ArrayToRecieveData.b(1), HelpFolder.s="", ReturnPath.l=0)
  ;this procedure is reading the registry values when we DO NOT know
  ;exactly what we want to read and where to read
  ;OnErrorResume()
  RequesySubKey.s: TempStr.s: RLen.l: Result.l
  STime.FILETIME: MaxValLen.l: azz.l:tmp.s
  MaxValNameLen.l: MaxSubKeyLen.l: MaxSubKeyLen2.l
  SubKeys.l: Values.l: hKey.l: i.l
  hKey1.l: hKey2.l:SKey.s:SKey2.s
  Result = RegOpenKeyEx_(ReadKey, SubKey, 0, $20019, @hKey)
  Result = RegQueryInfoKey_(hKey, 0, 0, 0, @SubKeys, @MaxSubKeyLen, 0, @Values, @MaxValNameLen, @MaxValLen, 0, STime)
  keynum = SubKeys
  For i = 0 To keynum - 1
    TempStr = Space(255)
    RLen = 255
    Result = RegEnumKey_(hKey, i, @TempStr, @RLen)
    SKey = SubKey + "\" + TempStr
    If LookInSubFolders > 0
      For ii=1 To LookInSubFolders
        Result = RegOpenKeyEx_(ReadKey, SKey, 0, $20019, @hKey1)
        Result = RegQueryInfoKey_(hKey1, 0, 0, 0, @SubKeys, @MaxSubKeyLen, 0, @Values, @MaxValNameLen, @MaxValLen, 0, STime)
        For iii=0 To SubKeys-1
          TempStr = Space(255): RLen = 255
          Result = RegEnumKey_(hKey1, iii, @TempStr, @RLen)
          SKey2 = SKey + "\" + TempStr
          If RegOpenKeyEx_(ReadKey, SKey2 + "\" + HelpFolder, 0, $20019, @hKey2) = #ERROR_SUCCESS
            azz = 1
            RegCloseKey_(hKey2)
            Break
          EndIf
        Next
        If azz = 1
          RegCloseKey_(hKey1)
          RegCloseKey_(hKey)
          ProcedureReturn GetString(ReadKey,SKey2,ReadValue,ValueType)
        EndIf
      Next
    EndIf
    
    If HelpValue <> ""
      tmpp.s=GetString(ReadKey,SKey,HelpValue)
      If FindString(tmpp,HelpValueRead,1) = 0
        Goto ReadNext
      EndIf
    EndIf
    tmp = GetString(ReadKey, SKey, ReadValue,ValueType)
    If tmp<> ""
      datalen.l=164
      RegOpenKey_(#HKEY_LOCAL_MACHINE, sKey, @hKey2)
      RegQueryValueEx_(hKey2, "DigitalProductID", 0, @REG_BINARY, @ArrayToRecieveData(), @datalen)
      Result = RegCloseKey_(hKey2)
      Result = RegCloseKey_(hKey)
      If ReturnPath>0
        ProcedureReturn SKey
      Else
        ProcedureReturn tmp
      EndIf
    EndIf
    ReadNext:
  Next
EndProcedure

Procedure.s WindowsKeys(KeyType.l)
  ilByte.l: lDataLen.l = 164: hKey.l: keyval.s: Dim TempStr.s(66)
  Dim  bProductKey.b(14)
  Dim bDigitalProductID.b(lDataLen)
  ;The keytype tell us which key do we need.
  ;Each office product can be installed separately from the CD
  ;with its own key so we will take them all, if they exist.
  Select KeyType
    Case 1 ;windows key
      Select OSVersion()
        Case #PB_OS_Windows_95, #PB_OS_Windows_98, #PB_OS_Windows_ME
          keyval = "SOFTWARE\Microsoft\Windows\CurrentVersion"
        Default
          keyval = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
      EndSelect
      RegOpenKey_(#HKEY_LOCAL_MACHINE, keyval, @hKey)
      RegQueryValueEx_(hKey, "DigitalProductID", 0, @REG_BINARY, @bDigitalProductID(), @lDataLen)
      Result = RegCloseKey_(hKey)
    Case 2 ;office key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"SuiteName","Microsoft Office",@bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Error: Read Registry (key)": EndIf
    Case 3 ;Access key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        ;"ProductName" is needed to take the key for the correct product
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Access",@bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf;found it
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
    Case 4 ;Excel key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Excel",bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
    Case 5 ;Outlook key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Outlook",bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
    Case 6 ;PowerPoint key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office PowerPoint",bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
    Case 7 ;Word key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Word",bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
    Case 8 ;FrontPage key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office FrontPage",bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
    Case 9 ;InfoPath key
      For i.l = 12 To 1 Step -1
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration"
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office InfoPath",bDigitalProductID(),"",1)
        If keyval <>"": Break: EndIf
      Next
      If keyval="": ProcedureReturn "Not Available": EndIf
  EndSelect
  
  ;Get the Product Key, 15 bytes long, offset by 52 bytes
  For ilByte = 52 To 66
    bProductKey(ilByte - 52) = bDigitalProductID(ilByte)
  Next
  
  Dim bKeyChars.b(24)
  ;Now we are going To 'base24' decode the Product Key
  ;Possible characters in the CD Key:
  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")
  nCur.l: sCDKey.s
  ilKeyByte.l: ilBit.l
  For ilByte = 24 To 0 Step -1
    ;Step through each character in the CD key
    nCur = 0
    For ilKeyByte = 14 To 0 Step -1
      ;Step through each byte in the Product Key
      nCur = (nCur * 256) ! bProductKey(ilKeyByte)
      bProductKey(ilKeyByte) = Int(nCur / 24)
      nCur = nCur % 24
    Next
    sCDKey = Chr(bKeyChars(nCur)) + sCDKey
    If (ilByte % 5) = 0 And ilByte <> 0 : sCDKey = "-" + sCDKey:EndIf
  Next
  ProcedureReturn sCDKey
EndProcedure

;show me results
If OpenWindow(0, 100, 200, 300, 200, "Product Keys", #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget)
  If CreateGadgetList(WindowID(0))
    TextGadget(0,10,10,350,20,"Windows : " + WindowsKeys(1))
    TextGadget(1,10,30,350,20,"Office  : " + WindowsKeys(2))
    TextGadget(2,10,50,350,20,"Access  : " + WindowsKeys(3))
    TextGadget(3,10,70,350,20,"Excel   : " + WindowsKeys(4))
    TextGadget(4,10,90,350,20,"Outlook : " + WindowsKeys(5))
    TextGadget(5,10,110,350,20,"PowerPoint : " + WindowsKeys(6))
    TextGadget(6,10,130,350,20,"Word   : " + WindowsKeys(7))
    TextGadget(7,10,150,350,20,"FrontPage : " + WindowsKeys(8))
    TextGadget(8,10,170,350,20,"InfoPath : " + WindowsKeys(9))
  EndIf
  Repeat
    EventID = WaitWindowEvent()
    
    If EventID = #PB_Event_CloseWindow  ; If the user has pressed on the close button
      Quit = 1
    EndIf
    
  Until Quit = 1
  
EndIf

Posted: Thu May 28, 2009 3:52 pm
by doctorized
Rings wrote:can you provide a version thats works under a actual (4.3) version ?
i can't compile the source without lots of compiler-syntax errors.
thx.
See initial code. It's been updated.

Posted: Thu May 28, 2009 4:05 pm
by Kaeru Gaman
I ask myself, what is the use of posting dozens of codes for an almost half a year outdated PB-Version... Image

Re: Get product keys of Windows and Office products

Posted: Thu Jul 08, 2010 1:25 pm
by doctorized
The code has been updated. Please test it.

Re: Updated: Get product keys of Windows and Office products

Posted: Thu Jul 08, 2010 5:50 pm
by SFSxOI
doctorized wrote:View Windows and every single Office Product Key separately (as long as separate installation is done for each product).

The code has been updated to support Office 2010. Please test it to confirm good functionality.
On Windows 7 x86 abd PB 4.50 here > It only gets the Windows product key, it does not retrieve the keys for office.

I tried also the version for PB 4.3x and it acts the same here on windows 7.

Re: Updated: Get product keys of Windows and Office products

Posted: Thu Jul 08, 2010 6:32 pm
by KJ67
WinXP 2002 SP3, Office 2000
* Windows, Ok
* Office, not ok. Just getting BBBB-BBBB-....

Re: Updated: Get product keys of Windows and Office products

Posted: Thu Jul 08, 2010 8:30 pm
by doctorized
SFSxOI wrote:On Windows 7 x86 abd PB 4.50 here > It only gets the Windows product key, it does not retrieve the keys for office.
KJ67 wrote:Office, not ok. Just getting BBBB-BBBB-....
It was a stupidity of mine. I had forgotten to set the Offset to 808 ONLY for office 2007/2010 and not all. Now fixed.

Re: Updated: Get product keys of Windows and Office products

Posted: Fri Jul 09, 2010 12:25 am
by SFSxOI
Still does not get office keys here. Did you update the original code in your first post?

Re: Updated: Get product keys of Windows and Office products

Posted: Fri Jul 09, 2010 10:28 am
by doctorized
SFSxOI wrote:Still does not get office keys here. Did you update the original code in your first post?
Yes. The first code is the latest. I will mention it.

Re: Updated: Get product keys of Windows and Office products

Posted: Fri Jul 09, 2010 3:07 pm
by SFSxOI
I still can not get your code as written to work here for office 2007 keys. However, the below code works here on Windows 7 x 86 with Office 2007 and PB 4.50:

Code: Select all

Procedure.s GetString(hKey.l, strPath.s, strValue.s, RegType.l=2) 
  ;this procedure is reading the registry values when we know 
  ;exactly what we want to read and where to read 
  ;OnErrorResume() 
  KeyHand.l:datatype.l:lresult.l 
  Dim strBuf.b(1):lDataBufSize.l 
  intZeroPos.l:tempV.l:mm.l 
  r = RegOpenKey_(hKey, strPath, @KeyHand) 
  lresult = RegQueryValueEx_(KeyHand, strValue, 0, @lValueType, 0, @lDataBufSize) 
  mm=lDataBufSize 
  If lDataBufSize > 0 
    ReDim strBuf.b(lDataBufSize-1) 
  EndIf 
  lresult = RegQueryValueEx_(KeyHand, @strValue, 0, @RegType, @strBuf(), @lDataBufSize) 
  If lresult = #ERROR_SUCCESS 
    If lValueType = 4 
      tempV.l = 0 
      For i = 0 To lDataBufSize-1 
        tempV = tempV + (strBuf(i) & $FF) * Pow(16,(2 * i)) 
      Next 
      ProcedureReturn StrU(tempV,#PB_Long) 
    EndIf 
    tmp.s 
    If RegType = #REG_MULTI_SZ 
      For i=0 To lDataBufSize-1 
        If strBuf(i)=0 
          tmp + " , " 
        Else 
          tmp+ Chr(strBuf(i)) 
        EndIf 
      Next 
      For i=lDataBufSize-1 To 0 Step -1 
        If Right(tmp,3)=" , ":tmp = Left(tmp,Len(tmp)-3):EndIf 
      Next 
      ProcedureReturn tmp + "." 
    EndIf 
    For i=0 To lDataBufSize-1 
      tmp+ Chr(strBuf(i)) 
    Next 
    ProcedureReturn tmp 
  EndIf 
EndProcedure 

Procedure.s ReadReg(ReadKey.l, SubKey.s, ReadValue.s, ValueType.l, LookInSubFolders.l, HelpValue.s, HelpValueRead.s, Array ArrayToRecieveData.b(1), HelpFolder.s="", ReturnPath.l=0) 
  ;this procedure is reading the registry values when we DO NOT know 
  ;exactly what we want to read and where to read 
  ;OnErrorResume() 
  RequesySubKey.s: TempStr.s: RLen.l: Result.l 
  STime.FILETIME: MaxValLen.l: azz.l:tmp.s 
  MaxValNameLen.l: MaxSubKeyLen.l: MaxSubKeyLen2.l 
  SubKeys.l: Values.l: hKey.l: i.l 
  hKey1.l: hKey2.l:SKey.s:SKey2.s 
  Result = RegOpenKeyEx_(ReadKey, SubKey, 0, $20019, @hKey) 
  Result = RegQueryInfoKey_(hKey, 0, 0, 0, @SubKeys, @MaxSubKeyLen, 0, @Values, @MaxValNameLen, @MaxValLen, 0, STime) 
  keynum = SubKeys 
  For i = 0 To keynum - 1 
    TempStr = Space(255) 
    RLen = 255 
    Result = RegEnumKey_(hKey, i, @TempStr, @RLen) 
    SKey = SubKey + "\" + TempStr 
    If LookInSubFolders > 0 
      For ii=1 To LookInSubFolders 
        Result = RegOpenKeyEx_(ReadKey, SKey, 0, $20019, @hKey1) 
        Result = RegQueryInfoKey_(hKey1, 0, 0, 0, @SubKeys, @MaxSubKeyLen, 0, @Values, @MaxValNameLen, @MaxValLen, 0, STime) 
        For iii=0 To SubKeys-1 
          TempStr = Space(255): RLen = 255 
          Result = RegEnumKey_(hKey1, iii, @TempStr, @RLen) 
          SKey2 = SKey + "\" + TempStr 
          If RegOpenKeyEx_(ReadKey, SKey2 + "\" + HelpFolder, 0, $20019, @hKey2) = #ERROR_SUCCESS 
            azz = 1 
            RegCloseKey_(hKey2) 
            Break 
          EndIf 
        Next 
        If azz = 1 
          RegCloseKey_(hKey1) 
          RegCloseKey_(hKey) 
          ProcedureReturn GetString(ReadKey,SKey2,ReadValue,ValueType) 
        EndIf 
      Next 
    EndIf 
    
    If HelpValue <> "" 
      tmpp.s=GetString(ReadKey,SKey,HelpValue) 
      If FindString(tmpp,HelpValueRead,1) = 0 
        Goto ReadNext 
      EndIf 
    EndIf 
    tmp = GetString(ReadKey, SKey, ReadValue,ValueType) 
    If tmp<> "" 
      datalen.l=164 
      RegOpenKey_(#HKEY_LOCAL_MACHINE, sKey, @hKey2) 
      RegQueryValueEx_(hKey2, "DigitalProductID", 0, @REG_BINARY, @ArrayToRecieveData(), @datalen) 
      Result = RegCloseKey_(hKey2) 
      Result = RegCloseKey_(hKey) 
      If ReturnPath>0 
        ProcedureReturn SKey 
      Else 
        ProcedureReturn tmp 
      EndIf 
    EndIf 
    ReadNext: 
  Next 
EndProcedure 

Procedure.s WindowsKeys(KeyType.l) 
  ilByte.l: lDataLen.l = 164: hKey.l: keyval.s: Dim TempStr.s(66) 
  Dim  bProductKey.b(14) 
  Dim bDigitalProductID.b(lDataLen) 
  ;The keytype tell us which key do we need. 
  ;Each office product can be installed separately from the CD 
  ;with its own key so we will take them all, if they exist. 
  Select KeyType 
    Case 1 ;windows key 
      Select OSVersion() 
        Case #PB_OS_Windows_95, #PB_OS_Windows_98, #PB_OS_Windows_ME 
          keyval = "SOFTWARE\Microsoft\Windows\CurrentVersion" 
        Default 
          keyval = "SOFTWARE\Microsoft\Windows NT\CurrentVersion" 
      EndSelect 
      RegOpenKey_(#HKEY_LOCAL_MACHINE, keyval, @hKey) 
      RegQueryValueEx_(hKey, "DigitalProductID", 0, @REG_BINARY, @bDigitalProductID(), @lDataLen) 
      Result = RegCloseKey_(hKey) 
    Case 2 ;office key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"SuiteName","Microsoft Office",@bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Error: Read Registry (key)": EndIf 
    Case 3 ;Access key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        ;"ProductName" is needed to take the key for the correct product 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Access",@bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf;found it 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
    Case 4 ;Excel key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Excel",bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
    Case 5 ;Outlook key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Outlook",bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
    Case 6 ;PowerPoint key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office PowerPoint",bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
    Case 7 ;Word key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office Word",bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
    Case 8 ;FrontPage key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office FrontPage",bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
    Case 9 ;InfoPath key 
      For i.l = 12 To 1 Step -1 
        keyval = "SOFTWARE\Microsoft\Office\" + Str(i) + ".0\Registration" 
        keyval=ReadReg(#HKEY_LOCAL_MACHINE,keyval,"DigitalProductId",REG_BINARY,0,"ProductName","Microsoft Office InfoPath",bDigitalProductID(),"",1) 
        If keyval <>"": Break: EndIf 
      Next 
      If keyval="": ProcedureReturn "Not Available": EndIf 
  EndSelect 
  
  ;Get the Product Key, 15 bytes long, offset by 52 bytes 
  For ilByte = 52 To 66 
    bProductKey(ilByte - 52) = bDigitalProductID(ilByte) 
  Next 
  
  Dim bKeyChars.b(24) 
  ;Now we are going To 'base24' decode the Product Key 
  ;Possible characters in the CD Key: 
  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") 
  nCur.l: sCDKey.s 
  ilKeyByte.l: ilBit.l 
  For ilByte = 24 To 0 Step -1 
    ;Step through each character in the CD key 
    nCur = 0 
    For ilKeyByte = 14 To 0 Step -1 
      ;Step through each byte in the Product Key 
      nCur = (nCur * 256) ! bProductKey(ilKeyByte) 
      bProductKey(ilKeyByte) = Int(nCur / 24) 
      nCur = nCur % 24 
    Next 
    sCDKey = Chr(bKeyChars(nCur)) + sCDKey 
    If (ilByte % 5) = 0 And ilByte <> 0 : sCDKey = "-" + sCDKey:EndIf 
  Next 
  ProcedureReturn sCDKey 
EndProcedure 

;show me results 
If OpenWindow(0, 100, 200, 300, 200, "Product Keys", #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget) 
  ;If CreateGadgetList(WindowID(0))
  If UseGadgetList(WindowID(0)) 
    TextGadget(0,10,10,350,20,"Windows : " + WindowsKeys(1)) 
    TextGadget(1,10,30,350,20,"Office  : " + WindowsKeys(2)) 
    TextGadget(2,10,50,350,20,"Access  : " + WindowsKeys(3)) 
    TextGadget(3,10,70,350,20,"Excel   : " + WindowsKeys(4)) 
    TextGadget(4,10,90,350,20,"Outlook : " + WindowsKeys(5)) 
    TextGadget(5,10,110,350,20,"PowerPoint : " + WindowsKeys(6)) 
    TextGadget(6,10,130,350,20,"Word   : " + WindowsKeys(7)) 
    TextGadget(7,10,150,350,20,"FrontPage : " + WindowsKeys(8)) 
    TextGadget(8,10,170,350,20,"InfoPath : " + WindowsKeys(9)) 
  EndIf 
  Repeat 
    EventID = WaitWindowEvent() 
    
    If EventID = #PB_Event_CloseWindow  ; If the user has pressed on the close button 
      Quit = 1 
    EndIf 
    
  Until Quit = 1 
  
EndIf
seems to have something to do with the decode offset being used in your code in the first post.

Re: Updated: Get product keys of Windows and Office products

Posted: Fri Jul 09, 2010 3:30 pm
by doctorized
SFSxOI wrote:I still can not get your code as written to work here for office 2007 keys.
What exactly returns for office key? It returns BBBB-BBBB-.... or "Not available"?
I think it is not the offset, it's the OS. You have x86 and I have x64. In order to take the key under x64 you must use some special permissions, #KEY_ALL_ACCESS |$100 or $101 with RegOpenKeyEx_() and not #KEY_READ. Obviously, x86 version gives us a failure with these values. I have XP x86, I will do some tests and improvements there. Thanx a lot for mentioning the problem.

Re: Updated: Get product keys of Windows and Office products

Posted: Fri Jul 09, 2010 9:19 pm
by SFSxOI
It returns "Not available".

I didn't realize that this was for 64 bit only. sorry bout that. I just assumed it was an updated verion of previous code which did work (as I posted).
All times are UTC+01:00
Page 1 of 2

Powered by phpBB® Forum Software © phpBB Limited