Subversion Repositories simple_log_event

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.