uheartmachine.pas

心电图显示波形控件心电图显示波形控件心电图显示波形控件

//  THeartMachine released to the public domain by the author
//  Adi L. Miller, [e-mail] 26/01/2000
//
//  Excuse the dust. Spaghetti code, but it works
//
//  Please sumbit all bug-fixes, enhancments or additions to the author
//  or just Email me that you have downloaded it... -- [e-mail]
//
//  See code for relevance info
//
//  To Do:
//
//  1. Make the DrawSeries method more efficient for high-end use
//
//
unit uHeartMachine;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus;

const
  TheColors :Array[0..16] of TColor = (clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clLtGray, clDkGray, clWhite, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray, clSilver);

type
  TGraph = Array [1..100] of Integer; // Maximum number of points (640k should be enough for everyone...)

  THeartMachine = class(TGraphicControl)
  private
    FColorBackground,   // Color of component background
    FColorGrid: TColor; // Color of grid lines
    FHGridCount,        // Number of horizontal grid lines
    FHTickCount: Byte;  // Number of ticks visible in the component
    FMin,               // Minimum value of point
    FMax: Integer;      // Maximum value of point
    FSeries: Array of TGraph;  // Array of points (each for a serie)
    FSeriesVisible: Array of Boolean; // If each serie is visible or not
    FNumOfSeries: Integer;  // Number of series
    FPopupMenu: TPopupMenu;
    procedure SetColorBackground(const Value: TColor);
    procedure SetColorGrid(const Value: TColor);
    procedure SetHGridCount(const Value: Byte);
    function RealToGrid(I: Integer): Integer; // Translates the value of the point to the absolute location on the component canvas. Needs work!
  protected
    procedure DrawBackground;
    procedure DrawGrid;
    procedure Paint; override;
    procedure DrawSeries;
    property PopupMenu;
    procedure PopupMenuDraw(Sender: TObject; ACanvas: TCanvas;
      ARect: TRect; Selected: Boolean);
    procedure PopupMeasureItem(Sender: TObject; ACanvas: TCanvas;
      var Width, Height: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddPoint(Series, Point: Integer; Name: String='');
    procedure PopupMenuClicked(Sender: TObject);
  published
    property Align;
    property ColorBackground: TColor read FColorBackground write SetColorBackground;
    property ColorGrid: TColor read FColorGrid write SetColorGrid;
    property HGridCount: Byte read FHGridCount write SetHGridCount;
    property Min: Integer read FMin write FMin;
    property Max: Integer read FMax write FMax;
    property HTickCount: Byte read FHTickCount write FHTickCount;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('System', [THeartMachine]);
end;

{ THeartMachine }

procedure THeartMachine.AddPoint(Series, Point: Integer; Name: String='');
var
  I: Integer;
  tmpMenuItem: TMenuItem;
begin
  // Making a simple range check
  if (Point > Max) or (Point < Min) then
    raise ERangeError.Create('Point value out of range ('+IntToStr(Point)+')');
  // Checking to see if a creation of a new serie is in order if so create
  if FNumOfSeries < Series then
  begin
    Inc(FNumOfSeries);
    SetLength(FSeriesVisible, Series+1);
    SetLength(FSeries, Series+1);    // Assuming that AddPoint does
    For I := 1 to 100 do             // address a serie higher then
      FSeries[Series][I] := 0;       // one of an already existing serie
    FSeriesVisible[Series] := True;  // Potential bug/mess-up
  end;
  // Creat a new menu item if missing for current serie. Should happen:
  //    1. When a new serie was just added at the section above
  //    2. When the first AddPoint called, cause .Create didn't creat the first menu itme
  if PopupMenu.Items.Count < Series+1 then
  begin
    tmpMenuItem := TMenuItem.Create(self);
    tmpMenuItem.Caption := Name;
    tmpMenuItem.Tag := Series;
    tmpMenuItem.OnClick := PopupMenuClicked;
    tmpMenuItem.Checked := True;
    tmpMenuItem.OnDrawItem := PopupMenuDraw;
    tmpMenuItem.OnMeasureItem := PopupMeasureItem;
    PopupMenu.Items.Add(tmpMenuItem);
    PopupMenu.OwnerDraw := True;
  end;
  // Update the name of the serie
  PopupMenu.Items[Series].Caption := Name;
  // Moving all points back
  For I := 2 to 100 do
    FSeries[Series][I-1] := FSeries[Series][I];
  // Placing Point in place 100
  FSeries[Series][100] := Point;

  DrawSeries;
end;

constructor THeartMachine.Create(AOwner: TComponent);
var
  I: Integer;
begin
  inherited;
  FPopupMenu := TPopupMenu.Create(Self);
  PopupMenu := FPopupMenu;
  Parent := TWinControl(AOwner);
  FNumOfSeries := 0;
  Width := 100;
  Height := 100;
  FMin := 1;
  FMax := 10;
  FHTickCount := 10;
  FHGridCount := 5;
  ColorBackground := clBlack;
  ColorGrid := clGreen;
  SetLength(FSeries, 1);
  SetLength(FSeriesVisible, 1);
  Align := alClient;
  For I := 1 to 99 do
    FSeries[0][I] := 0;
  FSeriesVisible[0] := True;
end;

destructor THeartMachine.Destroy;
begin
  inherited;
end;

procedure THeartMachine.DrawBackground;
var
  tmpRect: TRect;
begin
  tmpRect.Top := 0;
  tmpRect.Left := 0;
  tmpRect.Bottom := Height;
  tmpRect.Right := Width;
  Canvas.Brush.Color := ColorBackground;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(tmpRect);
end;

procedure THeartMachine.DrawGrid;
var
  I, II, Factor, XFactor: Integer;
begin
  DrawBackground;

  // Horizontal grid lines
  Factor := (Height div (HGridCount));
  Canvas.Pen.Color := ColorGrid;
  Canvas.Pen.Width := 1;
  For I := 1 to HGridCount-1 do
  begin
    Canvas.MoveTo(0,(I*Factor));
    Canvas.LineTo(Width,(I*Factor));
  end;

  // Vertical grid lines
  XFactor := Width div HTickCount;
  For II := 99 downto 100-HTickCount do
  begin
    Canvas.MoveTo(XFactor*(HTickCount-(100-II)), 0);
    Canvas.LineTo(XFactor*(HTickCount-(100-II)), Height);
  end;
end;

procedure THeartMachine.DrawSeries;
var
  XFactor, I, II: Integer;
begin
  // Very in-efficient draw. If the component is to be used in a process
  // which paints it self more than once a second, then this method
  // should be imporved or flickering would occur.
  // To improve, use CopyRect to move the already painted area backwards
  // and just repaint the new points.
  // Special care should be made to the following situation:
  //
  // Every serie can add a point regardless of others
  DrawGrid;
  Canvas.Pen.Width := 1;
  XFactor := Width div HTickCount;
  For I := 0 to Length(FSeries) - 1 do
    if FSeriesVisible[I] then
    begin
      Canvas.Pen.Color := TheColors[I];
      Canvas.MoveTo(XFactor*(HTickCount), RealToGrid(FSeries[I][100]));
      For II := 99 downto 100-HTickCount do
        Canvas.LineTo(XFactor*(HTickCount-(100-II)), RealToGrid(FSeries[I][II]));
    end;
end;

procedure THeartMachine.Paint;
begin
  inherited;
  DrawSeries;
end;

procedure THeartMachine.PopupMeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
begin
  // To give menu items broader boundry
  Width := ACanvas.TextWidth((Sender as TMenuItem).Caption)+10;
end;

procedure THeartMachine.PopupMenuClicked(Sender: TObject);
var
  B: Boolean;
  tmpMenuItem: TMenuItem;
begin
  // To make a serie disappear/reappear from the graph
  tmpMenuItem := (Sender as TMenuItem);
  B := not FSeriesVisible[tmpMenuItem.Tag];
  FSeriesVisible[tmpMenuItem.Tag] := B;
  tmpMenuItem.Checked := B;
  DrawSeries;
end;

procedure THeartMachine.PopupMenuDraw(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; Selected: Boolean);
var
  AMenuItem: TMenuItem;
  tmpRect: TRect;
begin
  // Draw the menu items
  AMenuItem := (Sender as TMenuItem);
  if Selected then
  begin
    // Highlighted rect
    ACanvas.Brush.Color := clActiveCaption;
    ACanvas.FillRect(ARect);
  end else
  begin
    // Un-highlighted rect
    ACanvas.Brush.Color := clBtnFace;
    ACanvas.FillRect(ARect);
  end;
  // Draw menu text with the assigned color from the TheColors set
  ACanvas.Font.Color := TheColors[AMenuItem.Tag];
  ACanvas.TextOut(ARect.Left+12, ARect.Top+3, AMenuItem.Caption);
  // Draw V mark
  if AMenuItem.Checked then
  begin
    if Selected then
      ACanvas.Pen.Color := clCaptionText
    else
      ACanvas.Pen.Color := clMenuText;
    ACanvas.Pen.Width := 2;
    ACanvas.MoveTo(ARect.Left+1, ARect.Top+9);
    ACanvas.LineTo(ARect.Left+4, ARect.Top+12);
    ACanvas.LineTo(ARect.Left+9, ARect.Top+6);
  // Or use this code instead of the drawn V mark for a simple square
{    ACanvas.Brush.Color := clBlack;
    with tmpRect do
    begin
      Left := 3; Top := ARect.Top+8; Right := 7; Bottom := ARect.Top+12;
    end;
    ACanvas.FillRect(tmpRect);}
  end;
end;

function THeartMachine.RealToGrid(I: Integer): Integer;
begin
  // Translates the value given by the "user" to a value absolute to
  // the component's canvas.
  Result := Trunc((Height-2) - ((I-Min)*((Height-2) / (Max-Min))))+1;
end;

procedure THeartMachine.SetColorBackground(const Value: TColor);
begin
  // rtfm
  FColorBackground := Value;
  DrawGrid;
end;

procedure THeartMachine.SetColorGrid(const Value: TColor);
begin
  // rtfm
  FColorGrid := Value;
  DrawGrid;
end;

procedure THeartMachine.SetHGridCount(const Value: Byte);
begin
  // rtfm
  FHGridCount := Value;
  DrawGrid;
end;

end.