aboppnt.pas

来自「著名的虚拟仪表控件,包含全部源码, 可以在,delphi2007 下安装运行」· PAS 代码 · 共 436 行

unit AbOpPnt;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                       Component TAbOperatingPoint                            }
{                                                                              }
{******************************************************************************}
{        e-Mail: [e-mail] , Web: http://www.abaecker.com            }
{------------------------------------------------------------------------------}
{          (c) Copyright 1998..2000 A.Baecker, All rights Reserved             }
{******************************************************************************}

{$I abks.inc}

interface

uses
  Windows,
  Classes,
  Graphics,
  Controls,
  extctrls,
  Messages,
  SysUtils,
 {****** Abakus VCL - Units ******}
  AbFlashT,
  _GClass,
  _AbInfo,
  _AbProc;

const
  MaxArraySize      = (65520 div SizeOf(TPoint));



type
  TailArrayType = array[1..MaxArraySize] of TPoint;

  TIndRect = class(TPersistent)
  private
  public
    FLeft: Smallint;
    FTop: Smallint;
    FRight: Smallint;
    FBottom: Smallint;
    procedure SetxyRect(Value: TRect);
    function GetxyRect: TRect;
  published
    property Left: Smallint read FLeft write FLeft;
    property Top: Smallint read FTop write FTop;
    property Right: Smallint read FRight write FRight;
    property Bottom: Smallint read FBottom write FBottom;
  end;

  TAbOperatingPoint = class(TAbGraphicControl)
  private
    FAbInfo: TAbInfo;
    FCharacteristicBMP: TBitmap;
    FDigitX: Smallint;
    FDigitY: Smallint;
    FSignalSettingsX: TSignalSettings;
    FSignalSettingsY: TSignalSettings;
    FTail: Boolean;
    FTailArraySize: Smallint;
    FValueX: Single;
    FValueY: Single;
    FIndRect: TIndRect;
    FInterval: Smallint;
    FTailColor: TColor;
    r: TRect;
    AnzPulses: Smallint;
    PulseCount: Smallint;
    PPTx: Smallint;
    PPTy: Smallint;
    TailArray: ^TailArrayType;
    PointAnz: Smallint;
    xyRect: TRect;
    Painting : Boolean;
  protected
    procedure Paint; override;
    procedure ParamChange(Sender: TObject); override;
    procedure WMFlash(var Message: TMessage); message WM_FLASH;
    procedure DrawPoints;
    procedure SetDigitX(Value: Smallint);
    procedure SetDigitY(Value: Smallint);
    procedure SetValueX(Value: Single);
    procedure SetValueY(Value: Single);
    procedure SetTailArraySize(Value: Smallint);
    procedure SetInterval(Value: Smallint);
  public
    procedure DrawPoint(can: TCanvas; x, y: Smallint; Tail: Boolean);
    procedure SetCharacteristicBMP(Value: TBitmap);
    procedure MovePoints;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
    property OnStartDrag;
    property Visible;
    property Color default clYellow;

    property AbInfo: TAbInfo read FAbInfo
    write FAbInfo stored false;

    property CharacteristicBMP: TBitmap read FCharacteristicBMP
    write SetCharacteristicBMP;

    property DigitX: Smallint read FDigitX
    write SetDigitX;

    property DigitY: Smallint read FDigitY
    write SetDigitY;

    property SignalSettingsX: TSignalSettings read FSignalSettingsX
    write FSignalSettingsX;

    property SignalSettingsY: TSignalSettings read FSignalSettingsY
    write FSignalSettingsY;

    property Tail: Boolean read FTail
    write FTail default true;

    property TailArraySize: Smallint read FTailArraySize
    write SetTailArraySize default 20;

    property ValueX: Single read FValueX
    write SetValueX;

    property ValueY: Single read FValueY
    write SetValueY;

    property IndRect: TIndRect read FIndRect
    write FIndRect;

    property Interval: Smallint read FInterval
    write SetInterval default 1000;

    property TailColor: TColor read FTailColor
    write FTailColor default clAqua;
  end;

implementation

procedure TIndRect.SetxyRect(Value: TRect);
begin
  Left := Value.Left;
  Top := Value.Top;
  Right := Value.Right;
  Bottom := Value.Bottom;
end;

function TIndRect.GetxyRect: TRect;
begin
  result := Rect(Left, Top, Right, Bottom);
end;

destructor TAbOperatingPoint.Destroy;
begin
  FSignalSettingsX.Free;
  FSignalSettingsY.Free;
  DelControl(self);
  FCharacteristicBMP.Free;
  FIndRect.Free;
  FreeMem(TailArray, (TailArraySize + 2) * SizeOf(TPoint));
  PointAnz := 0;
  inherited Destroy;
end;

constructor TAbOperatingPoint.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  BeginUpdate;

  FSignalSettingsX := TSignalSettings.Create;

  FSignalSettingsY := TSignalSettings.Create;

  Height := 150;
  Width := 150;

  FCharacteristicBMP := TBitmap.Create;

  FIndRect := TIndRect.Create;

  r := ClientRect;
  AbBorder(r, 4);
  xyRect := r;
  IndRect.SetxyRect(r);

  FTailArraySize := 20;
  TailArray := AllocMem((TailArraySize + 2) * SizeOf(TPoint));

  PointAnz := 0;
  PulseCount := 1;
  Color := clYellow;
  TailColor := clFuchsia;
  Tail := true;
  FInterval := 1000;

  if (csDesigning in Componentstate) then Loaded;

end;

procedure TAbOperatingPoint.Loaded;
begin
  inherited Loaded;

  FSignalSettingsX.OnChange := ParamChange;
  FSignalSettingsY.OnChange := ParamChange;
  EndUpdate;
  AddControl(self, FInterval);
end;

procedure TAbOperatingPoint.SetTailArraySize(Value: Smallint);
begin
  if Value < MaxArraySize then
  begin
    if Value < 2 then Value := 2;
    if Value > 100 then Value := 100;
    FreeMem(TailArray, (TailArraySize + 2) * SizeOf(TPoint));
    FTailArraySize := Value;
    TailArray := AllocMem((TailArraySize + 2) * SizeOf(TPoint));
    PointAnz := 0;
  end;
end;

procedure TAbOperatingPoint.SetInterval(Value: Smallint);
begin
  if Value > 49 then
  begin
    FInterval := Value;
    AddControl(self, FInterval);
  end;
end;

procedure TAbOperatingPoint.SetCharacteristicBMP(Value: TBitmap);
begin
  FCharacteristicBMP.Assign(Value);

  if FCharacteristicBMP.Empty then
  begin
  end
  else
  begin
    Width := FCharacteristicBMP.Width;
    Height := FCharacteristicBMP.Height;
  end;

  r := FCharacteristicBMP.Canvas.Cliprect;
  AbBorder(r, 4);
  xyRect := r;
  IndRect.SetxyRect(r);

  Change;
end;

procedure TAbOperatingPoint.SetDigitX(Value: Smallint);
begin
  FDigitX := Value;
  FValueX := SignalSettingsX.ValueFrom +
    (FDigitX - SignalSettingsX.DigitalFrom) * SignalSettingsX.ValuePerDigit;
end;

procedure TAbOperatingPoint.SetDigitY(Value: Smallint);
begin
  FDigitY := Value;
  FValueY := SignalSettingsY.ValueFrom +
    (FDigitY - SignalSettingsY.DigitalFrom) * SignalSettingsY.ValuePerDigit;
end;

procedure TAbOperatingPoint.SetValueX(Value: Single);
begin
  FValueX := Value;
  FDigitX := Round(SignalSettingsX.DigitalFrom +
    (FValueX - SignalSettingsX.ValueFrom) * SignalSettingsX.DigitPerValue);
end;

procedure TAbOperatingPoint.SetValueY(Value: Single);
begin
  FValueY := Value;
  FDigitY := Round(SignalSettingsY.DigitalFrom +
    (FValueY - SignalSettingsY.ValueFrom) * SignalSettingsY.DigitPerValue);
end;


procedure TAbOperatingPoint.WMFlash(var Message: TMessage);
begin
  if Painting then exit;
  with Message do
  begin
    DrawPoints;
  end;
end;

procedure TAbOperatingPoint.DrawPoints;
var
  TempBmp           : TBitmap;
begin
  Painting := true;
  Inc(PulseCount);
  xyRect := IndRect.GetxyRect;
  AbBorder(xyRect, -5);

  if not FCharacteristicBMP.Empty then
  begin

    if not (csDesigning in Componentstate) then PulseCount := 0;

    TempBmp := TBitmap.Create;
    TempBmp.Width := xyRect.Right - xyRect.Left;
    TempBmp.Height := xyRect.Bottom - xyRect.Top;

    TempBmp.Canvas.CopyRect(Rect(0, 0, TempBmp.Width, TempBmp.Height),
      FCharacteristicBMP.Canvas, xyRect);

    r := ClientRect;

    PPTx := Round((1000 / SignalSettingsX.TotalValue) *
      (FValueX - SignalSettingsX.ValueFrom));

    PPTy := Round((1000 / SignalSettingsY.TotalValue) *
      (FValueY - SignalSettingsY.ValueFrom));

    if PPTx > 1000 then
      PPTx := 1000
    else
      if PPTx < 0 then PPTx := 0;
    if PPTy > 1000 then
      PPTy := 1000
    else
      if PPTy < 0 then PPTx := 0;

    DrawPoint(TempBmp.Canvas, 5 + Round(((TempBmp.Width - 11) / 1000) * PPTx),
      5 + (Round(((TempBmp.Height - 11) / 1000) * (1000 - PPTy))), Tail);

    MovePoints;

    if Visible or (csDesigning in Componentstate) then
      Canvas.Draw(xyRect.Left, xyRect.Top, TempBmp);
    TempBmp.Free;
  end;
  if csDesigning in Componentstate then
  begin
    Canvas.Pen.Width := 1;
    Canvas.Pen.Style := psDot;
    Canvas.Pen.Color := TailColor;
    Canvas.Brush.Style := bsClear;
    Canvas.Rectangle(xyRect.Left + 5, xyRect.Top + 5, xyRect.Right - 5,
      xyRect.Bottom - 5);
  end;
  Painting := False;

end;

procedure TAbOperatingPoint.Paint;
begin
  if Painting then exit;
  Painting := true;
  if FCharacteristicBMP.Empty then
  begin
    Canvas.Pen.Color := clBlack;
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := clBtnHighlight;
    Canvas.Pen.Style := psSolid;

    Canvas.Rectangle(0, 0, Width, Height);
    AbTextOut(Canvas, Width div 2, Height div 2, 'No CharacteristicBMP',
      toMidCenter);
  end
  else
  begin
    xyRect := IndRect.GetxyRect;
    Width := FCharacteristicBMP.Width;
    Height := FCharacteristicBMP.Height;
    Canvas.Draw(0, 0, FCharacteristicBMP);
    PulseCount := AnzPulses;
    DrawPoints;
  end;
  Painting := false;
end;

procedure TAbOperatingPoint.DrawPoint(can: TCanvas; x, y: Smallint; Tail:
  Boolean);
begin
  try
    TailArray^[1] := Point(x, y);
    with can do
    begin
      Pen.Color := TailColor;
      Pen.Width := 1;
      if Tail then
      begin
        polyline(Slice(TailArray^, PointAnz));
      end;

      Pen.Color := Color;
      Pen.Width := 3;

      moveTo(TailArray^[1].x - 5, TailArray^[1].y);
      LineTo(TailArray^[1].x + 5, TailArray^[1].y);
      moveTo(TailArray^[1].x, TailArray^[1].y - 5);
      LineTo(TailArray^[1].x, TailArray^[1].y + 5);

    end;
  except
  end;
end;

procedure TAbOperatingPoint.MovePoints;
begin
  try
    move(TailArray^[1], TailArray^[2], PointAnz * SizeOf(TPoint));
    Inc(PointAnz);
    if PointAnz > TailArraySize then PointAnz := TailArraySize;
  except
  end;
end;

procedure TAbOperatingPoint.ParamChange(Sender: TObject);
begin
  inherited ParamChange(self);
  Invalidate;
end;

end.