[gunsmokingman]

I made this Vb.net app on Win7 and it get the OS Key and saves it to a text file.
I have tested this On Win7x64, Vistax32, XPx32

I have updated this app
GetKey_V3
Source Code GetKey_V3

New Source Code Get_KeyV1
New Get_KeyV1

Attached File(s)

•  GetKey.exe (53.5K)
  Number of downloads: 296

[cluberti]

Very nice - care to post the source for this little app?

[Yzöwl]

I agree, it could be a very useful tool GSM.

If you can post the source code then it would certainly helpful for the tools current location in 'programming'.

I'll even go as far as to say that there may even be a more prominent location, (or at least a way for MSFN to better show it off), too!

Note - To the less knowledgeable among us, due to the fact that the tool was written in Vb.NET, it will require that the host PC has at least .NET Framework v2.0.50727 in order for it to run.

[CoffeeFiend]

Don't wanna p*** on anyone's parade, but I kind of fail to see the point. There's been apps to do exactly this for ages e.g. magical jellybean keyfinder, and they're open source too. Want to see how it's done? Download its source code, and look at TForm1.DecodeMSKey. Don't like or can't understand pascal? Fine, you can easily find sample code in basically any other language that exists within seconds using google searching for common related terms, like this. There's even pre-written vbscripts that do this... Or C# versions.

Having yet-another-app that does this brings very, very little, especially when it's closed source.

[MagicAndre1981]

cluberti, on Feb 4 2009, 08:55 AM, said:

Very nice - care to post the source for this little app?

the source is not necessary because it can be found all over the internet:

Here in Delphi: http://www.swissdelp...ode.php?id=2252

And you can use .NET Reflector to open his application and see the code

[Yzöwl]

CoffeeFiend, on Feb 4 2009, 12:12 PM, said:

Don't wanna p*** on anyone's parade, but I kind of fail to see the point. There's been apps to do exactly this for ages e.g. magical jellybean keyfinder, and they're open source too. Want to see how it's done? Download its source code, and look at TForm1.DecodeMSKey. Don't like or can't understand pascal? Fine, you can easily find sample code in basically any other language that exists within seconds using google searching for common related terms, like this. There's even pre-written vbscripts that do this... Or C# versions.

Having yet-another-app that does this brings very, very little, especially when it's closed source.

Surely the source code would define whether or not there was anything different or better with this particular implementation. The only tool I've ever used for this task was a VBScript and I've not tested in on any OS other than XP (x86). This used Vb.NET, which so far the ones you've linked didn't and also as far as I'm aware Magical Jelly Bean Keyfinder isn'y advertised as working in Windows 7.

MagicAndre1981, on Feb 4 2009, 12:18 PM, said:

cluberti, on Feb 4 2009, 08:55 AM, said:

Very nice - care to post the source for this little app?

the source is not necessary because it can be found all over the internet:

Here in Delphi: http://www.swissdelp...ode.php?id=2252

And you can use .NET Reflector to open his application and see the code

The source really is necessary, this is a Programming Forum, not a tool repository, therefore in this location the tool serves no real benefit to the Members. The topic shouldn't require interested Members to download and use a 3rd party tool in order to access the code within.

[gunsmokingman]

The original source code was a vbs script and I wanted to see if it would work in Vb.net
I made the app to see if it would work on Win7. Sorry about not posting the source code
it slipped my mind.

Quote

