unit cuUtils;

interface

uses
  // VCL
  Windows, ActiveX, Registry, Graphics, SysUtils, Classes, Dialogs, Forms,
  ComObj, StdCtrls, ComCtrls;

const
  REGSTR_KEY_FONT             = 'Font';
  REGSTR_PATH_FONT            = 'Software\ATOL\';
  REGSTR_VAL_FONTNAME         = 'FontName';
  REGSTR_VAL_FONTSIZE         = 'FontSize';
  REGSTR_VAL_FONTCOLOR        = 'FontColor';
  REGSTR_VAL_FONTCHARSET      = 'FontCharSet';
  REGSTR_VAL_FONTISBOLD       = 'FontIsBold';
  REGSTR_VAL_FONTISITALIC     = 'FontIsItalic';
  REGSTR_VAL_FONTISUNDERLINED = 'FontIsUnderlined';
  REGSTR_VAL_FONTISSTRIKEDOUT = 'FontIsStriledOut';
  REGSTR_VAL_SHOWDEMOONSTART  = 'ShowDemoOnStart';
  REGSTR_KEY_LINETEST         = 'Software\ATOL\Drivers\5.0\Displays\Line_T';

  DEFAULT_FONTNAME            = 'MS Sans Serif';
  DEFAULT_FONTSIZE            = 8;
  DEFAULT_FONTCOLOR           = clBlack;
  DEFAULT_FONTCHARSET         = DEFAULT_CHARSET;
  DEFAULT_FONTISBOLD          = False;
  DEFAULT_FONTISITALIC        = False;
  DEFAULT_FONTISUNDERLINED    = False;
  DEFAULT_FONTISSTRIKEDOUT    = False;

  STR_REG_DLL = '  . '#13+
    '    %s';

  STR_REG_LS =
    '     %s.'#13 +
    ' :'#13 +
    '   '#13 +
    ' ,    , .'#13#13 +
    '""'#9#9'  '#13 +
    '""'#9#9'    '#13 +
    '""'#9#9'  ';

procedure RegReadFont(Font :TFont);
procedure RegSaveFont(Font: TFont);
function GetFileVersionInfo: string;
function GetRegistryShowDemoOnStart: Boolean;
procedure SetRegistryShowDemoOnStart(Value: Boolean);
function RegisterDriverObject(const CLSID: TGUID;
  const FileName: String): Integer;
function RegisterServerObject(const CLSID: TGUID;
  const FileName: String): Integer;
procedure SafeSetChecked(CheckBox: TCheckBox; Value: Boolean);
procedure SafeSetComboBox(ComboBox: TComboBox; Value: Integer);
procedure SafeSetEdit(Edit: TEdit; const Value: String);
procedure SafeSetTrackBar(TrackBar: TTrackBar; Value: Integer);
function StrToIntRus(const Value: String): Integer;

implementation

function StrToIntRus(const Value: String): Integer;
begin
  try
    Result := StrToInt(Value);
  except
    raise EConvertError.CreateFmt('"%s"    ', [Value]);
  end;
end;

function GetRegistryShowDemoOnStart: Boolean;
var
  Reg: TRegistry;
begin
  Result := True;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(REGSTR_KEY_LINETEST, False) and
      Reg.ValueExists(REGSTR_VAL_SHOWDEMOONSTART) then
      Result := Reg.ReadBool(REGSTR_VAL_SHOWDEMOONSTART)
  finally
    Reg.Free;
  end;
end;

procedure SetRegistryShowDemoOnStart(Value: Boolean);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(REGSTR_KEY_LINETEST, True) then
      Reg.WriteBool(REGSTR_VAL_SHOWDEMOONSTART, Value);
  finally
    Reg.Free;
  end;
end;

procedure SafeSetChecked(CheckBox: TCheckBox; Value: Boolean);
var
  SaveOnClick: TNotifyEvent;
