WebSVN – simple_log_event – Diff – /trunk/Setup/SimpleLogEventSetupMain.pas


unit SimpleLogEventSetupMain;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
 
type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    Edit1: TEdit;
    Button1: TButton;
    Edit2: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    GroupBox2: TGroupBox;
    ListBox1: TListBox;
    Edit3: TEdit;
    Button2: TButton;
    Button3: TButton;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    found32: string;
    found64: string;
    procedure CheckInstallation;
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
{$R DllRes.res}
 
uses
  ShellApi, ShlObj, Registry;
 
Function Wow64DisableWow64FsRedirection(Var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
  External 'Kernel32.dll' Name 'Wow64DisableWow64FsRedirection';
Function Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
  External 'Kernel32.dll' Name 'Wow64EnableWow64FsRedirection';
 
procedure RunAndWaitShell(Executable, Parameter: STRING; ShowParameter: INTEGER);
var
  Info: TShellExecuteInfo;
  pInfo: PShellExecuteInfo;
  exitCode: DWord;
begin
  // Source: https://www.delphipraxis.net/31067-shellexecute-wait.html
  pInfo := @Info;
  with Info do
  begin
    cbSize := SizeOf(Info);
    fMask := SEE_MASK_NOCLOSEPROCESS;
    wnd   := application.Handle;
    lpVerb := NIL;
    lpFile := PChar(Executable);
    lpParameters := PChar(Parameter + #0);
    lpDirectory := NIL;
    nShow       := ShowParameter;
    hInstApp    := 0;
  end;
  ShellExecuteEx(pInfo);
  repeat
    exitCode := WaitForSingleObject(Info.hProcess, 500);
    Application.ProcessMessages;
  until (exitCode <> WAIT_TIMEOUT);
end;
 
procedure RegSvr32(const dll: string);
begin
  //ShellExecute(Form1.Handle, 'open', 'regsvr32.exe', PChar('"' + dll + '"'), '', SW_NORMAL);
  RunAndWaitShell('regsvr32.exe', '"'+dll+'"', SW_NORMAL);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  rs: TResourceStream;
  Wow64FsEnableRedirection: LongBool;
  reg: TRegistry;
  sl: TStringList;
  kn: string;
  test: string;
  lastregfile: string;
begin
  if not IsUserAnAdmin  then
  begin
    raise Exception.Create('To register the libraries, this application needs to run as administrator.');
  end;
 
  try
    {$REGION 'Copy DLL to common files'}
 
    if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX86 then
    begin
      {$REGION '32 Bit Windows'}
      lastregfile := 'C:\Program Files\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent32.dll';
      ForceDirectories(ExtractFilePath(lastregfile));
      rs := TResourceStream.CreateFromID(HInstance, 32, PChar('DLL'));
      rs.SaveToFile(lastregfile);
      rs.Free;
      RegSvr32(lastregfile);
      {$ENDREGION}
    end;
 
    if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then
    begin
      {$REGION '64 Bit Windows'}
      Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
      try
        lastregfile := 'C:\Program Files (x86)\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent32.dll';
        ForceDirectories(ExtractFilePath(lastregfile));
        rs := TResourceStream.CreateFromID(HInstance, 32, PChar('DLL'));
        rs.SaveToFile(lastregfile);
        rs.Free;
        RegSvr32(lastregfile);
 
        lastregfile := 'C:\Program Files\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent64.dll';
        ForceDirectories(ExtractFilePath(lastregfile));
        rs := TResourceStream.CreateFromID(HInstance, 64, PChar('DLL'));
        rs.SaveToFile(lastregfile);
        rs.Free;
        RegSvr32(lastregfile);
      finally
        Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
      end;
      {$ENDREGION}
    end;
 
    {$ENDREGION}
 
    {$REGION 'Update DLL path in log provider list'}
    reg := TRegistry.Create;
    sl := TStringList.Create;
    try
      reg.RootKey := HKEY_LOCAL_MACHINE;
      if reg.OpenKey('SYSTEM\CurrentControlSet\services\eventlog\Application', false) then
      begin
        reg.GetKeyNames(sl);
        reg.CloseKey;
        for kn in sl do
        begin
          if reg.OpenKey('SYSTEM\CurrentControlSet\services\eventlog\Application\' + kn, false) then
          begin
            test := reg.ReadString('EventMessageFile');
            if Pos('VIATHINKSOFTSIMPLELOGEVENT', UpperCase(test)) > 0 then
            begin
              if test <> lastregfile then
              begin
                reg.WriteString('EventMessageFile', lastregfile);
              end;
            end;
            reg.CloseKey;
          end;
        end;
      end;
    finally
      FreeAndNil(reg);
      FreeAndNil(sl);
    end;
    {$ENDREGION}
 
  finally
    CheckInstallation;
  end;
end;
 
const
  DEFECTIVE_SUFFIX = ' (defective)';
 
procedure RegisterEventLogProvider(ProviderName, MessageFile: string);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if not reg.OpenKey('SYSTEM\CurrentControlSet\Services\Eventlog\Application\'+ProviderName, true) then
    begin
      raise Exception.Create('Cannot register EventLog provider! Please run the application as administrator');
    end
    else
    begin
      reg.WriteInteger('CategoryCount', 0);
      reg.WriteInteger('TypesSupported', 7);
      reg.WriteString('EventMessageFile', MessageFile);
      reg.WriteString('CategoryMessageFile', MessageFile);
      reg.CloseKey;
    end;
  finally
    reg.Free;
  end;
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  if FileExists(found64) then
  begin
    RegisterEventLogProvider(Edit3.Text, found64);
  end
  else if FileExists(found32) then
  begin
    RegisterEventLogProvider(Edit3.Text, found32);
  end
  else
  begin
    raise Exception.Create('Please first register the DLL');
  end;
 
  CheckInstallation;
 
  Edit3.Text := '';
end;
 
procedure TForm1.Button3Click(Sender: TObject);
var
  text: string;
  reg: TRegistry;
begin
  if ListBox1.ItemIndex = -1 then exit;
  text := ListBox1.Items.Strings[ListBox1.ItemIndex];
  text := StringReplace(text, DEFECTIVE_SUFFIX, '', []);
 
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if not reg.DeleteKey('SYSTEM\CurrentControlSet\services\eventlog\Application\' + text) then
    begin
      raise Exception.Create('Failed to remove item. Are you admin?');
    end;
  finally
    FreeAndNil(reg);
  end;
 
  CheckInstallation;
end;
 
procedure TForm1.CheckInstallation;
var
  reg: TRegistry;
  filename: string;
  Wow64FsEnableRedirection: LongBool;
  sl: TStrings;
  kn: string;
  test: string;
begin
  found32 := '';
  found64 := '';
 
  if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then
  begin
    Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
  end;
  try
    {$REGION '32 Bit'}
    reg := TRegistry.Create;
    try
      reg.RootKey := HKEY_CLASSES_ROOT;
      if not reg.OpenKeyReadOnly('TypeLib\{D7654BA7-41D0-4FF9-8543-C3A4DA936856}\1.0\0\win32') then
      begin
        Edit1.Text := 'NOT INSTALLED';
        Edit1.Color := clRed;
      end
      else
      begin
        filename := reg.ReadString('');
        if FileExists(filename) then
        begin
          Edit1.Text := 'Installed at ' + FileName;
          Edit1.Color := clLime;
          found32 := FileName;
        end
        else
        begin
          Edit1.Text := 'MISSING at location ' + FileName;
          Edit1.Color := clRed;
        end;
        reg.CloseKey;
      end;
    finally
      FreeAndNil(reg);
    end;
    {$ENDREGION}
 
    {$REGION '64 Bit'}
    if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX86 then
    begin
      Edit2.Text := 'Not applicable on a 32-bit operating system';
      Edit2.Color := clLime;
    end
    else
    begin
      reg := TRegistry.Create;
      try
        reg.RootKey := HKEY_CLASSES_ROOT;
        if not reg.OpenKeyReadOnly('TypeLib\{D7654BA7-41D0-4FF9-8543-C3A4DA936856}\1.0\0\win64') then
        begin
          Edit2.Text := 'NOT INSTALLED';
          Edit2.Color := clRed;
        end
        else
        begin
          filename := reg.ReadString('');
          if FileExists(filename) then
          begin
            Edit2.Text := 'Installed at ' + FileName;
            Edit2.Color := clLime;
            found64 := FileName;
          end
          else
          begin
            Edit2.Text := 'MISSING at location ' + FileName;
            Edit2.Color := clRed;
          end;
          reg.CloseKey;
        end;
      finally
        FreeAndNil(reg);
      end;
    end;
    {$ENDREGION}
 
  finally
    if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then
    begin
      Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
    end;
  end;
 
  {$REGION 'List providers'}
  ListBox1.Clear;
  reg := TRegistry.Create;
  sl := TStringList.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\services\eventlog\Application') then
    begin
      reg.GetKeyNames(sl);
      reg.CloseKey;
      for kn in sl do
      begin
        if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\services\eventlog\Application\' + kn) then
        begin
          test := reg.ReadString('EventMessageFile');
          if Pos('VIATHINKSOFTSIMPLELOGEVENT', UpperCase(test)) > 0 then
          begin
            if not FileExists(test) then
              ListBox1.Items.Add(kn + DEFECTIVE_SUFFIX)
            else
              ListBox1.Items.Add(kn);
          end;
          reg.CloseKey;
        end;
      end;
    end;
  finally
    FreeAndNil(reg);
    FreeAndNil(sl);
  end;
  {$ENDREGION}
end;
 
procedure TForm1.FormShow(Sender: TObject);
begin
  CheckInstallation;
end;
 
end.
 

Rev 3	Rev 5
1	unit SimpleLogEventSetupMain;	1	unit SimpleLogEventSetupMain;
2		2
3	interface	3	interface
4		4
5	uses	5	uses
6	Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,	6	Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
7	Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;	7	Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
8		8
9	type	9	type
10	TForm1 = class(TForm)	10	TForm1 = class(TForm)
11	GroupBox1: TGroupBox;	11	GroupBox1: TGroupBox;
12	Edit1: TEdit;	12	Edit1: TEdit;
13	Button1: TButton;	13	Button1: TButton;
14	Edit2: TEdit;	14	Edit2: TEdit;
15	Label1: TLabel;	15	Label1: TLabel;
16	Label2: TLabel;	16	Label2: TLabel;
17	GroupBox2: TGroupBox;	17	GroupBox2: TGroupBox;
18	ListBox1: TListBox;	18	ListBox1: TListBox;
19	Edit3: TEdit;	19	Edit3: TEdit;
20	Button2: TButton;	20	Button2: TButton;
21	Button3: TButton;	21	Button3: TButton;
22	Label3: TLabel;	22	Label3: TLabel;
23	Label4: TLabel;	23	Label4: TLabel;
24	Label5: TLabel;	24	Label5: TLabel;
25	Label6: TLabel;	25	Label6: TLabel;
26	Label7: TLabel;	26	Label7: TLabel;
27	Label8: TLabel;	27	Label8: TLabel;
28	Label9: TLabel;	28	Label9: TLabel;
29	Label10: TLabel;	29	Label10: TLabel;
30	procedure Button1Click(Sender: TObject);	30	procedure Button1Click(Sender: TObject);
31	procedure FormShow(Sender: TObject);	31	procedure FormShow(Sender: TObject);
32	procedure Button2Click(Sender: TObject);	32	procedure Button2Click(Sender: TObject);
33	procedure Button3Click(Sender: TObject);	33	procedure Button3Click(Sender: TObject);
34	private	34	private
35	found32: string;	35	found32: string;
36	found64: string;	36	found64: string;
37	procedure CheckInstallation;	37	procedure CheckInstallation;
38	{ Private-Deklarationen }	38	{ Private-Deklarationen }
39	public	39	public
40	{ Public-Deklarationen }	40	{ Public-Deklarationen }
41	end;	41	end;
42		42
43	var	43	var
44	Form1: TForm1;	44	Form1: TForm1;
45		45
46	implementation	46	implementation
47		47
48	{$R *.dfm}	48	{$R *.dfm}
49		49
50	{$R DllRes.res}	50	{$R DllRes.res}
51		51
52	uses	52	uses
53	ShellApi, ShlObj, Registry;	53	ShellApi, ShlObj, Registry;
54		54
55	Function Wow64DisableWow64FsRedirection(Var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;	55	Function Wow64DisableWow64FsRedirection(Var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
56	External 'Kernel32.dll' Name 'Wow64DisableWow64FsRedirection';	56	External 'Kernel32.dll' Name 'Wow64DisableWow64FsRedirection';
57	Function Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection: LongBool): LongBool; StdCall;	57	Function Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
58	External 'Kernel32.dll' Name 'Wow64EnableWow64FsRedirection';	58	External 'Kernel32.dll' Name 'Wow64EnableWow64FsRedirection';
59		59
-		60	procedure RunAndWaitShell(Executable, Parameter: STRING; ShowParameter: INTEGER);
-		61	var
-		62	Info: TShellExecuteInfo;
-		63	pInfo: PShellExecuteInfo;
-		64	exitCode: DWord;
-		65	begin
-		66	// Source: https://www.delphipraxis.net/31067-shellexecute-wait.html
-		67	pInfo := @Info;
-		68	with Info do
-		69	begin
-		70	cbSize := SizeOf(Info);
-		71	fMask := SEE_MASK_NOCLOSEPROCESS;
-		72	wnd := application.Handle;
-		73	lpVerb := NIL;
-		74	lpFile := PChar(Executable);
-		75	lpParameters := PChar(Parameter + #0);
-		76	lpDirectory := NIL;
-		77	nShow := ShowParameter;
-		78	hInstApp := 0;
-		79	end;
-		80	ShellExecuteEx(pInfo);
-		81	repeat
-		82	exitCode := WaitForSingleObject(Info.hProcess, 500);
-		83	Application.ProcessMessages;
-		84	until (exitCode <> WAIT_TIMEOUT);
-		85	end;
-		86
60	procedure RegSvr32(const dll: string);	87	procedure RegSvr32(const dll: string);
61	begin	88	begin
62	ShellExecute(Form1.Handle, 'open', 'regsvr32.exe', PChar('"' + dll + '"'), '', SW_NORMAL);	89	//ShellExecute(Form1.Handle, 'open', 'regsvr32.exe', PChar('"' + dll + '"'), '', SW_NORMAL);
-		90	RunAndWaitShell('regsvr32.exe', '"'+dll+'"', SW_NORMAL);
63	end;	91	end;
64		92
65	procedure TForm1.Button1Click(Sender: TObject);	93	procedure TForm1.Button1Click(Sender: TObject);
66	var	94	var
67	rs: TResourceStream;	95	rs: TResourceStream;
68	Wow64FsEnableRedirection: LongBool;	96	Wow64FsEnableRedirection: LongBool;
69	reg: TRegistry;	97	reg: TRegistry;
70	sl: TStringList;	98	sl: TStringList;
71	kn: string;	99	kn: string;
72	test: string;	100	test: string;
73	lastregfile: string;	101	lastregfile: string;
74	begin	102	begin
75	if not IsUserAnAdmin then	103	if not IsUserAnAdmin then
76	begin	104	begin
77	raise Exception.Create('To register the libraries, this application needs to run as administrator.');	105	raise Exception.Create('To register the libraries, this application needs to run as administrator.');
78	end;	106	end;
79		107
80	try	108	try
81	{$REGION 'Copy DLL to common files'}	109	{$REGION 'Copy DLL to common files'}
82		110
83	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX86 then	111	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX86 then
84	begin	112	begin
85	{$REGION '32 Bit Windows'}	113	{$REGION '32 Bit Windows'}
86	lastregfile := 'C:\Program Files\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent32.dll';	114	lastregfile := 'C:\Program Files\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent32.dll';
87	ForceDirectories(ExtractFilePath(lastregfile));	115	ForceDirectories(ExtractFilePath(lastregfile));
88	rs := TResourceStream.CreateFromID(HInstance, 32, PChar('DLL'));	116	rs := TResourceStream.CreateFromID(HInstance, 32, PChar('DLL'));
89	rs.SaveToFile(lastregfile);	117	rs.SaveToFile(lastregfile);
90	rs.Free;	118	rs.Free;
91	RegSvr32(lastregfile);	119	RegSvr32(lastregfile);
92	{$ENDREGION}	120	{$ENDREGION}
93	end;	121	end;
94		122
95	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then	123	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then
96	begin	124	begin
97	{$REGION '64 Bit Windows'}	125	{$REGION '64 Bit Windows'}
98	Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);	126	Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
99	try	127	try
100	lastregfile := 'C:\Program Files (x86)\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent32.dll';	128	lastregfile := 'C:\Program Files (x86)\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent32.dll';
101	ForceDirectories(ExtractFilePath(lastregfile));	129	ForceDirectories(ExtractFilePath(lastregfile));
102	rs := TResourceStream.CreateFromID(HInstance, 32, PChar('DLL'));	130	rs := TResourceStream.CreateFromID(HInstance, 32, PChar('DLL'));
103	rs.SaveToFile(lastregfile);	131	rs.SaveToFile(lastregfile);
104	rs.Free;	132	rs.Free;
105	RegSvr32(lastregfile);	133	RegSvr32(lastregfile);
106		134
107	lastregfile := 'C:\Program Files\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent64.dll';	135	lastregfile := 'C:\Program Files\Common Files\ViaThinkSoft\ViaThinkSoftSimpleLogEvent64.dll';
108	ForceDirectories(ExtractFilePath(lastregfile));	136	ForceDirectories(ExtractFilePath(lastregfile));
109	rs := TResourceStream.CreateFromID(HInstance, 64, PChar('DLL'));	137	rs := TResourceStream.CreateFromID(HInstance, 64, PChar('DLL'));
110	rs.SaveToFile(lastregfile);	138	rs.SaveToFile(lastregfile);
111	rs.Free;	139	rs.Free;
112	RegSvr32(lastregfile);	140	RegSvr32(lastregfile);
113	finally	141	finally
114	Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);	142	Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
115	end;	143	end;
116	{$ENDREGION}	144	{$ENDREGION}
117	end;	145	end;
118		146
119	{$ENDREGION}	147	{$ENDREGION}
120		148
121	{$REGION 'Update DLL path in log provider list'}	149	{$REGION 'Update DLL path in log provider list'}
122	reg := TRegistry.Create;	150	reg := TRegistry.Create;
123	sl := TStringList.Create;	151	sl := TStringList.Create;
124	try	152	try
125	reg.RootKey := HKEY_LOCAL_MACHINE;	153	reg.RootKey := HKEY_LOCAL_MACHINE;
126	if reg.OpenKey('SYSTEM\CurrentControlSet\services\eventlog\Application', false) then	154	if reg.OpenKey('SYSTEM\CurrentControlSet\services\eventlog\Application', false) then
127	begin	155	begin
128	reg.GetKeyNames(sl);	156	reg.GetKeyNames(sl);
129	reg.CloseKey;	157	reg.CloseKey;
130	for kn in sl do	158	for kn in sl do
131	begin	159	begin
132	if reg.OpenKey('SYSTEM\CurrentControlSet\services\eventlog\Application\' + kn, false) then	160	if reg.OpenKey('SYSTEM\CurrentControlSet\services\eventlog\Application\' + kn, false) then
133	begin	161	begin
134	test := reg.ReadString('EventMessageFile');	162	test := reg.ReadString('EventMessageFile');
135	if Pos('VIATHINKSOFTSIMPLELOGEVENT', UpperCase(test)) > 0 then	163	if Pos('VIATHINKSOFTSIMPLELOGEVENT', UpperCase(test)) > 0 then
136	begin	164	begin
137	if test <> lastregfile then	165	if test <> lastregfile then
138	begin	166	begin
139	reg.WriteString('EventMessageFile', lastregfile);	167	reg.WriteString('EventMessageFile', lastregfile);
140	end;	168	end;
141	end;	169	end;
142	reg.CloseKey;	170	reg.CloseKey;
143	end;	171	end;
144	end;	172	end;
145	end;	173	end;
146	finally	174	finally
147	FreeAndNil(reg);	175	FreeAndNil(reg);
148	FreeAndNil(sl);	176	FreeAndNil(sl);
149	end;	177	end;
150	{$ENDREGION}	178	{$ENDREGION}
151		179
152	finally	180	finally
153	CheckInstallation;	181	CheckInstallation;
154	end;	182	end;
155	end;	183	end;
156		184
157	const	185	const
158	DEFECTIVE_SUFFIX = ' (defective)';	186	DEFECTIVE_SUFFIX = ' (defective)';
159		187
160	procedure RegisterEventLogProvider(ProviderName, MessageFile: string);	188	procedure RegisterEventLogProvider(ProviderName, MessageFile: string);
161	var	189	var
162	reg: TRegistry;	190	reg: TRegistry;
163	begin	191	begin
164	reg := TRegistry.Create;	192	reg := TRegistry.Create;
165	try	193	try
166	reg.RootKey := HKEY_LOCAL_MACHINE;	194	reg.RootKey := HKEY_LOCAL_MACHINE;
167	if not reg.OpenKey('SYSTEM\CurrentControlSet\Services\Eventlog\Application\'+ProviderName, true) then	195	if not reg.OpenKey('SYSTEM\CurrentControlSet\Services\Eventlog\Application\'+ProviderName, true) then
168	begin	196	begin
169	raise Exception.Create('Cannot register EventLog provider! Please run the application as administrator');	197	raise Exception.Create('Cannot register EventLog provider! Please run the application as administrator');
170	end	198	end
171	else	199	else
172	begin	200	begin
173	reg.WriteInteger('CategoryCount', 0);	201	reg.WriteInteger('CategoryCount', 0);
174	reg.WriteInteger('TypesSupported', 7);	202	reg.WriteInteger('TypesSupported', 7);
175	reg.WriteString('EventMessageFile', MessageFile);	203	reg.WriteString('EventMessageFile', MessageFile);
176	reg.WriteString('CategoryMessageFile', MessageFile);	204	reg.WriteString('CategoryMessageFile', MessageFile);
177	reg.CloseKey;	205	reg.CloseKey;
178	end;	206	end;
179	finally	207	finally
180	reg.Free;	208	reg.Free;
181	end;	209	end;
182	end;	210	end;
183		211
184	procedure TForm1.Button2Click(Sender: TObject);	212	procedure TForm1.Button2Click(Sender: TObject);
185	begin	213	begin
186	if FileExists(found64) then	214	if FileExists(found64) then
187	begin	215	begin
188	RegisterEventLogProvider(Edit3.Text, found64);	216	RegisterEventLogProvider(Edit3.Text, found64);
189	end	217	end
190	else if FileExists(found32) then	218	else if FileExists(found32) then
191	begin	219	begin
192	RegisterEventLogProvider(Edit3.Text, found32);	220	RegisterEventLogProvider(Edit3.Text, found32);
193	end	221	end
194	else	222	else
195	begin	223	begin
196	raise Exception.Create('Please first register the DLL');	224	raise Exception.Create('Please first register the DLL');
197	end;	225	end;
198		226
199	CheckInstallation;	227	CheckInstallation;
200		228
201	Edit3.Text := '';	229	Edit3.Text := '';
202	end;	230	end;
203		231
204	procedure TForm1.Button3Click(Sender: TObject);	232	procedure TForm1.Button3Click(Sender: TObject);
205	var	233	var
206	text: string;	234	text: string;
207	reg: TRegistry;	235	reg: TRegistry;
208	begin	236	begin
209	if ListBox1.ItemIndex = -1 then exit;	237	if ListBox1.ItemIndex = -1 then exit;
210	text := ListBox1.Items.Strings[ListBox1.ItemIndex];	238	text := ListBox1.Items.Strings[ListBox1.ItemIndex];
211	text := StringReplace(text, DEFECTIVE_SUFFIX, '', []);	239	text := StringReplace(text, DEFECTIVE_SUFFIX, '', []);
212		240
213	reg := TRegistry.Create;	241	reg := TRegistry.Create;
214	try	242	try
215	reg.RootKey := HKEY_LOCAL_MACHINE;	243	reg.RootKey := HKEY_LOCAL_MACHINE;
216	if not reg.DeleteKey('SYSTEM\CurrentControlSet\services\eventlog\Application\' + text) then	244	if not reg.DeleteKey('SYSTEM\CurrentControlSet\services\eventlog\Application\' + text) then
217	begin	245	begin
218	raise Exception.Create('Failed to remove item. Are you admin?');	246	raise Exception.Create('Failed to remove item. Are you admin?');
219	end;	247	end;
220	finally	248	finally
221	FreeAndNil(reg);	249	FreeAndNil(reg);
222	end;	250	end;
223		251
224	CheckInstallation;	252	CheckInstallation;
225	end;	253	end;
226		254
227	procedure TForm1.CheckInstallation;	255	procedure TForm1.CheckInstallation;
228	var	256	var
229	reg: TRegistry;	257	reg: TRegistry;
230	filename: string;	258	filename: string;
231	Wow64FsEnableRedirection: LongBool;	259	Wow64FsEnableRedirection: LongBool;
232	sl: TStrings;	260	sl: TStrings;
233	kn: string;	261	kn: string;
234	test: string;	262	test: string;
235	begin	263	begin
236	found32 := '';	264	found32 := '';
237	found64 := '';	265	found64 := '';
238		266
239	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then	267	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then
240	begin	268	begin
241	Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);	269	Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
242	end;	270	end;
243	try	271	try
244	{$REGION '32 Bit'}	272	{$REGION '32 Bit'}
245	reg := TRegistry.Create;	273	reg := TRegistry.Create;
246	try	274	try
247	reg.RootKey := HKEY_CLASSES_ROOT;	275	reg.RootKey := HKEY_CLASSES_ROOT;
248	if not reg.OpenKeyReadOnly('TypeLib\{D7654BA7-41D0-4FF9-8543-C3A4DA936856}\1.0\0\win32') then	276	if not reg.OpenKeyReadOnly('TypeLib\{D7654BA7-41D0-4FF9-8543-C3A4DA936856}\1.0\0\win32') then
249	begin	277	begin
250	Edit1.Text := 'NOT INSTALLED';	278	Edit1.Text := 'NOT INSTALLED';
251	Edit1.Color := clRed;	279	Edit1.Color := clRed;
252	end	280	end
253	else	281	else
254	begin	282	begin
255	filename := reg.ReadString('');	283	filename := reg.ReadString('');
256	if FileExists(filename) then	284	if FileExists(filename) then
257	begin	285	begin
258	Edit1.Text := 'Installed at ' + FileName;	286	Edit1.Text := 'Installed at ' + FileName;
259	Edit1.Color := clLime;	287	Edit1.Color := clLime;
260	found32 := FileName;	288	found32 := FileName;
261	end	289	end
262	else	290	else
263	begin	291	begin
264	Edit1.Text := 'MISSING at location ' + FileName;	292	Edit1.Text := 'MISSING at location ' + FileName;
265	Edit1.Color := clRed;	293	Edit1.Color := clRed;
266	end;	294	end;
267	reg.CloseKey;	295	reg.CloseKey;
268	end;	296	end;
269	finally	297	finally
270	FreeAndNil(reg);	298	FreeAndNil(reg);
271	end;	299	end;
272	{$ENDREGION}	300	{$ENDREGION}
273		301
274	{$REGION '64 Bit'}	302	{$REGION '64 Bit'}
275	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX86 then	303	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX86 then
276	begin	304	begin
277	Edit2.Text := 'Not applicable on a 32-bit operating system';	305	Edit2.Text := 'Not applicable on a 32-bit operating system';
278	Edit2.Color := clLime;	306	Edit2.Color := clLime;
279	end	307	end
280	else	308	else
281	begin	309	begin
282	reg := TRegistry.Create;	310	reg := TRegistry.Create;
283	try	311	try
284	reg.RootKey := HKEY_CLASSES_ROOT;	312	reg.RootKey := HKEY_CLASSES_ROOT;
285	if not reg.OpenKeyReadOnly('TypeLib\{D7654BA7-41D0-4FF9-8543-C3A4DA936856}\1.0\0\win64') then	313	if not reg.OpenKeyReadOnly('TypeLib\{D7654BA7-41D0-4FF9-8543-C3A4DA936856}\1.0\0\win64') then
286	begin	314	begin
287	Edit2.Text := 'NOT INSTALLED';	315	Edit2.Text := 'NOT INSTALLED';
288	Edit2.Color := clRed;	316	Edit2.Color := clRed;
289	end	317	end
290	else	318	else
291	begin	319	begin
292	filename := reg.ReadString('');	320	filename := reg.ReadString('');
293	if FileExists(filename) then	321	if FileExists(filename) then
294	begin	322	begin
295	Edit2.Text := 'Installed at ' + FileName;	323	Edit2.Text := 'Installed at ' + FileName;
296	Edit2.Color := clLime;	324	Edit2.Color := clLime;
297	found64 := FileName;	325	found64 := FileName;
298	end	326	end
299	else	327	else
300	begin	328	begin
301	Edit2.Text := 'MISSING at location ' + FileName;	329	Edit2.Text := 'MISSING at location ' + FileName;
302	Edit2.Color := clRed;	330	Edit2.Color := clRed;
303	end;	331	end;
304	reg.CloseKey;	332	reg.CloseKey;
305	end;	333	end;
306	finally	334	finally
307	FreeAndNil(reg);	335	FreeAndNil(reg);
308	end;	336	end;
309	end;	337	end;
310	{$ENDREGION}	338	{$ENDREGION}
311		339
312	finally	340	finally
313	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then	341	if TOSVersion.Architecture = TOSVersion.TArchitecture.arIntelX64 then
314	begin	342	begin
315	Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);	343	Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
316	end;	344	end;
317	end;	345	end;
318		346
319	{$REGION 'List providers'}	347	{$REGION 'List providers'}
320	ListBox1.Clear;	348	ListBox1.Clear;
321	reg := TRegistry.Create;	349	reg := TRegistry.Create;
322	sl := TStringList.Create;	350	sl := TStringList.Create;
323	try	351	try
324	reg.RootKey := HKEY_LOCAL_MACHINE;	352	reg.RootKey := HKEY_LOCAL_MACHINE;
325	if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\services\eventlog\Application') then	353	if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\services\eventlog\Application') then
326	begin	354	begin
327	reg.GetKeyNames(sl);	355	reg.GetKeyNames(sl);
328	reg.CloseKey;	356	reg.CloseKey;
329	for kn in sl do	357	for kn in sl do
330	begin	358	begin
331	if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\services\eventlog\Application\' + kn) then	359	if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\services\eventlog\Application\' + kn) then
332	begin	360	begin
333	test := reg.ReadString('EventMessageFile');	361	test := reg.ReadString('EventMessageFile');
334	if Pos('VIATHINKSOFTSIMPLELOGEVENT', UpperCase(test)) > 0 then	362	if Pos('VIATHINKSOFTSIMPLELOGEVENT', UpperCase(test)) > 0 then
335	begin	363	begin
336	if not FileExists(test) then	364	if not FileExists(test) then
337	ListBox1.Items.Add(kn + DEFECTIVE_SUFFIX)	365	ListBox1.Items.Add(kn + DEFECTIVE_SUFFIX)
338	else	366	else
339	ListBox1.Items.Add(kn);	367	ListBox1.Items.Add(kn);
340	end;	368	end;
341	reg.CloseKey;	369	reg.CloseKey;
342	end;	370	end;
343	end;	371	end;
344	end;	372	end;
345	finally	373	finally
346	FreeAndNil(reg);	374	FreeAndNil(reg);
347	FreeAndNil(sl);	375	FreeAndNil(sl);
348	end;	376	end;
349	{$ENDREGION}	377	{$ENDREGION}
350	end;	378	end;
351		379
352	procedure TForm1.FormShow(Sender: TObject);	380	procedure TForm1.FormShow(Sender: TObject);
353	begin	381	begin
354	CheckInstallation;	382	CheckInstallation;
355	end;	383	end;
356		384
357	end.	385	end.
358		386

Subversion Repositories simple_log_event

simple_log_event/trunk/Setup/SimpleLogEventSetupMain.pas – Rev 3 → 5