unit untUtil;

////////////////////////////////////////////////////////////////////////////////////////////////////
//   ( ,    ..)                                     //
////////////////////////////////////////////////////////////////////////////////////////////////////

interface

uses
  SysUtils, Windows, Forms, Dialogs, ComObj, StdCtrls,
  ExtCtrls, ComCtrls, Classes, Registry, Graphics, CheckLst,
  BRegStr,
  PrnRegStr;

resourcestring

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

const
  BOOLSTR: array[False..True] of string = ('', '');

type

  TRegisterDlgResult = (
    rrNo,            //     
    rrYes,           //   
    rrCancel);       //    

function VarEquals(V1, V2: Variant): Boolean;
function RegisterDriver(const InitFileName: String): TRegisterDlgResult;

procedure GetRegistryFont(aFont :TFont);
procedure SetRegistryFont(AFont: TFont);

{ StdUtil}

procedure SafeSetChecked(CheckBox: TCheckBox; Value: Boolean);
procedure SafeSetRadioButton(RadioButton: TRadioButton; Value: Boolean);
procedure SafeSetEdit(Edit: TCustomEdit; const Value: String);
procedure SafeSetComboBoxObj(ComboBox: TComboBox; Value: TObject);
procedure SafeSetCheckListBox(CheckListBox: TCheckListBox; Index: integer; Value: Boolean);
procedure SafeSetMemo(Memo: TCustomMemo; Value: TStrings);
procedure SafeSetUpDown(UpDown: TUpDown; const Value: Integer);
function GetSelectedComboBoxObject(ComboBox: TComboBox): TObject;
procedure ValidIntKeyPress(var Key: Char);
procedure ValidDoubleKeyPress(var Key: Char);

function DisableScreenForms(ActiveForm: TCustomForm): TList;
procedure EnableScreenForms(FormList: TList);

function GetUniqueFileName(const Path, FileName, PostFix: String): String;
function GenerateTempPictureFileName: String;

implementation

function GetVariantPointer(const Value: Variant): Pointer;
begin
  case VarType(Value) of
    varEmpty, varNull: Result := nil;
    varDispatch: Result := TVarData(Value).VDispatch;
    varVariant: Result := @Value;
    varUnknown: Result := TVarData(Value).VUnknown;
  else
    Result := @TVarData(Value).VPointer;
  end;
end;

function VarEquals(V1, V2: Variant): Boolean;
begin
  Result := GetVariantPointer(V1) = GetVariantPointer(V2);
end;

function RegisterDriver(const InitFileName: String): TRegisterDlgResult;
var
  dlg: TOpenDialog;
begin
  With Application do
   if MessageBox(PChar(Format(STR_REG_DLL, [InitFileName])), PChar(Title),
     mb_IconExclamation or mb_OKCancel) = IdCancel then
  begin
    Result := rrCancel;
    Exit;
  end;

  dlg := TOpenDialog.Create(nil);
  try
    dlg.FileName := InitFileName;
    dlg.Filter := ' (*.dll)|*.dll|' + '  (*.*)|*.*';
    dlg.DefaultExt := 'dll';
    dlg.Options := [ofHideReadOnly, ofPathMustExist, ofFileMustExist];

    if dlg.Execute then
    begin
      try
        RegisterComServer(dlg.FileName);
        Result := rrYes
      except
        Result := rrNo
      end;
    end
    else Result := rrCancel;

  finally
    dlg.Free;
  end;
end;

procedure GetRegistryFont(aFont :TFont);
var
  fRegistry: TRegistry;
begin
  fRegistry:= TRegistry.Create;
  try
    fRegistry.RootKey:= HKEY_CURRENT_USER;
    fRegistry.OpenKey(REGSTR_KEY_FONT, TRUE);
    if fRegistry.ValueExists('FontName') then
      aFont.Name:= fRegistry.ReadString('FontName') else
      aFont.Name:= 'MS Sans Serif';
    if fRegistry.ValueExists('FontSize') then
      aFont.Size:= fRegistry.ReadInteger('FontSize') else
      aFont.Size:= 8;
    if fRegistry.ValueExists('FontColor') then
      aFont.Color:= fRegistry.ReadInteger('FontColor') else
      aFont.Color:= clWindowText;
    if fRegistry.ValueExists('FontCharset') then
      aFont.Charset:= fRegistry.ReadInteger('FontCharset') else
      aFont.Charset:= RUSSIAN_CHARSET;
    aFont.Style :=[];
    if fRegistry.ValueExists('FontfsBold') then
      if fRegistry.ReadBool('FontfsBold') then
        aFont.Style:= aFont.Style + [fsBold];
    if fRegistry.ValueExists('FontfsItalic') then
      if fRegistry.ReadBool('FontfsItalic') then
        aFont.Style:= aFont.Style + [fsItalic];
    if fRegistry.ValueExists('FontfsUnderline') then
      if fRegistry.ReadBool('FontfsUnderline') then
        aFont.Style:= aFont.Style + [fsUnderline];
    if fRegistry.ValueExists('FontfsStrikeOut') then
      if fRegistry.ReadBool('FontfsStrikeOut') then
        aFont.Style:= aFont.Style+[fsStrikeOut];
  finally
    fRegistry.Free;
  end;
end;

procedure SetRegistryFont(aFont: TFont);
var
  fRegistry: TRegistry;