begin
  SaveOnClick := CheckBox.OnClick;
  CheckBox.OnClick := nil;
  try
    CheckBox.Checked := Value;
  finally
    CheckBox.OnClick := SaveOnClick;
  end;
end;

procedure SafeSetComboBox(ComboBox: TComboBox; Value: Integer);
var
  SaveOnChange: TNotifyEvent;
begin
  SaveOnChange := ComboBox.OnChange;
  ComboBox.OnChange := nil;
  try
    ComboBox.ItemIndex := Value;
  finally
    ComboBox.OnChange := SaveOnChange;
  end;
end;

procedure SafeSetEdit(Edit: TEdit; const Value: String);
var
  SaveOnChange: TNotifyEvent;
begin
  SaveOnChange := Edit.OnChange;
  Edit.OnChange := nil;
  try
    Edit.Text := Value;
  finally
    Edit.OnChange := SaveOnChange;
  end;
end;


procedure SafeSetTrackBar(TrackBar: TTrackBar; Value: Integer);
var
  SaveOnChange: TNotifyEvent;
begin
  SaveOnChange := TrackBar.OnChange;
  TrackBar.OnChange := nil;
  try
    TrackBar.Position := Value;
  finally
    TrackBar.OnChange := SaveOnChange;
  end;
end;

procedure RegReadFont(Font :TFont);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey(REGSTR_PATH_FONT + REGSTR_KEY_FONT, False) then
    begin
      if Reg.ValueExists(REGSTR_VAL_FONTNAME) then
        Font.Name := Reg.ReadString(REGSTR_VAL_FONTNAME)
      else
        Font.Name := DEFAULT_FONTNAME;

      if Reg.ValueExists(REGSTR_VAL_FONTSIZE) then
        Font.Size := Reg.ReadInteger(REGSTR_VAL_FONTSIZE)
      else
        Font.Size := DEFAULT_FONTSIZE;


      if Reg.ValueExists(REGSTR_VAL_FONTCOLOR) then
        Font.Color := Reg.ReadInteger(REGSTR_VAL_FONTCOLOR)
      else
        Font.Color := DEFAULT_FONTCOLOR;

      if Reg.ValueExists(REGSTR_VAL_FONTCHARSET) then
        Font.Charset := Reg.ReadInteger(REGSTR_VAL_FONTCHARSET)
      else
        Font.Charset := DEFAULT_FONTCHARSET;

      Font.Style :=[];

      if Reg.ValueExists(REGSTR_VAL_FONTISBOLD) and
        Reg.ReadBool(REGSTR_VAL_FONTISBOLD) then
        Font.Style := Font.Style + [fsBold];

      if Reg.ValueExists(REGSTR_VAL_FONTISITALIC) and
        Reg.ReadBool(REGSTR_VAL_FONTISITALIC) then
        Font.Style := Font.Style + [fsItalic];

      if Reg.ValueExists(REGSTR_VAL_FONTISUNDERLINED) and
        Reg.ReadBool(REGSTR_VAL_FONTISUNDERLINED) then
        Font.Style := Font.Style + [fsUnderline];

      if Reg.ValueExists(REGSTR_VAL_FONTISSTRIKEDOUT) and
        Reg.ReadBool(REGSTR_VAL_FONTISSTRIKEDOUT) then
        Font.Style := Font.Style + [fsStrikeOut];
    end else
    begin
      Font.Name := DEFAULT_FONTNAME;
      Font.Size := DEFAULT_FONTSIZE;
      Font.Color := DEFAULT_FONTCOLOR;
      Font.Charset := DEFAULT_FONTCHARSET;
      Font.Style :=[];
    end;
  finally
    Reg.Free;
  end;
end;

