unit MCAD_MI1201_FormMethods;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Db, DBTables, Grids, DBGrids,ActnList, Menus, DBClient,

  MITypes,
  MCAD_MI1201_XForm,
  MCAD_MI1201_Registry, Buttons;


type
  TDBErrorCodes = (ecCommon, ecNoCreate, ecNoUpdate, ecNoOpen, ecNoActive);

Const
  cErrorBegin = 'Невозможно ';
  cDBErrors:array[TDBErrorCodes]of pChar =
    ('выполнить данную операцию!',
     'создать новую базу!',
     'обновить информацию в базе!',
     'открыть базу данных!',
     'выполнить на закрытом DataSet`е!'
    );

ResourceString
  cDBErrorCaption = 'Ошибка работы с базой данных';

type
  TFormMethods = class(TXForm)
    DBGridMethodData: TDBGrid;
    DataSourceMethodData: TDataSource;
    OpenDialogMethodData: TOpenDialog;
    SaveDialogMethodData: TSaveDialog;
    ButtonAddLine: TButton;
    ButtonDelLine: TButton;
    MainMenuMethods: TMainMenu;
    MenuFile: TMenuItem;
    MenuItemOpen: TMenuItem;
    MenuItemSave: TMenuItem;
    MenuItemNew: TMenuItem;
    MenuItemCloseForm: TMenuItem;
    MenuData: TMenuItem;
    MenuItemAddLine: TMenuItem;
    MenuItemDelLine: TMenuItem;
    MenuItemStartMeasuring: TMenuItem;
    ActionListFormMethods: TActionList;
    ActionSaveDataBase: TAction;
    ActionOpenDataBase: TAction;
    ActionCloseFormMethods: TAction;
    ActionAddLine: TAction;
    ActionDelLine: TAction;
    ActionStartMeasuring: TAction;
    ActionNewDataBase: TAction;
    FileSep0: TMenuItem;
    DataSep0: TMenuItem;
    TableMethodData: TTable;
    CheckBoxChanged: TCheckBox;
    SpeedButtonStartMeasure: TSpeedButton;
    SpeedButtonRecordDown: TSpeedButton;
    SpeedButtonRecordUp: TSpeedButton;
    procedure ActionOpenDataBaseExecute(Sender: TObject);
    procedure ActionAddLineExecute(Sender: TObject);
    procedure ActionDelLineExecute(Sender: TObject);
    procedure ActionSaveDataBaseExecute(Sender: TObject);
    procedure ActionCloseFormMethodsExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ActionNewDataBaseExecute(Sender: TObject);
    procedure DataSourceMethodDataStateChange(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ActionStartMeasuringExecute(Sender: TObject);
    procedure SpeedButtonRecordUpClick(Sender: TObject);
    procedure SpeedButtonRecordDownClick(Sender: TObject);
  private
    prChanged:boolean;
    prDBDir:string;

    // Состояние формы --------------------
    prFormStyle:array[1..16]of TFormStyle;
    procedure SaveFormStyle(NewStyle:TFormStyle);
    procedure RestoreFormStyle;


    procedure RefreshCaption;
    function  MessageBoxFileExists(FN:TFileName):integer;

    procedure CloseDataBaseMethod;

    procedure SaveDataBaseMethod;
    procedure SaveDBNotAsk;

    procedure OpenDataBaseMethod;
    procedure NewDataBaseMethod;

    procedure DataBaseError(ErrorCode:TDBErrorCodes);

    // Работа с реестром
    procedure RegistryReadDimensions; virtual;
    procedure RegistryWriteDimensions; virtual;

    procedure RegistryReadRelations; virtual;
    procedure RegistryWriteRelations; virtual;

    procedure RegistryReadSettings;
    procedure RegistryWriteSettings;


    //
    procedure SetChanged(b:boolean);
    procedure SwapRecords(r1,r2:longint);

  public
    property  IsChanged:boolean read prChanged write SetChanged;
    property  DataBasesDir:string read prDBDir;
  end;


Var
  FormMethods: TFormMethods;

procedure Execute(Sender:TObject);

Implementation

uses
  Registry,

  MCAD_MI1201_FormSpectrum,

  MCAD_MI1201_MeasureOn_Proc;

{$R *.DFM}

type
  tFieldInfo = Record
    FName:string;
    FTitle:string;
    FType:TFieldType;
    FSize:integer;
    end;


Const
  NumFields = 5;
  FieldInfo:Array[1..NumFields] of TFieldInfo =
    ((FName:'FieldID';        FTitle:'ID';      FType:ftAutoInc; FSize:10;),
     (FName:'FieldMass';      FTitle:'m/e';     FType:ftFloat;   FSize:10;),
     (FName:'FieldEnable';    FTitle:'Мерить';  FType:ftBoolean; FSize:10;),
     (FName:'FieldValves';    FTitle:'Клапаны'; FType:ftString;  FSize:250;),
     (FName:'FieldIntensity'; FTitle:'Сигнал';  FType:ftFloat;   FSize:10;));


// Инициализация формы ---------------------------------------------------------
procedure Execute;
begin
  if not Assigned(FormMethods) then
    try
      FormMethods := TFormMethods.Create(FormSpectrum);
    except
      FormMethods := nil;
      exit;
    end;

  FormMethods.Show;
  FormMethods.WindowState := wsNormal;
end;


// Сохранение состояния формы --------------------------------------------------
Const
  FPos:byte = 1;

procedure TFormMethods.SaveFormStyle(NewStyle:TFormStyle);
begin
  if FPos > 16 then
    Exit;
  prFormStyle[FPos] := FormStyle;
  inc(FPos);
  FormStyle   := NewStyle;
end;


procedure TFormMethods.RestoreFormStyle;
begin
  if FPos = 1 then
    Exit;
  FormStyle := prFormStyle[FPos];
  dec(FPos);
end;


// Обновление заголовка --------------------------------------------------------
ResourceString
  cFormMethodsCaption = 'Метод измерения - ';

procedure TFormMethods.RefreshCaption;
begin
  Caption := cFormMethodsCaption;
  if TableMethodData.Exists then
    Caption := Caption + ExtractFileName(TableMethodData.TableName);
end;


procedure TFormMethods.DataBaseError(ErrorCode:TDBErrorCodes);
begin
  MessageBox(cErrorBegin + cDBErrors[ErrorCode], cDBErrorCaption, MB_OK + MB_ICONEXCLAMATION);
end;


procedure TFormMethods.SetChanged(b:boolean);
begin
  prChanged := b;
  CheckBoxChanged.Checked := b;
end;


function GetFileDir(FileName:string):string;
begin
  Result := ExtractFilePath(ExpandFileName(FileName));
end;


// Методом лома и топора копирует один файл в другой ---------------------------
ResourceString
  cTMPName = '~IsOldDB.db';

procedure CopyToFile(Source,Dest:TFileName);
Var
  SrcHandle,DestHandle:file;
  p:pointer;
  Readed:longint;

Const
  Sz = 65535;

begin
  GetMem(p,sz);

  AssignFile(SrcHandle, Source);
  AssignFile(DestHandle, Dest);
  Reset(SrcHandle,1);
  Rewrite(DestHandle,1);

  Repeat
    BlockRead(SrcHandle, P^, Sz, Readed);
    BlockWrite(DestHandle, P^, Readed);
  Until Readed <= 0;

  Close(SrcHandle);
  Close(DestHandle);
  FreeMem(p,sz);
end;


// Безусловное сохранение текущей базы данных ----------------------------------

ResourceString
  cWarningCaption = 'Предупреждение';
  cNotSaved = 'В базу данных были внесены изменения! Сохранять?';
  cAlreadyExist = 'Файл уже существует! Перезаписать?';

function TFormMethods.MessageBoxFileExists(FN:TFileName):integer;
begin
  if FileExists(FN) then
    Result := MessageBox(cAlreadyExist, cWarningCaption, MB_YESNO+MB_ICONQUESTION)
  else
    Result := 0;
end;


procedure TFormMethods.SaveDBNotAsk;
Var
  OldName:TFileName;

Label
  RepExec;

begin
  SaveFormStyle(fsNormal);

  With TableMethodData, SaveDialogMethodData do
    begin
    InitialDir := prDBDir;
    FileName   := TableName;
    OldName    := FileName;

RepExec:
    if Execute then // Пользователь выбрал новое имя файла
      begin
      // Проверяем не существует ли уже ---------------

      Case MessageBoxFileExists(FileName) of
        ID_YES: DeleteFile(FileName);
        ID_NO : Goto RepExec;  // На мой взгляд, так удобней...
        end; //Case

      prDBDir := GetFileDir(FileName);  // В случае ошибки - каталог текущий

      // Копируем неизменённую базу во временный файл
      if Active then
        try
          CopyToFile(ExpandFileName(TableName), GetFileDir(TableName)+cTMPName);
          FlushBuffers;        // Обновляем таблицу
          Close;
        except
          DataBaseError(ecNoUpdate);
          Exit;
          end//; {
      else
        DataBaseError(ecNoActive); {}

      try
        if ExtractFileName(FileName) <> ExtractFileName(OldName) then // Имя отлично от предыдущего
          begin
          RenameTable(FileName);         // Переименовываем таблицу
          RenameFile(cTMPName, OldName); // Переименовываем временную таблицу на старое место
          end
        else
          DeleteFile(cTMPName); // Удаляем -> таблица не нужна
      except
        DataBaseError(ecCommon);
        end;

      // Приводим в рабочий вид ------------
      try
        Open; // Открываем таблицу
        IsChanged := False;
      except
        DataBaseError(ecCommon);
        end;

      RefreshCaption; // Обновляем заголовок
      end; // if
    end; //with

  RestoreFormStyle;
end;


procedure TFormMethods.SaveDataBaseMethod;
begin
  //CopyFile();
  if IsChanged then
    if MessageBox(cNotSaved,cWarningCaption,MB_YESNO) = IDYES then  // Сохраняем базу данных
      SaveDBNotAsk;
end;


procedure TFormMethods.CloseDataBaseMethod;
begin
  // Закрываем базу данных, если она открыта
  With TableMethodData do
    if Active then
      begin
      SaveDataBaseMethod;
      Close;
      end; // With
end;


procedure TFormMethods.OpenDataBaseMethod;
  ResourceString
    cAskNewDataBase = 'Создать новую базу данных?';
    cAskNewDataBaseCaption = 'Подтверждение';

begin
  SaveFormStyle(fsNormal);

  With TableMethodData, OpenDialogMethodData do
    begin
    if Exists and Active then
      CloseDataBaseMethod;

    InitialDir := prDBDir;
    if Execute then
      try
      prDBDir := GetFileDir(FileName);
      TableName := FileName;
      Open;
      IsChanged := False;

      RefreshCaption;
      except
        DataBaseError(ecNoOpen);
        end
    else
      if MessageBox(cAskNewDataBase, cAskNewDataBaseCaption, MB_YESNO+MB_ICONQUESTION) = IDYES then
        NewDataBaseMethod;
    end; // With

  RestoreFormStyle;
end;


procedure TFormMethods.NewDataBaseMethod;
  ResourceString
    cNewDataBaseCaption = 'Создание новой базы данных';
    cNewDatabase = 'Задайте имя файла для новой базы:';

  procedure AddFieldToDataBase(Table:TTable; FieldInf:TFieldInfo);
    begin
      with FieldInf, Table.FieldDefs.AddFieldDef do
        begin
        Name     := FName;
        DataType := FType;
        Required := False;
        if FType = ftString then
          Size     := FSize;
        end;  // With
    end;

Var
  BaseName:string;
  i:word;
Label
  RepInp;
begin
  with TableMethodData do
    begin
    if Exists then
      CloseDataBaseMethod;

    try
RepInp:
      SaveFormStyle(fsNormal);
      BaseName  := InputBox(cNewDataBaseCaption, cNewDataBase, '');
      RestoreFormStyle;

      if Length(BaseName) = 0 then
        begin
        if not TableMethodData.Exists then
          FormMethods.Destroy;
        Exit;
        end;

      Case MessageBoxFileExists(BaseName) of
        ID_YES: DeleteFile(BaseName);
        ID_NO : Goto RepInp;
        end;  //Case

      TableName := GetCurrentDir + '\' + BaseName;
      prDBDir   := GetFileDir(TableName);

      // Создаём поля в новой базе данных
      with FieldDefs do
        begin
        Clear;
        For i := 1 to NumFields do
          AddFieldToDataBase(TableMethodData, FieldInfo[i]);

        end; //With

      CreateTable;
      Open;
      DBGridMethodData.SelectedIndex := 0;
      IsChanged := False;
      RefreshCaption;
    except
      DataBaseError(ecNoCreate);
      end; // try

    end; // with
end;


procedure TFormMethods.ActionOpenDataBaseExecute(Sender: TObject);
begin
  OpenDataBaseMethod;
end;


procedure TFormMethods.ActionAddLineExecute(Sender: TObject);
begin
  With TableMethodData do
    begin
    Insert;
    end; // With
end;


procedure TFormMethods.ActionDelLineExecute(Sender: TObject);
begin
  With TableMethodData do
    begin
    if RecordCount > 0 then
      Delete;
    end; // With
end;


procedure TFormMethods.ActionSaveDataBaseExecute(Sender: TObject);
begin
  SaveDBNotAsk;
end;


procedure TFormMethods.ActionCloseFormMethodsExecute(Sender: TObject);
begin
  if IsChanged then
    CloseDataBaseMethod;
  Hide;
end;


procedure TFormMethods.FormCreate(Sender: TObject);
begin
  prDBDir := GetCurrentDir;
  RegistryReadSettings;
  ActionOpenDataBaseExecute(Sender);
end;


procedure TFormMethods.FormDestroy(Sender: TObject);
begin
  ActionCloseFormMethodsExecute(Sender);
  RegistryWriteSettings;
  FormMethods := nil;
end;


// Операции с реестром ---------------------------------------------------------
ResourceString
  cRegistryDimensionsKey = 'Dimensions';
  cRegistryRelationsKey  = 'Valves';

  cRegistryKeyDBDir = 'DataBasesDir';

procedure TFormMethods.RegistryReadDimensions;

  procedure ReadColumnsWith;
    Var
      i:integer;
    begin
      with prRegistry, DBGridMethodData do
        for i := 0 to Columns.Count - 1 do
          try
          Columns[i].Width := ReadInteger(Columns[i].FieldName);
          except
            end;
    end;

begin
  if RegistryOpenForReadSubKey(cRegistryDimensionsKey) then
    try
      try
        Left := prRegistry.ReadInteger('Left');
        if (Left < 0) then
          Left := 0;
        if ((Left + Width) > Screen.Width) then
          Left := Screen.Width - Width;
      except
        end; // try

      try
        Top := prRegistry.ReadInteger('Top');
        if (Top < 0) then
          Top := 0;
        if ((Top + Height) > Screen.Height) then
          Top := Screen.Height - Height;
      except
        end;   // try

      ReadColumnsWith;

    finally
      prRegistry.CloseKey;
      end;
end;


procedure TFormMethods.RegistryWriteDimensions;
  procedure WriteColumnsWidth;
    Var
      i:integer;
    begin
      with prRegistry, DBGridMethodData do
        for i := 0 to Columns.Count - 1 do
          WriteInteger(Columns[i].FieldName, Columns[i].Width);
    end;

begin
  if Assigned(Self) and RegistryOpenForWriteSubKey(cRegistryDimensionsKey) then
    try
      prRegistry.WriteInteger('Left',Left);
      prRegistry.WriteInteger('Top',Top);

      WriteColumnsWidth;
    finally
      prRegistry.CloseKey
      end;  //try
end;


procedure TFormMethods.RegistryReadRelations;

  procedure ReadTo(Var VR:tValveRelation);
    Var
      Tmp:string[ValveStringLen];
    begin
      with VR,prRegistry do
        try
          tmp := ReadString(VValve);
          if Length(tmp) <> 0 then
            VName := tmp;
        except
          end; //try, with
    end;

Var
  V :tSource;

begin
  if RegistryOpenForReadSubKey(cRegistryRelationsKey) then
    begin
    for V := Low(tSource) to High(tSource) do
      ReadTo(VRelations[V]);

    prRegistry.CloseKey;
    end;  // if
end;


procedure TFormMethods.RegistryWriteRelations;
  procedure WriteFrom(VR:tValveRelation);
    begin
      with VR, prRegistry do
        try
          WriteString(VValve, VName);
        except
          end; //try, with
    end;

Var
  V :tSource;
begin
  if RegistryOpenForWriteSubKey(cregistryRelationsKey) then
    begin
    for V := Low(tSource) to High(tSource) do
      WriteFrom(VRelations[V]);

    prRegistry.CloseKey;
    end;  //if
end;


procedure TFormMethods.RegistryReadSettings;
Var
  DBDir:string;
begin
  RegistryReadDimensions;
  RegistryReadRelations;

  if RegistryOpenForRead then
    try

      try
        DBDir := prRegistry.ReadString(cRegistryKeyDBDir);
      finally
        if length(DBDir) = 0 then
          DBDir := GetCurrentDir;
        prDBDir := DBDir;
        end; // try

    finally
      prRegistry.CloseKey;
      end; // try
end;


procedure TFormMethods.RegistryWriteSettings;
begin
  RegistryWriteDimensions;
  RegistryWriteRelations;

  if Assigned(Self) and RegistryOpenForWrite then
    try
      prRegistry.WriteString(cRegistryKeyDBDir, prDBDir);
    finally
      prRegistry.CloseKey;
      end;  // try
end;
// Конец работы с реестром -----------------------------------------------------

procedure TFormMethods.ActionNewDataBaseExecute(Sender: TObject);
begin
  NewDataBaseMethod;
end;


procedure TFormMethods.DataSourceMethodDataStateChange(Sender: TObject);
begin
   if DataSourceMethodData.State = dsEdit then
     IsChanged := True;
end;

procedure TFormMethods.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  if Action in [caHide, caFree] then
    FormDestroy(Sender);
end;


procedure TFormMethods.ActionStartMeasuringExecute(Sender: TObject);
Var
  i:integer;
begin
  ProcessMessages;
  With TableMethodData do
    begin

    if not Exists then
      Exit;

    //SaveDataBaseMethod;
    For i := 1 to RecordCount do
      begin
      RecNo := i;
      Edit;
      With Fields do
        if FieldByName('FieldEnable').AsBoolean then
          begin
          FieldByName('FieldIntensity').AsFloat :=
                    MeasureOn(FieldByName('FieldMass').AsFloat,
                              FieldByName('FieldValves').AsString);
          end;  // With, For
      end;  // if

    end;  // With
end;


procedure TFormMethods.SpeedButtonRecordUpClick(Sender: TObject);
begin
  with TableMethodData do
    begin
    SwapRecords(RecNo,RecNo - 1);
    end;
end;

procedure TFormMethods.SpeedButtonRecordDownClick(Sender: TObject);
begin
  with TableMethodData do
    begin
    SwapRecords(RecNo,RecNo + 1);
    end;
end;


procedure TFormMethods.SwapRecords(r1,r2:longint);
  function CheckValid(i:longint):boolean;
    begin
      Result := (i >= 0) and (i < TableMethodData.RecordCount)
    end;
Var
//  Ns:longint;
  p:pchar;
begin
  with TableMethodData do
    begin
    IndexFieldNames := 'FieldValves';
    exit;

    if GetCurrentRecord(p) then
      Application.MessageBox(p,'Message',MB_OK);
    exit;
    if not (CheckValid(r1) and CheckValid(r2)) then
      Exit;

    if r2 > r1 then
      begin
//      ns := r1;
      r1 := r2;
//      r2 := ns;
      end;

//    ns := RecNo;
    RecNo := r1;
    Insert;





    end;

end;



end.