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 RegSvr32(const dll: string);
begin
ShellExecute(Form1.Handle, 'open', 'regsvr32.exe', PChar('"' + 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.