procedure RegSaveFont(Font: TFont);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey(REGSTR_PATH_FONT + REGSTR_KEY_FONT, True);
    Reg.WriteString(REGSTR_VAL_FONTNAME, Font.Name);
    Reg.WriteInteger(REGSTR_VAL_FONTSIZE, Font.Size);
    Reg.WriteInteger(REGSTR_VAL_FONTCOLOR, Font.Color);
    Reg.WriteInteger(REGSTR_VAL_FONTCHARSET, Font.Charset);
    Reg.WriteBool(REGSTR_VAL_FONTISBOLD, (fsBold in Font.Style));
    Reg.WriteBool(REGSTR_VAL_FONTISITALIC, (fsItalic in Font.Style));
    Reg.WriteBool(REGSTR_VAL_FONTISUNDERLINED, (fsUnderline in Font.Style));
    Reg.WriteBool(REGSTR_VAL_FONTISSTRIKEDOUT, (fsStrikeOut in Font.Style));
  finally
    Reg.Free;
  end;
end;

function GetFileVersionInfo: string;
var
  hVerInfo: THandle;
  hGlobal: THandle;
  AddrRes: pointer;
  Buf: array[0..7]of byte;

  MajorVersion: WORD;
  MinorVersion: WORD;
  ProductRelease: WORD;
  ProductBuild: WORD;
begin
  hVerInfo:= FindResource(hInstance, '#1', RT_VERSION);
  if hVerInfo = 0 then
    Result := '0.0.0.0'
  else
  begin
    hGlobal := LoadResource(hInstance, hVerInfo);
    if hGlobal = 0 then
      Result := '0.0.0.0'
    else
    begin
      AddrRes:= LockResource(hGlobal);
      CopyMemory(@Buf, Pointer(Integer(AddrRes)+48), 8);

      MinorVersion := Buf[0] + Buf[1]*$100;
      MajorVersion := Buf[2] + Buf[3]*$100;
      ProductBuild := Buf[4] + Buf[5]*$100;
      ProductRelease := Buf[6] + Buf[7]*$100;

      Result := Format('%d.%d.%d.%d',
        [MajorVersion, MinorVersion, ProductRelease, ProductBuild]);
      FreeResource(hGlobal);
    end;
  end;
end;

function ExtractQuotedStr(const Src: String): String;
begin
  Result := Src;
  if Src[1] = '"' then Delete(Result, 1, 1);;
  if Result[Length(Result)] = '"' then SetLength(Result, Length(Result) - 1);
end;

function CLSIDToFileName(const CLSID: TGUID): String;
var
  Reg: TRegistry;
  strCLSID: String;
begin
  Result := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey:= HKEY_CLASSES_ROOT;
    strCLSID := GUIDToString(CLSID);
    if Reg.OpenKey(Format('CLSID\%s\InProcServer32', [strCLSID]), False)
       or Reg.OpenKey(Format('CLSID\%s\LocalServer32', [strCLSID]), False) then
    begin
      try
        Result := ExtractQuotedStr(Reg.ReadString(''));
      finally
        Reg.CloseKey;
      end;
    end;
  finally
    Reg.Free;
  end;
end;

function GetDriverFileByCLSID(const CLSID: TGUID): String;
begin
  Result := CLSIDToFileName(CLSID);
end;

function RegisterDriverByFileName(const FileName: string; const CLSID: TGUID): Boolean;
begin
  try
    RegisterComServer(FileName);
    Result := AnsiCompareFileName(GetDriverFileByCLSID(CLSID), FileName) = 0;
  except
    Result := False;
  end;
end;

function RegisterDriver(const CLSID: TGUID;
  const Query: String; const FileName: String): Integer;
const
  BoolToID: array[Boolean] of Integer = (IDCancel, IDOk); 
var
  OpenDialog: TOpenDialog;
