Kopieret fra Experts-exchange (håber det er OK med dem):
DFM-filen:
object Form1: TForm1
Left = 325
Top = 82
Width = 651
Height = 599
Caption = 'Registry Lookup Thread Test'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object HKCRMemo: TMemo
Left = 0
Top = 0
Width = 321
Height = 186
Lines.Strings = (
'HKCRMemo')
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
object HKCUMemo: TMemo
Left = 320
Top = 0
Width = 321
Height = 186
Lines.Strings = (
'HKCUMemo')
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 1
WordWrap = False
end
object HKLMMemo: TMemo
Left = 0
Top = 185
Width = 321
Height = 186
Lines.Strings = (
'HKLMMemo')
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 2
WordWrap = False
end
object HKUMemo: TMemo
Left = 320
Top = 185
Width = 321
Height = 186
Lines.Strings = (
'HKUMemo')
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 3
WordWrap = False
end
object HKCCMemo: TMemo
Left = 0
Top = 375
Width = 321
Height = 186
Lines.Strings = (
'HKCCMemo')
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 4
WordWrap = False
end
object Button1: TButton
Left = 325
Top = 375
Width = 316
Height = 161
Caption = 'Do Test'
TabOrder = 5
OnClick = Button1Click
end
object StaticText1: TStaticText
Left = 325
Top = 540
Width = 311
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvNone
BevelKind = bkTile
BorderStyle = sbsSingle
Caption = 'Total Time : N/A'
TabOrder = 6
end
object Timer1: TTimer
OnTimer = Timer1Timer
Left = 390
Top = 530
end
end
PAS-filen:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry, ExtCtrls;
type
TRegistryThread = class(TThread)
private
procedure RegistrySearch(KeyName: String);
protected
procedure Execute; override;
public
RegistryHKey : HKEY;
Memo : TMemo;
end;
type
TForm1 = class(TForm)
HKCRMemo: TMemo;
HKCUMemo: TMemo;
HKLMMemo: TMemo;
HKUMemo: TMemo;
HKCCMemo: TMemo;
Button1: TButton;
StaticText1: TStaticText;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
function RunThread(RegistryHKey: HKEY; Memo: TMemo): TRegistryThread;
procedure ThreadTerminated(Sender: TObject);
public
rtHKCR, rtHKCU, rtHKLM, rtHKU, rtHKCC : TRegistryThread;
end;
var
Form1 : TForm1;
TotalDone : Integer = 0;
TotalSeconds : Integer = 0;
implementation
{$R *.dfm}
procedure TRegistryThread.RegistrySearch(KeyName: String);
var
Reg : TRegistry;
Names : TStringList;
Delimiter : String;
I : Integer;
begin
Reg := TRegistry.Create;
Names := TStringList.Create;
Reg.RootKey := RegistryHKey;
Try
If Reg.OpenKeyReadOnly(KeyName) Then
begin
If Reg.HasSubKeys Then
begin
Reg.GetKeyNames(Names);
For I := 0 To Names.Count - 1 Do
begin
Memo.Lines.Add(KeyName + '\' + Names.Strings[I]);
SendMessage(Memo.Handle, EM_SCROLLCARET, 0, 0);
RegistrySearch(KeyName + '\' + Names.Strings[I]);
end;
end;
end;
finally
Reg.Free;
Names.Free;
end;
end;
procedure TRegistryThread.Execute;
var
Reg : TRegistry;
Names : TStringList;
Delimiter : String;
I : Integer;
begin
inherited;
Reg := TRegistry.Create;
Names := TStringList.Create;
Reg.RootKey := RegistryHKey;
Try
If Reg.OpenKeyReadOnly('\') Then
begin
Reg.GetKeyNames(Names);
For I := 0 To Names.Count - 1 Do
begin
Memo.Lines.Add('\' + Names.Strings[I]);
RegistrySearch('\' + Names.Strings[I]);
end;
end;
finally
Reg.Free;
Names.Free;
end;
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
Inc(TotalDone);
end;
function TForm1.RunThread(RegistryHKey: HKEY; Memo: TMemo): TRegistryThread;
var
RegistryThread : TRegistryThread;
begin
RegistryThread := TRegistryThread.Create(True);
RegistryThread.FreeOnTerminate := True;
RegistryThread.RegistryHKey := RegistryHKey;
RegistryThread.Memo := Memo;
RegistryThread.OnTerminate := ThreadTerminated;
RegistryThread.Resume;
Result := RegistryThread;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
HKCRMemo.Clear;
HKCUMemo.Clear;
HKLMMemo.Clear;
HKUMemo.Clear;
HKCCMemo.Clear;
rtHKCR := RunThread(HKEY_CLASSES_ROOT,HKCRMemo);
rtHKCU := RunThread(HKEY_CURRENT_USER,HKCUMemo);
rtHKLM := RunThread(HKEY_LOCAL_MACHINE,HKLMMemo);
rtHKU := RunThread(HKEY_USERS,HKUMemo);
rtHKCC := RunThread(HKEY_CURRENT_CONFIG,HKCCMemo);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
Application.ProcessMessages;
If TotalDone < 1 Then
begin
Inc(TotalSeconds);
StaticText1.Caption := 'Current Time: ' + IntToStr(TotalSeconds) + 's';
end
Else
begin
StaticText1.Caption := 'Total Time: ' + IntToStr(TotalSeconds) + 's';
end;
Timer1.Enabled := True;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.DoubleBuffered := True;
HKCRMemo.DoubleBuffered := True;
HKCUMemo.DoubleBuffered := True;
HKLMMemo.DoubleBuffered := True;
HKUMemo.DoubleBuffered := True;
HKCCMemo.DoubleBuffered := True;
end;
end.