Imports System.IO
Public Class Form1
	Dim Desktop = Microsoft.VisualBasic.CreateObject("Wscript.Shell").SpecialFolders("Desktop")
	Dim KeyTxt = Desktop & "\" & My.Computer.Name & "_Key.txt"
	Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
		Label1.Text = ""
		Label2.Text = "Gunsmokingman Get OS Key"
	End Sub
	'-> Get The OS Key
	Dim OsKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId"
	Function GetKey(ByVal rpk)
		Dim i, j
		Dim dwAccumulator = "", szProductKey = ""
		Const rpkOffset = 52 : i = 28
		Dim 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
		Label1.Text = szProductKey
	End Function
	'-> Button1 Get The Os Key
	Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
		If Button1.Text = "Get Key" Then
			Button1.Text = "Clear Key"
			GetKey(Microsoft.VisualBasic.CreateObject("Wscript.Shell").RegRead(OsKey))
		Else
			Button1.Text = "Get Key"
			Label1.Text = ""
		End If
	End Sub
	'-> Button2 Save The Os Key
	Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
		If Label1.Text = "" Then
			MsgBox(Space(6) & "Error No Key Text" & vbCrLf & _
				   " Press The Get Key Button" & vbCrLf & _
				   " Then Press The Save Key", 4128)
		Else
			Dim sw As StreamWriter = New StreamWriter(KeyTxt.ToString)
			sw.WriteLine(" Saved At " & Chr(187) & Chr(160) & KeyTxt.ToString)
			sw.WriteLine(" Os Key   " & Chr(187) & Chr(160) & Label1.Text)
			sw.Close()
			Microsoft.VisualBasic.CreateObject("Wscript.Shell").Run(Chr(34) & KeyTxt.ToString & Chr(34), 1, True)
		End If
	End Sub
End Class

I have included the Vb.net project files so you can open it in Vb.net and make any changes you want.
Source Code

New Source Code Get_KeyV1
New Get_KeyV1

This post has been edited by gunsmokingman: 01 January 2010 - 11:52 PM

[CoffeeFiend]

Yzöwl, on Feb 4 2009, 09:26 AM, said:

This used Vb.NET, which so far the ones you've linked didn't

I only linked to a couple, but it's not exactly hard to find. I linked to 3, but google can easily find more (I even included a sample search query, many other queries work fine too) The algo is pretty simple, and it's really easy to port it from C# if you're more of a VB person -- there's even automated tools to do this for you, even online versions of it... And porting an existing vbscript to VB isn't exactly hard either as both languages are very similar in syntax. And like MagicAndre1981 said, you could even use reflector for this.

Yzöwl, on Feb 4 2009, 09:26 AM, said:

and also as far as I'm aware Magical Jelly Bean Keyfinder isn'y advertised as working in Windows 7.

I doubt it stopped working just because it doesn't explicitly mention on its home page that it's been tested with a unreleased beta OS, as those same digitalproductid's haven't changed in just about forever (Win2k era at least), nor their locations. Even more so as Win 7 is pretty much Vista R2, and all those old tools still work fine on Vista.

Yzöwl, on Feb 4 2009, 09:26 AM, said:

this is a Programming Forum, not a tool repository, therefore in this location the tool serves no real benefit to the Members.

Indeed, without the source it's in the wrong section. But I honestly don't see this section as a very good place to share code anyways. Useful bits tend to just get moved at the very end of a "repository" thread no one seemingly reads, which explains why I haven't bothered sharing FixPE (a C# app that does much the same as modifype.exe -- except it works on OS'es past XP and lacks a couple of its bugs), and even removed my font installer (fontinst.exe replacement) & screen saver scripts a while ago. Not that anyone noticed (as it just gets no readers). Feel free to delete the posts with no content.

