unit VisTrackBar;

interface

uses
  DesignIntf, DesignEditors,
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, stdctrls, uPSComponent, uPSCompiler, uPSRuntime, ComCtrls,
  VisControl;

type
  TMyFunction = procedure (Sender: TObject) of Object;

  TMyTrackBar = class(TPanel)
    procedure SetTex;
  protected
    TrackBar: TTrackBar;
    CurPosLabel: TLabel;
    FOnMyChange : TMyFunction;
    FPosCont   : integer;
    FMarkCount : integer;
    FShowCurVal : boolean;

    FStrBefore, FStrAfter : string;
    procedure SetMarks (a:integer);
    procedure SetCont  (a:integer);
    procedure SetPos   (a:integer);
    function  GetPos : integer;
    function  GetMin : integer;
    function  GetMax : integer;
    function  GetShowCurVal : boolean;
    procedure SetShowCurVal (w:boolean);
  published
    property Marks: integer read FMarkCount write SetMarks;
    property PosCont: integer read FPosCont write SetCont;
    property ShowCurVal: boolean read GetShowCurVal write SetShowCurVal;

    property StrBefore : string read FStrBefore;
    property StrAfter : string read FStrAfter;

    property OnMyChange : TMyFunction read FOnMyChange write FOnMyChange;
    property YTrackBar: TTrackBar read TrackBar write TrackBar;
    property YLabel: TLabel read CurPosLabel write CurPosLabel;

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure TrackBarChange(Sender: TObject);
    procedure SetWidth;
    procedure SetStrs (a : string; b:integer);


  protected
    old_pos_value : integer;
  end;


  TVisTrackBar = class(TVisControl)
    procedure PSScriptCompile(Sender: TPSScript);
    procedure PSScriptCompImport(Sender: TObject; x: TPSPascalCompiler);
    procedure PSScriptExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
    procedure PSScriptExecute(Sender: TPSScript);
  private
    FTrackBar: TMyTrackBar;
    FAutoUpdateApply: boolean;
    FApplying: boolean;
    FControlChangeDisabled: boolean;

  protected
    F2OnMyChange : TMyFunction;

    procedure OnControlChange(Sender: TObject);
    procedure ScriptProcess(ForceExecute: boolean);
    procedure TrackBarChange(Sender: TObject);

    function RStrBefore : string;
    function RStrAfter : string;
    procedure WStrBefore (s:string);
    procedure WStrAfter (s:string);

    function RMinVal : integer;
    procedure WMinVal (i:integer);
    function RMaxVal: integer;
    procedure WMaxVal (i:integer);

    function RIsShowText : boolean;
    procedure WIsShowText (w:boolean);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Init; override;
    procedure Process; override;
    function IsApplying: boolean;

    procedure setcolors(AFontColor: integer; ABackColor: integer);

    function CompileScript(var Messages: string): boolean; override;
    procedure ExecuteScript; override;
    procedure DoApply;
    procedure DoUpdate;

  published
    property StrBefore: string read RStrBefore write WStrBefore;
    property StrAfter: string read RStrAfter write WStrAfter;
    property MinVal: integer read RMinVal write WMinVal;
    property MaxVal: integer read RMaxVal write WMaxVal;
    property IsShowText: boolean read RIsShowText write WIsShowText;
    property AutoUpdateApply: boolean read FAutoUpdateApply write FAutoUpdateApply;
    property objTrackBar: TMyTrackBar read FTrackBar write FTrackBar;
    property OnChange : TMyFunction read F2OnMyChange write F2OnMyChange;

    property Align;
    property Anchors;
    property Enabled;
    property Visible;
  end;


  TVisTrackBar_ScriptPropEdit =class(TClassProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
  end;




procedure Register;

implementation
uses
  uPSR_std,
  uPSC_std,
  uPSR_stdctrls,
  uPSC_stdctrls,
  uPSR_extctrls,
  uPSC_extctrls,
  uPSR_forms,
  uPSC_forms,
  uPSC_graphics,
  uPSC_controls,
  uPSC_classes,
  uPSR_graphics,
  uPSR_controls,
  uPSR_classes,
  uPSR_visscada,
  uPSC_visscada,
  RpVisualGlobal,
  TagStorage,
  numbers,
  UserControlEx,
  VisControlScriptEdit,
//  VisTrackBarScriptEdit,
  hyperstr, Users;

var
  PSScript: TPSScript;
  PSScript_refcount: integer;
  PSVisTrackBar: TVisTrackBar;

  tmp_compile_src, tmp_compile_out: string;

procedure Register;
begin
  RegisterComponents('Scada', [TVisTrackBar]);
  RegisterPropertyEditor(TypeInfo(TStrings), TVisTrackBar, 'Script', TVisTrackBar_ScriptPropEdit);
end;

procedure TMyTrackBar.SetWidth;
begin
  SetTex;

  if FMarkCount < 1 then FMarkCount := 1;
  TrackBar.Frequency := round ((TrackBar.Max - TrackBar.Min) / FMarkCount);
end;


function  TMyTrackBar.GetShowCurVal : boolean;
begin
 result := FShowCurVal;
end;


procedure TMyTrackBar.SetShowCurVal (w:boolean);
begin
  FShowCurVal := w;
  SetTex;
end;


procedure TMyTrackBar.SetStrs (a : string; b:integer);
begin
  if b = 1 then FStrBefore := a
           else FStrAfter  := a;

  SetTex;
end;


procedure TMyTrackBar.SetMarks (a:integer);
begin
  FMarkCount := a;
  SetWidth;
end;

function  TMyTrackBar.GetPos : integer;
begin
  result := Self.TrackBar.Position;
end;

function  TMyTrackBar.GetMin : integer;
begin
result := Self.TrackBar.Min;
end;
function  TMyTrackBar.GetMax : integer;
begin
result := Self.TrackBar.Max;
end;



procedure TMyTrackBar.SetPos   (a:integer);
begin
  if (Self.TrackBar.min <= a) and (a <= Self.TrackBar.max) then
    begin
      Self.TrackBar.Position := a;
      TrackBarChange(Self.TrackBar);
    end;
end;

procedure TMyTrackBar.SetCont   (a:integer);
begin
  FPosCont := a;
end;


procedure TMyTrackBar.SetTex;
var s:string;
begin
  if FShowCurVal then s := inttostr(TrackBar.Position) else s := '';
  CurPosLabel.Caption := FStrBefore + s + FStrAfter;
  CurPosLabel.Left := round ((self.Width - CurPosLabel.Width) / 2);
end;

procedure TMyTrackBar.TrackBarChange(Sender: TObject);
var r:real;
    v:integer;
begin
  with Sender as TTrackBar do
    begin
      if PosCont < 1 then PosCont := 1;
      r := (Max - Min) / PosCont;
      v := round (r * round ( (Position - Min) / r ));

      Position := v;

      if old_pos_value <> v then
        begin
          SetTex;
        end;
      old_pos_value := v;
    end;

  if Assigned(FOnMyChange) then  FOnMyChange(Sender);
end;




constructor TMyTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  //-----------------------------
  FMarkCount := 10;
  FPosCont := 20;

  FStrBefore := '';
  FStrAfter := '';
  //-----------------------------

//  FShowCurVal := true;

  CurPosLabel := TLabel.Create(self);
  CurPosLabel.Parent := self;
  CurPosLabel.Align  := alTop;
  CurPosLabel.Alignment := taCenter;

  CurPosLabel.Font.Size  := 8;
  CurPosLabel.Font.Style := [fsBold];

  CurPosLabel.Caption := '%%%%';

  TrackBar := TTrackBar.Create(self);
  TrackBar.Parent := self;
  TrackBar.Align  := alClient;

  TrackBar.Min := 0;
  TrackBar.Max := 100;
  TrackBar.Position := TrackBar.Min;
  old_pos_value := TrackBar.Position;

  SetWidth;

  TrackBar.OnChange := TrackBarChange;
end;

destructor TMyTrackBar.Destroy;
begin
  CurPosLabel.Destroy;
  TrackBar.Destroy;

  inherited Destroy;
end;




{ TVisualDevice }

function TVisTrackBar.RIsShowText : boolean;
begin
   result := FTrackBar.ShowCurVal;
end;
procedure TVisTrackBar.WIsShowText (w:boolean);
begin
//  FShowCurVal := w;

  FTrackBar.ShowCurVal := w;
end;



procedure TVisTrackBar.TrackBarChange(Sender: TObject);
begin
 //Мини фильтрик, а то много действий
 if GetKeyState(VK_LBUTTON) >= 0 then
   OnControlChange(Sender);
end;


constructor TVisTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ShowHint := true;

  // Создание метки
  FTrackBar := TMyTrackBar.Create(Self);
  FTrackBar.Name := 'objTrackBar';

  FTrackBar.Parent := self;
  FTrackBar.Visible := true;
  FTrackBar.SetSubComponent(true);

  FTrackBar.SetPos(FTrackBar.YTrackBar.Min);

  FTrackBar.OnMyChange := TrackBarChange;

  FTrackBar.Anchors := [akLeft, akTop, akRight, akBottom];
  FTrackBar.Align := alClient;

  FAutoUpdateApply := true;
  FControlChangeDisabled := false;

  if PSScript = nil then begin
    PSScript := TPSScript.Create(nil);
    PSScript.OnCompile := PSScriptCompile;
    PSScript.OnCompImport := PSScriptCompImport;
    PSScript.OnExecImport := PSScriptExecImport;
    PSScript.OnExecute := PSScriptExecute;
    inc(PSScript_refcount);
  end;

end;


destructor TVisTrackBar.Destroy;
begin
  FTrackBar.Free;
  inherited;
end;

function TVisTrackBar.RStrBefore : string;
begin
  result := FTrackBar.StrBefore;
end;
function TVisTrackBar.RStrAfter : string;
begin
  result := FTrackBar.StrAfter;
end;

procedure TVisTrackBar.WStrBefore (s:string);
begin
  FTrackBar.SetStrs(s, 1);
end;
procedure TVisTrackBar.WStrAfter (s:string);
begin
  FTrackBar.SetStrs(s, 2);
end;


function TVisTrackBar.RMinVal : integer;
begin
  result := FTrackBar.YTrackBar.Min;
end;
function TVisTrackBar.RMaxVal: integer;
begin
  result := FTrackBar.YTrackBar.Max;
end;

procedure TVisTrackBar.WMinVal (i:integer);
begin
 if i > FTrackBar.YTrackBar.Max then FTrackBar.YTrackBar.Max := i;

 FTrackBar.YTrackBar.Min := i;
end;
procedure TVisTrackBar.WMaxVal (i:integer);
begin
 if i < FTrackBar.YTrackBar.Min then FTrackBar.YTrackBar.Min := i;

 FTrackBar.YTrackBar.Max := i;
end;





//procedure TVisTrackBar.SetTagNames(Value: TStringList);
//begin
//  FTagNames.Assign(Value);
//end;



// INIT
procedure TVisTrackBar.Init;
var
  s, _tags: string;
  i,k: integer;
begin
  inherited;

  _tags := '';
  TagRoot := trim(TagRoot);
  TagIdRoot := trim(TagIdRoot);
  TagPath := trim(TagPath);

  SetLength(Tags, FTagNames.Count);

  IsConnectionBad := false;
  for i:=0 to FTagNames.Count-1 do begin

    s:=FTagNames[i];

    if length(TagRoot)>0 then begin
      k:=pos(TagIdRoot, s);
      if k>0 then begin
        delete(s, k, length(TagIdRoot));
        insert(TagRoot, s, k);
      end;
    end;

    if length(TagPath)>0 then begin
      s := TagPath + '.' + s;
    end;

    _tags := _tags + s + ' ';
    Tags[i].idx := GetTagIndex(s);
    Tags[i].value := 0;

    if Tags[i].idx < 0 then
      _tags := _tags + s + '- NOT FOUND! ';

    IsConnectionBad := (IsConnectionBad) or (Tags[i].idx < 0);
  end;

  CompileScript(s);
  for i:=0 to length(Tags)-1 do begin
    Tags[i].value := -1;
  end;

  if FHint = '' then FHint := trim(Hint);
  if not(FHint='') then begin
    if debugTagNotFoundHint then
      Hint := FHint + #13 + 'Теги: ' + _tags
    else
      Hint := FHint;
  end;

end;



// PROCESS HANDLER
procedure TVisTrackBar.Process;
begin
  if not FAutoUpdateApply then 
    exit;

  FApplying := false;
  ScriptProcess(false);
  ExecuteProcessEvent;
end;

procedure TVisTrackBar.DoApply;
begin
  if FControlChangeDisabled then 
    exit;

  FApplying := true;
  ScriptProcess(true);
end;

procedure TVisTrackBar.DoUpdate;
begin
  FApplying := false;
  ScriptProcess(true);
end;

function TVisTrackBar.IsApplying: boolean;
begin
  result := FApplying;
end;

procedure TVisTrackBar.ScriptProcess(ForceExecute: boolean);
var
  fl: boolean;
  value: integer;
begin
  FControlChangeDisabled := true;

  fl := updateTags();

  if FScriptDefEnabled then
    begin
      // Обработчик по умолчанию (вместо скрипта)
      if FApplying then begin
        if isModeUserEx then begin
          if isPermitted('VisTrackBar' + '~' + Name + '~Меняем~'+inttostr(objTrackBar.GetPos)) then
             SetTagVal(0, objTrackBar.GetPos);
        end else begin
          if CheckAccess(PREVILEG_ZAPRET_TRACKBAR, true, true) then
             SetTagVal(0, objTrackBar.GetPos);
        end
      end else
      begin

        if GetKeyState(VK_LBUTTON) >= 0 then
        begin
        value := gettagval(0);

        if (objTrackBar.GetPos <> value) and (objTrackBar.GetMin <= value) and (value <= objTrackBar.GetMax) then
          begin
            objTrackBar.SetPos (value);

            if (objTrackBar.GetPos <> value) then
              begin
                SetTagVal(0, objTrackBar.GetPos);
              end;

          end
        else
          begin
            //Если значение не вписывается в диапазон, то игнорим его

          end;
        end;
      end;
    end;


  if (fl) or (not FExecuteOnTagChange) or (FApplying) or (ForceExecute) then begin
    if FScriptEnabled then
     begin
      ExecuteScript;
      end;
  end;

  FControlChangeDisabled := false;
end;



procedure TVisTrackBar.OnControlChange(Sender: TObject);
begin
  if FAutoUpdateApply then DoApply;
  OnDeviceClick(sender);
end;


//function TVisTrackBar.gettagval(AIndex: integer): integer;
//begin
//  result := -1;
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//      result := FTags[AIndex].value;
//end;
//
//function TVisTrackBar.gettagidx(AIndex: integer): integer;
//begin
//  result := -1;
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//      result := FTags[AIndex].idx;
//end;
//
//procedure TVisTrackBar.settagval(AIndex, AValue: integer);
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//      SetTagValue(FTags[AIndex].idx, AValue)
//end;


procedure TVisTrackBar.setcolors(AFontColor: integer; ABackColor: integer);
begin
end;





// tag getters
//function TVisTrackBar.gettagvalbool(AIndex: integer): boolean;
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    result := GetTagValueBool( FTags[AIndex].idx );
//end;
//
//function TVisTrackBar.gettagvalint(AIndex: integer): integer;
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    result := GetTagValueInt( FTags[AIndex].idx );
//end;
//
//function TVisTrackBar.gettagvallong(AIndex: integer): int64;
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    result := GetTagValueLong( FTags[AIndex].idx );
//end;
//
//function TVisTrackBar.gettagvaldouble(AIndex: integer): double;
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    result := GetTagValueDouble( FTags[AIndex].idx );
//end;
//
//function TVisTrackBar.gettagvalstring(AIndex: integer): string;
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    result := GetTagValueString( FTags[AIndex].idx );
//end;
//
//function TVisTrackBar.istaggood(AIndex: integer): boolean;
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    result := IsTagStatusGood( FTags[AIndex].idx );
//end;



// tag setters
//procedure TVisTrackBar.settagvalbool(AIndex: Integer; AValue: boolean);
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    SetTagValueBool( FTags[AIndex].idx, AValue );
//end;
//
//procedure TVisTrackBar.settagvalint(AIndex: Integer; AValue: integer);
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    SetTagValueInt( FTags[AIndex].idx, AValue );
//end;
//
//procedure TVisTrackBar.settagvallong(AIndex: Integer; AValue: int64);
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    SetTagValueLong( FTags[AIndex].idx, AValue );
//end;
//
//procedure TVisTrackBar.settagvaldouble(AIndex: Integer; AValue: double);
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    SetTagValueDouble( FTags[AIndex].idx, AValue );
//end;
//
//procedure TVisTrackBar.settagvalstring(AIndex: Integer; AValue: string);
//begin
//  if (AIndex>=0) and (AIndex<Length(FTags)) then
//    SetTagValueString( FTags[AIndex].idx, AValue );
//end;



//==============================================================================
procedure TVisTrackBar.PSScriptCompImport(Sender: TObject; x: TPSPascalCompiler);
begin
  SIRegister_Std(x);
  SIRegister_Classes(x, true);
  SIRegister_Graphics(x, true);
  SIRegister_Controls(x);
  SIRegister_stdctrls(x);
  SIRegister_extctrls(x);
  SIRegister_Forms(x);
  SIRegister_visscada(x);
end;

procedure TVisTrackBar.PSScriptExecImport(Sender: TObject; se: TPSExec;
  x: TPSRuntimeClassImporter);
begin
  RIRegister_Std(x);
  RIRegister_Classes(x, True);
  RIRegister_Graphics(x, True);
  RIRegister_Controls(x);
  RIRegister_stdctrls(x);
  RIRegister_extctrls(x);
  RIRegister_Forms(x);
  RIRegister_visscada(x);
end;

procedure TVisTrackBar.PSScriptCompile(Sender: TPSScript);
begin
  Sender.AddRegisteredPTRVariable('self', 'TVisTrackBar');
end;

procedure TVisTrackBar.PSScriptExecute(Sender: TPSScript);
begin
  Sender.SetPointerToData('self', @PSVisTrackBar, sender.FindNamedType('TVisTrackBar'));
end;

function TVisTrackBar.CompileScript(var Messages: string): boolean;
var
  i: integer;
begin
  if SameText(tmp_compile_src, Script.Text) then begin
    CompiledScript := tmp_compile_out;
    IsCompileScriptOk := true;
  end else begin
    PSVisTrackBar := self;
    PSScript.Script.Text := Script.Text;
    IsCompileScriptOk := PSScript.Compile;

    if IsCompileScriptOk then begin
      PSScript.GetCompiled(CompiledScript);
      tmp_compile_src := Script.Text;
      tmp_compile_out := CompiledScript;
    end;

    Messages := '';
    for i:=0 to PSScript.CompilerMessageCount-1 do
      Messages := Messages + PSScript.CompilerMessages[i].MessageToString + #13#10;
  end;

  if IsCompileScriptOk then
    Messages := Messages + 'Successfully compiled!'#13#10;

  result := true;
end;

procedure TVisTrackBar.ExecuteScript;
begin
  if IsCompileScriptOk then begin
    PSVisTrackBar := self;
    PSScript.SetCompiled(CompiledScript);
    PSScript.Execute;
  end;
end;

//==============================================================================



function TVisTrackBar_ScriptPropEdit.GetAttributes: TPropertyAttributes;
begin
 Result := inherited GetAttributes + [paDialog] - [paSubProperties];
end;


procedure TVisTrackBar_ScriptPropEdit.Edit;
begin
   if GetComponent(0) is TVisTrackBar then
    if  ShowScriptEdit(TVisTrackBar(GetComponent(0))) then
         Modified;
end;


initialization
  PSScript := nil;
  PSScript_refcount := 0;

  tmp_compile_src := '*';
  tmp_compile_out := '';

finalization
  dec(PSScript_refcount);
  if PSScript_refcount = 0 then begin
    PSScript.Free;
    PSScript := nil;
  end;

end.
