//*** Beispiel: Delphi 7 - Windows XP CD Produkt Key ermitteln //*** Keywords: SOFTWARE\Microsoft\Windows NT\CurrentVersion, DigitalProductID, //*** TRegistry, Create, KEY_READ, HKEY_LOCAL_MACHINE, RootKey, OpenKey, //*** SetLength, Length, ReadBinaryData, begin, for, downto, do, Ord, Char, //*** mod, and, then, try, finally, Free, Win32MinorVersion, Boolean, Application.Terminate, //*** Memo, TMainMenu, Menue, Menü, ClipBrd, TClipboard, TClipboard.Create, //*** SelText, AsText, Clipboard.Free, div, SaveDialog1, DefaultExt, Filter, Title, //*** FileExists, FileName, Execute, Memo1.Lines.SaveToFile, Speichern, Speichern unter, //*** MessageDlg, mbYes, mbNo, case, Cursor unit windows_xp_product_key_ermitteln; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Registry, StdCtrls, ToolWin, ActnMan, ActnCtrls, ActnMenus, ClipBrd, Menus, ExtCtrls; type TForm1 = class(TForm) Button1: TButton; MainMenu1: TMainMenu; File1: TMenuItem; Exit1: TMenuItem; GroupBox1: TGroupBox; Memo1: TMemo; Label1: TLabel; Image1: TImage; Label2: TLabel; N1: TMenuItem; SaveAs1: TMenuItem; SaveDialog1: TSaveDialog; procedure Button1Click(Sender: TObject); procedure Exit1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure GroupBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Image1Click(Sender: TObject); procedure SaveAs1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} function GetWindowsXPCDKey: String; const RequieredDigits: String = 'BCDFGHJKMPQRTVWXY2346789'; RegPath: String = 'SOFTWARE\Microsoft\Windows NT\CurrentVersion'; RegValueName: String = 'DigitalProductID'; var Buffer : String; hReg : TRegistry; j : Integer; k : Integer; n : Integer; begin Result := ''; hReg := TRegistry.Create(KEY_READ); try with hReg do begin RootKey := HKEY_LOCAL_MACHINE; OpenKey(RegPath, False); end; SetLength(Buffer, hReg.GetDataSize(RegValueName)); if (Length(Buffer) >= 67) then begin hReg.ReadBinaryData (RegValueName, Buffer[1], Length(Buffer)); for k := 24 downto 0 do begin n := 0; for j := 14 downto 0 do begin n := (n shl 8) + Ord(Buffer[53+j]); Buffer[53+j] := Char(n div 24); n := n mod 24; end; Result := RequieredDigits[n+1] + Result; if ( (k > 0) and ((k mod 5) = 0) ) then Result := '-' + Result; end; end; finally hReg.Free; end; end; function GetWindowsXPVersion: Boolean; begin Result := False; Case Win32MinorVersion of 1: Result := True; end; end; procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Text := GetWindowsXPCDKey; end; procedure TForm1.Exit1Click(Sender: TObject); begin Application.Terminate; end; procedure TForm1.FormCreate(Sender: TObject); begin Memo1.Text := ''; if GetWindowsXPVersion = False then Application.Terminate else Label1.Caption := 'Ihr Betriebssystem: Windows XP'; end; procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin Image1.Cursor := crHandPoint; Label2.Visible := True; end; procedure TForm1.GroupBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin Label2.Visible := False; end; procedure TForm1.Image1Click(Sender: TObject); var ClipBoard: TClipboard; begin if Memo1.Text = '' then begin ShowMessage('Kein Text zum kopieren vorhanden.'); Exit; end; ClipBoard := TClipboard.Create; if Memo1.SelText = '' then begin ClipBoard.AsText := Memo1.Text; end else begin ClipBoard.AsText := Memo1.SelText; end; ClipBoard.Free; end; procedure TForm1.SaveAs1Click(Sender: TObject); begin try if Memo1.Text <> '' then begin with SaveDialog1 do begin DefaultExt := '.txt'; Filter := 'Textdatei (*.txt)|*.txt'; Title := 'CD Key speichern'; end; if SaveDialog1.Execute then if FileExists(SaveDialog1.FileName) then begin case MessageDlg('Datei existiert bereits. Soll Sie ueberschrieben werden?', mtInformation, [mbYes,mbNo], 0) of mrYes : Memo1.Lines.SaveToFile(SaveDialog1.FileName); mrNo : Exit; end; end else Memo1.Lines.SaveToFile(SaveDialog1.FileName); end else ShowMessage('Keine Daten zum speichern vorhanden.'); except ShowMessage('Fehler...'); end; end; end.