If anything, it would be FAR better if the section was split into more relevant subsections: a batch/cmd section, a scripting section (e.g. vbscript/jscript/autoit), an actual programming section (C, C++, C#, Java, ...) and perhaps one to share tools and toys (create a new post for your new tool, where people can reply, make requests, report bugs, ask for features, etc). Right now, most of what we see in here is along the lines of "help me [write for me] a batch file to do xyz" and not so much programming related anyways. There doesn't seem to be a whole lot of programmers (as in people who this for a living) hanging around either.

This post has been edited by CoffeeFiend: 04 February 2009 - 04:45 PM

[cluberti]

That is true - but I think it goes without saying that those of us who do this for a living don't need a forum for help on it, either. I asked for source because I wanted to see how gun did it, not because it's inherently useful. Also, being a programming section, putting a tool without source (as it appeared to slip gun's mind, so no worries) is kind of useless.

Everyone should just lighten up a bit.

[CoffeeFiend]

cluberti, on Feb 4 2009, 07:22 PM, said:

I think it goes without saying that those of us who do this for a living don't need a forum for help on it

I meant that the other way around, not many of us around to answer such questions for others.

[Glenn9999]

CoffeeFiend, on Feb 4 2009, 06:26 PM, said:

cluberti, on Feb 4 2009, 07:22 PM, said:

I think it goes without saying that those of us who do this for a living don't need a forum for help on it

I meant that the other way around, not many of us around to answer such questions for others.

True. Why is this? Really it's because 95% of this sub-forum on MSFN is all batch and scripting (and nothing wrong with that, it's one of the top topics in one of the hardcore programming forums I referred to below). There are people that know these things on here and are getting a workout from what I can tell, but it's kind of hard to want to participate if nothing comes up that's in your field of expertise or interest. That's my category, to be honest. There's programming things I could post and things I could help on, but they never seem to come up in here, and I'm really about 90% sure from the posts here that enough would be interested to count on one hand what I would post. I could always roll the dice and post a couple of things that are semi-relevant to the other topics on this board, though...

Now, my interest in this site and participating in this forum is more of a software and hardware nature. I get value from those things, and I get value in the technicals of the OS for what programming projects I do do. I also have posted a couple of my semi-completed projects on here, to mild notice (and that's fine as long as they're useful to someone - they seemed to be, which makes it worthwhile to me to post them, and I have no regrets in posting them).

Now, I participate in a 2 or 3 other forums that are more hardcore towards "actual programming" (as CoffeeFiend puts it), and the large preponderance of people are people that do programming for a living (I'd say 99%). For a couple of the topics, it seems I'm the hobbyist sitting among everyone else who is making a buck doing what is involved in the forums (and some accomplished enough that you could call them luminaries in their chosen competency). And many of them participate, ask questions, answer them occasionally, and yes even profess then and again the usefulness of such forums to them.

My thoughts on these things? Usually, people tend to participate and flock to things that have others who are interested in the topic as well. It's a initial gauge I know most put up when they first see something - no posts on what I'm interested in? Maybe I should move on. Posts on what I'm interested in? Let me stay awhile. Of course, any site can't be everything to everyone. A forum is what the aggregate of its posting members make of it.

Now, let me go through my source and see what I could post here...

[cluberti]

I think you're probably right - at MSFN, anything more than scripting is pretty much above and beyond what people come here for (that's mostly questions about Windows and associated Microsoft apps, and hacking said apps judging from the apps in the member apps section).

I'd be interested to know, either publicly or in a PM, what dev forums you are speaking of to see if they're the same 2 or 3 I normally visit .

[gunsmokingman]

I have updated my Get key, It will now list Computer Name, Ram Total, Date Installed, Get Key.
If anyone has any more suggestion as to what to add, I am open to suggestions.

Quote

Imports System
Imports System.IO

Public Class Form1
	Const GB = 1073741824
	Const MB = 1048576
	Dim Act = Microsoft.VisualBasic.CreateObject("Wscript.Shell")
	Dim RamSize = My.Computer.Info.TotalPhysicalMemory
	Dim CName = My.Computer.Name
	Dim R_A = Chr(160) & Chr(187) & Chr(160)
	'-> On Load Clear Text
	Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
		TextGone()
	End Sub
	'-> Clear The Text Display Information
	Private Sub TextGone()
		Txt1b.Text = ""
		Txt2b.Text = ""
		Txt3b.Text = ""
		Txt4b.Text = ""
		SaveText.Enabled = False
	End Sub
	'-> Get Installed Ram Total
	Dim RamInstalled
	Private Sub InstalledRam()
		If RamSize < GB Then
			Txt2b.Text = FormatNumber(RamSize / MB, 2) & " MB"
		Else
			Txt2b.Text = FormatNumber(RamSize / GB, 2) & " GB"
		End If
		RamInstalled = " Install Ram	" & R_A & Txt2b.Text
	End Sub
	'-> Get Install Date
	Dim InstallDate
	Private Sub InstalledDate()
		Dim Wmi = GetObject("winmgmts:\\.\root\CIMV2")
		Dim IDate = Microsoft.VisualBasic.CreateObject("WbemScripting.SWbemDateTime")
		For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem")
			IDate.Value = Obj.InstallDate
			Dim T1 = Microsoft.VisualBasic.MonthName(IDate.Month.ToString)
			Dim T2 = Microsoft.VisualBasic.WeekdayName(IDate.Day.ToString)
			Txt3b.Text = T1 & "," & T2 & "  " & IDate.GetVarDate
			InstallDate = " Install Date   " & R_A & Txt3b.Text
		Next
		Wmi = Nothing
	End Sub
	'-> Get The OS Key
	Dim OsKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId"
	Dim Key
	Function GetKey(ByVal rpk)
		Dim i, j
		Dim dwAccumulator = "", KeyOs = ""
		Const rpkOffset = 52 : i = 28
		Dim 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 : KeyOs = Mid(szPossibleChars, dwAccumulator + 1, 1) & KeyOs
			If (((29 - i) Mod 6) = 0) And (i <> -1) Then
				i = i - 1 : KeyOs = "-" & KeyOs
			End If
		Loop While i >= 0
		GetKey = KeyOs
		Txt4b.Text = KeyOs
		Key = " OS Key		 " & R_A & KeyOs
	End Function
	'-> Show Text Information
	Dim CmpName
	Private Sub ShowText_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ShowText.Click
		Txt1b.Text = CName
		CmpName = " Computer Name  " & R_A & CName
		InstalledRam()
		InstalledDate()
		GetKey(Act.RegRead(OsKey))
		SaveText.Enabled = True
	End Sub
	'-> Clear The Text Information
	Private Sub ClearText_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ClearText.Click
		TextGone()
	End Sub
	'-> Save Text Information
	Private Sub SaveText_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles SaveText.Click
		Dim Desktop = Act.SpecialFolders("Desktop")
		Dim KeyTxt = Desktop & "\" & My.Computer.Name & "_InstallInfo.txt"
		Dim sw As StreamWriter = New StreamWriter(KeyTxt.ToString)
		sw.WriteLine(" Save Location  " & R_A & KeyTxt.ToString)
		sw.WriteLine(CmpName)
		sw.WriteLine(RamInstalled)
		sw.WriteLine(InstallDate)
		sw.WriteLine(Key)
		sw.Close()
		Act.Run(Chr(34) & KeyTxt.ToString & Chr(34), 1, True)
	End Sub
End Class

Source Code GetKey_V2
New Source Code Get_KeyV1
New Get_KeyV1

[gunsmokingman]

I have updated this app, I fixed a flaw that appeared on XP in my last version.

This caused a error if ran on XP

Quote

Dim T2 = Microsoft.VisualBasic.WeekdayName(IDate.Day.ToString)

This is the fixed line of code, runs on XP

Quote

Dim T2 = Microsoft.VisualBasic.WeekdayName(Microsoft.VisualBasic.Weekday(IDate.GetVarDate))

Quote

Imports System
Imports System.IO
Public Class Form1
	Const GB = 1073741824
	Const MB = 1048576
	'-> Objects From VBS Script
	Dim Act = Microsoft.VisualBasic.CreateObject("Wscript.Shell")
	Dim Tme = Microsoft.VisualBasic.CreateObject("WbemScripting.SWbemDateTime")
	Dim Wmi = GetObject("winmgmts:\\.\root\CIMV2")
	'-> Text Output Objects
	Dim R_A = Chr(160) & Chr(187) & Chr(160)
	Dim Vb = vbCrLf
	'-> Computer System Objects
	Dim RamSize = My.Computer.Info.TotalPhysicalMemory
	Dim CName = " Computer Name " & R_A & My.Computer.Name
	'-> Get Installed Ram Total
	Dim Ram1, Ram2
	Private Sub InstalledRam()
		If RamSize < GB Then
			Ram1 = FormatNumber(RamSize / MB, 2) & " MB"
		Else
			Ram1 = FormatNumber(RamSize / GB, 2) & " GB"
		End If
		Ram2 = " Install Ram   " & R_A & Ram1
	End Sub
	'-> Get Install Date
	Dim InstallDate, LastBoot, OsName
	Private Sub SystemTimeDateBoot()
		Dim A1, A2, T1, T2
		For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem")
			OsName = " Os Name	   " & R_A & Obj.Caption
			Tme.Value = Obj.InstallDate
			A1 = Tme.GetVarDate
			T1 = Microsoft.VisualBasic.MonthName(Tme.Month.ToString)
			T2 = Microsoft.VisualBasic.WeekdayName(Microsoft.VisualBasic.Weekday(A1))
			InstallDate = " Install Date  " & R_A & A1 & "  " & T1 & "," & T2
			Tme.Value = Obj.LastBootUpTime
			A2 = Tme.GetVarDate
			T1 = Microsoft.VisualBasic.MonthName(Tme.Month.ToString)
			T2 = Microsoft.VisualBasic.WeekdayName(Microsoft.VisualBasic.Weekday(A2))
			LastBoot = " Last Boot Up  " & R_A & A2 & "  " & T1 & "," & T2
		Next
	End Sub
	'-> Disks Information
	Dim HardDrive, Optical
	Private Sub DiskInformation()
		For Each Drv In My.Computer.FileSystem.Drives
			If Drv.DriveType = DriveType.Fixed Then
				HardDrive = HardDrive & Drv.Name & " "
			End If
			If Drv.DriveType = DriveType.CDRom Then
				Optical = Optical & Drv.Name & " "
			End If
		Next
		HardDrive = " Hard Disks	" & R_A & HardDrive
		Optical = " Optical Disks " & R_A & Optical
	End Sub
	'-> Get The OS Key
	Dim OsKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId"
	Dim Key
	Function GetKey(ByVal rpk)
		Dim i, j
		Dim dwAccumulator = "", KeyOs = ""
		Const rpkOffset = 52 : i = 28
		Dim 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 : KeyOs = Mid(szPossibleChars, dwAccumulator + 1, 1) & KeyOs
			If (((29 - i) Mod 6) = 0) And (i <> -1) Then
				i = i - 1 : KeyOs = "-" & KeyOs
			End If
		Loop While i >= 0
		GetKey = KeyOs
		Key = " OS Key		" & R_A & KeyOs
	End Function
	'-> Button 01 Click Fill Textbox
	Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
		InstalledRam()
		SystemTimeDateBoot()
		DiskInformation()
		GetKey(Act.RegRead(OsKey))
		TextBox1.Text = OsName & Vb & CName & Vb & _
		Ram2 & Vb & _
		InstallDate & Vb & _
		LastBoot & Vb & _
		HardDrive & Vb & _
		Optical & Vb & _
		Key
	End Sub
	'-> Button 02 Click Clear Textbox
	Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
		TextBox1.Text = ""
		Key = ""
		Optical = ""
		HardDrive = ""
		LastBoot = ""
		InstallDate = ""
	End Sub
	'-> Button 03 Click Save Textbox
	Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
		If Not TextBox1.Text = "" Then
			Dim Desktop = Act.SpecialFolders("Desktop")
			Dim KeyTxt = Desktop & "\" & My.Computer.Name & "_BasicInfo.txt"
			Dim sw As StreamWriter = New StreamWriter(KeyTxt.ToString)
			sw.WriteLine(" Save Location " & R_A & KeyTxt.ToString)
			sw.Write(TextBox1.Text)
			sw.Close()
			Act.Run(Chr(34) & KeyTxt.ToString & Chr(34), 1, False)
		End If
	End Sub
End Class

Source Code GetKey_V3
New Source Code Get_KeyV1
New Get_KeyV1

Attached File(s)

•  GetKey_V3.exe (57K)
  Number of downloads: 315

[gunsmokingman]

I have updated the app

Quote

Imports System
Imports System.IO
Public Class Form1
	Const GB = 1073741824
	Const MB = 1048576
	'-> Objects From VBS Script
	Dim Act = Microsoft.VisualBasic.CreateObject("Wscript.Shell")
	Dim Tme = Microsoft.VisualBasic.CreateObject("WbemScripting.SWbemDateTime")
	Dim Wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
	'-> Output Varibles 
	Dim vB = vbCrLf
	Dim ARW = Chr(160) & Chr(187) & Chr(160)
	Dim Lne = "------------------------------------------------------------------"
	'-> Varibles 
	Dim CName = My.Computer.Name
	Dim OName = My.Computer.Info.OSFullName
	Dim OsVer = My.Computer.Info.OSVersion
	Dim SyRam = My.Computer.Info.TotalPhysicalMemory
	Dim DigProID = "\DigitalProductId"
	'-> Reg Key Varible
	Dim RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\"
	'-> MsKeys(0) = Window Product Key
	'-> MsKeys(1) = Office 2010
	'-> MsKeys(2) = Office 2007
	'-> MsKeys(3) = Office 2003
	'-> MsKeys(4) = Office XP
	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"}
	'-> Button Click Section
	'-> Collect The Information
	Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
		Dim V1 = "  Installed System Ram  " & ARW
		If My.Computer.Info.TotalPhysicalMemory > GB Then
			SyRam = V1 & FormatNumber(My.Computer.Info.TotalPhysicalMemory / GB, 2) & " GB"
		Else
			SyRam = V1 & FormatNumber(My.Computer.Info.TotalPhysicalMemory / MB, 2) & " MB"
		End If
		TextBox1.Text = Lne & vB & _
		"  Computer System Name  " & ARW & CName & vB & _
		"  Operating System Name " & ARW & OName & vB & _
		"  Os Version			" & ARW & OsVer & vB & _
		SyRam & vB
		WmiQuerry()
		TextBox1.ScrollBars = ScrollBars.Both
		DiskInformation()
		ListMSKeys()
	End Sub
	'-> Clear Text And Global Varibles
	Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
		TextBox1.Text = ""
		HardDrive = ""
		Optical = ""
		Removable = ""
		SyRam = ""
		Tm1 = ""
		Tm2 = ""
		TxtVar1 = ""
		TextBox1.ScrollBars = ScrollBars.None
	End Sub
	'-> Save The Information
	Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
		If Not TextBox1.Text = "" Then
			Dim Desktop = Act.SpecialFolders("Desktop")
			Dim KeyTxt = Desktop & "\" & My.Computer.Name & "_BasicInfo.txt"
			Dim sw As StreamWriter = New StreamWriter(KeyTxt.ToString)
			sw.Write(TextBox1.Text)
			sw.Close()
			Act.Run(Chr(34) & KeyTxt.ToString & Chr(34), 1, False)
		End If
	End Sub
	'-> Code To Fill Textbox1
	'-> 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
	'-> Wmi Querries
	Dim Tm1
	Dim Tm2
	Private Sub WmiQuerry()
		Dim Cpu = "", InDate = "", InTime = "", LBDate = "", LBTime = ""
		For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem")
			If Obj.BuildNumber >= 6000 Then
				Cpu = True
			Else
				Cpu = False
			End If
		Next
		Dim T1 = "  Number Of Processors  "
		For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_ComputerSystem")
			If Cpu = True Then
				Cpu = T1 & ARW & Obj.NumberOfProcessors & vB & _
				"  Logical Processors	" & ARW & Obj.NumberOfLogicalProcessors
			Else
				Cpu = T1 & ARW & Obj.NumberOfProcessors
			End If
			TextBox1.Text = TextBox1.Text & _
			"  Computer System Type  " & ARW & Obj.SystemType & vB & _
			Cpu & vB
		Next
		Dim SysUpTime = ""
		For Each Obj In Wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem")
			'-> Install Date
			Tme.Value = Obj.InstallDate
			Tm1 = Tme.GetVarDate
			Tm2 = Split(Tme.GetVarDate, " ")
			InDate = "  Installed Date		" & ARW & _
			MonthName(Tme.Month) & ", " & WeekdayName(Weekday(Tm1)) & " " & Tme.Day & " " & Tme.Year
			InTime = "  Installed Time		" & ARW & Tm2(1) & " " & Tm2(2)
			'-> Last Boot Up
			Tme.Value = Obj.LastBootUpTime
			Tm1 = Tme.GetVarDate
			Tm2 = Split(Tme.GetVarDate, " ")
			LBDate = "  Last Boot Date		" & ARW & _
			MonthName(Tme.Month) & ", " & WeekdayName(Weekday(Tm1)) & " " & Tme.Day & " " & Tme.Year
			LBTime = "  Last Boot Time		" & ARW & Tm2(1) & " " & Tm2(2)
			SysUpTime = "  System Uptime Hours   " & ARW & DateDiff("h", Tm1, Now)
		Next
		TextBox1.Text = TextBox1.Text & _
		Lne & vB & _
		InDate & vB & _
		InTime & vB & _
		LBDate & vB & _
		LBTime & vB & _
		SysUpTime & vB
	End Sub
	'-> Disks Information
	Dim HardDrive, Optical, Removable
	Private Sub DiskInformation()
		For Each Drv In My.Computer.FileSystem.Drives
			If Drv.DriveType = DriveType.Fixed Then
				HardDrive = HardDrive & Drv.Name & " "
			End If
			If Drv.DriveType = DriveType.CDRom Then
				Optical = Optical & Drv.Name & " "
			End If
			If Drv.DriveType = DriveType.Removable Then
				Removable = Removable & Drv.Name & " "
			End If
		Next
		HardDrive = "  Local Hard Disks	  " & ARW & HardDrive
		Optical = "  Local Optical Drive   " & ARW & Optical
		Removable = "  Local Removable Drive " & ARW & Removable
		TextBox1.Text = TextBox1.Text & Lne & vB & HardDrive & vB & Optical & vB & Removable & vB
	End Sub
	'-> Get The OS Key
	Dim Key
	Function GetKey(ByVal rpk)
		Dim i, j
		Dim dwAccumulator = "", KeyOs = ""
		Const rpkOffset = 52 : i = 28
		Dim 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 : KeyOs = Mid(szPossibleChars, dwAccumulator + 1, 1) & KeyOs
			If (((29 - i) Mod 6) = 0) And (i <> -1) Then
				i = i - 1 : KeyOs = "-" & KeyOs
			End If
		Loop While i >= 0
		GetKey = KeyOs
		Key = KeyOs
	End Function
	'-> Code To Start The Graph Of Ram Usage
	Dim SysRam
	Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
		MachineRamSize()
		RamF3.Text = ""
		RamU3.Text = ""
		RamInfoTxt.Visible = True
		RamF1.Visible = True
		RamF2.Visible = True
		RamF3.Visible = True
		RamU1.Visible = True
		RamU2.Visible = True
		RamU3.Visible = True
		RamPanel.Visible = True
		Timer1.Start()
	End Sub
	'-> Start The Timer To Update The Ram Graph
	Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
		RamForGraph()
	End Sub
	Private Sub MachineRamSize()
		If My.Computer.Info.TotalPhysicalMemory > GB Then
			SysRam = FormatNumber(My.Computer.Info.TotalPhysicalMemory / GB, 2) & " GB "
		Else
			SysRam = FormatNumber(My.Computer.Info.TotalPhysicalMemory / MB, 2) & " MB "
		End If
		SysRam = " Total Ram " & ARW & SysRam
		RamInfoTxt.Text = SysRam
	End Sub
	'-> Ram usage For Graph
	Private Sub RamForGraph()
		'-> Free Ram
		Dim F3 = ""
		If My.Computer.Info.AvailablePhysicalMemory > GB Then
			F3 = FormatNumber(My.Computer.Info.AvailablePhysicalMemory / GB) & " GB "
		ElseIf My.Computer.Info.AvailablePhysicalMemory < GB Then
			F3 = FormatNumber(My.Computer.Info.AvailablePhysicalMemory / MB) & " MB "
		End If
		'-> Set The Free Percent Size
		Dim F1 = FormatPercent(My.Computer.Info.AvailablePhysicalMemory / My.Computer.Info.TotalPhysicalMemory, 2)
		Dim F2 = Replace(F1, "%", "")
		F2 = F2 * 2.25
		RamF3.Size = New Size(F2, 17)
		RamF2.Text = F3 & " " & F1
		'-> Used Ram
		Dim U3 = ""
		Dim Ram_Used = My.Computer.Info.TotalPhysicalMemory - My.Computer.Info.AvailablePhysicalMemory
		If Ram_Used > GB Then
			U3 = FormatNumber(Ram_Used / GB, 2) & " GB"
		ElseIf Ram_Used < GB Then
			U3 = FormatNumber(Ram_Used / MB, 2) & " MB"
		End If
		'-> Set The Used Percent Size
		Dim U1 = FormatPercent(Ram_Used / My.Computer.Info.TotalPhysicalMemory, 2)
		Dim U2 = Replace(U1, "%", "")
		U2 = U2 * 2.25
		RamU3.Size = New Size(U2, 17)
		RamU2.Text = U3 & " " & U1
	End Sub
End Class

Source Code Get_KeyV1

Attached File(s)

•  Get_KeyV1.exe (69.5K)
  Number of downloads: 105

[Ozzyguy]

{10140000-0011-0000-1000-0000000FF1CE}


@GunSmokingMan

Neat little app you got goin there mate.

Im just curious.

The Office 2010 subkey of \Registration seems to be different on each PC its installed on.

The only way i could get this to return a key, was to export my Key branch....edit it with your branch number i started with above....and import the reg back in.

It did return an Office 2010 key, tho it was the wrong one.

I have a mate who is building an app in delphi and found your post while researching it for him.

We have every other Windows and office key being displayed, but were stuck on Office 2010.

Is the decryption method different from other versions ? StartOffset, EndOffset etc ?

If it is, would you mind posting the changes for me? As he can enumerate the subkey branches, but no matter what, the codes are always wrong.

Thanks in advance mate.

This post has been edited by Ozzyguy: 14 March 2010 - 12:06 AM

[gunsmokingman]

Cluberti provided the Reg Key paths from this VBS Script, I just used the Reg Key Path
in my app.

[03GrandAmGT]

Thanks GSM, neat little tool.
jd

[Ozzyguy]

gunsmokingman, on 14 March 2010 - 11:39 AM, said:

Cluberti provided the Reg Key paths from this VBS Script, I just used the Reg Key Path
in my app.

Thanks for the reply Gunsmokingman.

I suppose i should post the code snip im using. (Delphi)

If i use the Windows NT location to extract the Windows key, it works fine.

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

Im lost lol.

I thought either the start and finish offsets had changed for Office 2010, or, the algorithm itself has changed.

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

Thanks in advance.

Attached File(s)

•  ProductKey.txt (2.92K)
  Number of downloads: 28

[Glenn9999]

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