begin
  with Application do
  Result := MessageBox(
     PChar(Format(Query, [FileName])),
     PChar(Title),
     mb_IconExclamation or mb_OKCancel);
  if Result = IDCancel then Exit; 
  OpenDialog := TOpenDialog.Create(nil);
  try
    OpenDialog.FileName := FileName;
    OpenDialog.Filter := ' (*.dll)|*.dll|'+
      ' OCX (*.OCX)|*.OCX|  (*.*)|*.*';
    OpenDialog.Options := [ofHideReadOnly, ofPathMustExist, ofFileMustExist];
    if not OpenDialog.Execute then
    begin
      Result := IDCancel;
      Exit;
    end;
    Result := BoolToID[RegisterDriverByFileName(OpenDialog.FileName, CLSID)];
  finally
    OpenDialog.Free;
  end;
end;

function RegisterExeServer(const FileName: string): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  Directory: String;
  Command: String;
begin
  Result := False;
  Directory := ExtractFilePath(FileName);
  Command := ExtractFileName(FileName) + ' /RegServer';

  FillChar(StartupInfo, SizeOf(StartupInfo) , 0 );
  with StartupInfo do
  begin
    cb := SizeOf(StartupInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := SW_HIDE;
  end;
  if CreateProcess(
       nil,             // lpApplicationName
       PChar(Command),              // lpCommandLine
       nil,                         // lpProcessAttributes
       nil,                         // lpThreadAttributes
       False,                       // bInheritHandles
       NORMAL_PRIORITY_CLASS,       // dwCreationFlags
       nil,                         // pEnvironment
       PChar(Directory),            // lpCurrentDirectory
       StartupInfo,                 // lpStartupInfo
       ProcessInfo)                 // lpProcessInformation
  then
  begin
    CloseHandle(ProcessInfo.hThread);
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    CloseHandle(ProcessInfo.hProcess);
    Result := True;
  end;
  {??? else
    RaiseLastWin32Error; }
end;

function GetExeDriverFileByCLSID(const CLSID: TGUID): String;
begin
  Result := CLSIDToFileName(CLSID);
end;

function RegisterExeDriverByFileName(const FileName: string;
  const CLSID: TGUID): Boolean;
begin
  try
    RegisterExeServer(FileName);
    Result := AnsiCompareFileName(GetExeDriverFileByCLSID(CLSID), FileName) = 0;
  except
    Result := False;
  end;
end;

function RegisterServer(const CLSID: TGUID;
  const FileName: String): Integer;
var
  OpenDialog: TOpenDialog;
begin
  Result := Application.MessageBox(
    PChar(Format(STR_REG_LS, [FileName])),
    PChar(Application.Title),
    mb_IconExclamation or mb_YesNoCancel);
  case Result of
    IDCancel, IDNo: Exit;
    IDYes:
    begin
      OpenDialog := TOpenDialog.Create(nil);
      try
        OpenDialog.FileName := FileName;
        OpenDialog.Filter := '  (*.exe)|*.exe|' +
          '  (*.*)|*.*';
        OpenDialog.DefaultExt := 'exe';
        OpenDialog.Options := [ofHideReadOnly, ofPathMustExist, ofFileMustExist];
        if not OpenDialog.Execute then
        begin
          Result := IDCancel;
          Exit;
        end;
        if not RegisterExeDriverByFileName(OpenDialog.FileName, CLSID) then
        begin
          Result := IDNo;
          Exit;
        end;
      finally
        OpenDialog.Free;
      end;
    end;
  end;
end;

function RegisterDriverObject(const CLSID: TGUID; const FileName: String): Integer;
var
  obj: IUnknown;
begin
  repeat
    try
      obj := CreateComObject(CLSID);
      Result := IDOk;
    except
      Result := RegisterDriver(CLSID, STR_REG_DLL, FileName);
    end;
  until (obj <> nil) or (Result = IDCancel);
end;

function RegisterServerObject(const CLSID: TGUID; const FileName: String): Integer;
var
  obj: IUnknown;
begin
  repeat
    try
      obj := CreateComObject(CLSID);
      Result := IDYes;
    except
      Result := RegisterServer(CLSID, FileName);
    end;
  until (obj <> nil) or (Result in [IDNo, IDCancel]);
end;

end.