begin
  fRegistry := TRegistry.create;
  try
    fRegistry.RootKey := HKEY_CURRENT_USER;
    fRegistry.OpenKey(REGSTR_KEY_FONT, True);
    fRegistry.WriteString('FontName', aFont.Name);
    fRegistry.WriteInteger('FontSize', aFont.Size);
    fRegistry.WriteInteger('FontColor', aFont.Color);
    fRegistry.WriteInteger('FontCharset', aFont.Charset);
    fRegistry.WriteBool('FontfsBold', (fsBold in aFont.Style));
    fRegistry.WriteBool('FontfsItalic', (fsItalic in aFont.Style));
    fRegistry.WriteBool('FontfsUnderline', (fsUnderline in aFont.Style));
    fRegistry.WriteBool('FontfsStrikeOut', (fsStrikeOut in aFont.Style));
  finally
    fRegistry.Free;
  end;
end;

{ StdUtil }

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 SafeSetRadioButton(RadioButton: TRadioButton; Value: Boolean);
var
  SaveOnClick: TNotifyEvent;
begin
  SaveOnClick := RadioButton.OnClick;
  RadioButton.OnClick := nil;
  try
    RadioButton.Checked := Value;
  finally
    RadioButton.OnClick := SaveOnClick;
  end;
end;

type
  TExposeEdit = class(TCustomEdit)
  public
    property OnChange;
  end;

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

procedure SafeSetComboBoxObj(ComboBox: TComboBox; Value: TObject);
var
  SaveOnChange: TNotifyEvent;
begin
  SaveOnChange := ComboBox.OnChange;
  ComboBox.OnChange := nil;
  try
    with ComboBox do
     ItemIndex := Items.IndexOfObject(Value);
  finally
    ComboBox.OnChange := SaveOnChange;
  end;
end;

procedure SafeSetCheckListBox(CheckListBox: TCheckListBox; Index: integer; Value: Boolean);
var
  SaveOnClickCheck: TNotifyEvent;
begin
  SaveOnClickCheck := CheckListBox.OnClickCheck;
  CheckListBox.OnClickCheck := nil;
  try
    CheckListBox.Checked[Index] := Value;
  finally
    CheckListBox.OnClickCheck := SaveOnClickCheck;
  end;
end;

procedure SafeSetMemo(Memo: TCustomMemo; Value: TStrings);
var
  SaveOnChange: TNotifyEvent;
begin
  SaveOnChange := TExposeEdit(Memo).OnChange;
  TExposeEdit(Memo).OnChange := nil;
  try
    Memo.Lines.Assign(Value);
    Memo.Modified := False;
  finally
    TExposeEdit(Memo).OnChange := SaveOnChange;
  end;
end;

procedure SafeSetUpDown(UpDown: TUpDown; const Value: Integer);
var
  SaveOnClick: TUDClickEvent;
begin
  SaveOnClick := UpDown.OnClick;
  UpDown.OnClick := nil;
  try
    UpDown.Position := Value;
  finally
    UpDown.OnClick := SaveOnClick;
  end;
end;

function GetSelectedComboBoxObject(ComboBox: TComboBox): TObject;
begin
  if (ComboBox <> nil) and (ComboBox.ItemIndex <> - 1) then
    Result := ComboBox.Items.Objects[ComboBox.ItemIndex]
  else Result := nil;
end;

procedure ValidIntKeyPress(var Key: Char);
begin
  if not (Key in ['0'..'9', Char(VK_BACK)]) then Key := #0;
end;

procedure ValidDoubleKeyPress(var Key: Char);
begin
  if not (Key in ['0'..'9', '.', ',', Char(VK_BACK)]) then Key := #0;
end;

function DisableScreenForms(ActiveForm: TCustomForm): TList;
var
  I: Integer;
  TmpForm: TForm;
begin
  Result := TList.Create;
  try
    Result.Capacity := Screen.FormCount;
    for I := 0 to Screen.FormCount - 1 do
    begin
      TmpForm := Screen.Forms[I];
      if TmpForm.Enabled and (TmpForm <> ActiveForm) then
      begin
        TmpForm.Enabled := False;
        Result.Add(TmpForm);
      end;
    end;
  except
    EnableScreenForms(Result);
    raise;
  end;
end;

procedure EnableScreenForms(FormList: TList);
var
  I: Integer;
begin
  if FormList <> nil then
   for I := 0 to FormList.Count - 1 do
     TForm(FormList[I]).Enabled := True;
  FormList.Free;
end;

function GetUniqueFileName(const Path, FileName, PostFix: String): String;

  function AddLastBkSlash(const Name: String): String;
  begin
    Result := Name;
    if (Result <> '')
       and (Result[Length(Result)] <> '\') then AppendStr(Result, '\');
  end;

  function ExtractShortFileName(const FileName: String): String;
  var
    I: Integer;
  begin
    Result := ExtractFileName(FileName);
    I := LastDelimiter('.', Result);
    if I > 0 then
      Result := Copy(Result, 1, I - 1);
  end;


var
  FilePath: String;
  ShortName: String;
  FileExt: String;
  I: Integer;
begin
  FilePath := AddLastBkSlash(Path);
  ShortName := ExtractShortFileName(FileName);
  AppendStr(ShortName, PostFix);
  FileExt := ExtractFileExt(FileName);
  Result := Format('%s%s%s', [FilePath, ShortName, FileExt]);
  if not FileExists(Result) then Exit;
  for I := 0 to 999 do
  begin
    Result := Format('%s%s%.3d%s', [FilePath, ShortName, I, FileExt]);
    if not FileExists(Result) then Exit;
  end;
  raise Exception.Create('   ');
end;

function GenerateTempPictureFileName: String;
begin
  Result := GetUniqueFileName(ExtractFilePath(ParamStr(0)), 'tmp.bmp', '')
end;

end.
