coolgauge.pas

来自「用于开发税务票据管理的软件」· PAS 代码 · 共 332 行

unit CoolGauge;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls;

type
  TCoolGauge = class(TGraphicControl)
  private
    { Private declarations }
    FBackColour: TColor;
    FBitmap: TBitmap;
    FEndColour: TColor;
    FShowAsPercent: Boolean;
    FStartColour: TColor;
    FFont: TFont;
    FShowFont: Boolean;

    FMin: LongInt;
    FMax: LongInt;
    FValue: LongInt;

    procedure ChangeBackColour(const NewVal: TColor);
    procedure ChangeEndColour(const NewVal: TColor);
    procedure ChangeFont(const NewVal: TFont);
    procedure ChangeMax(const NewVal: LongInt);
    procedure ChangeMin(const NewVal: LongInt);
    procedure ChangeShowAsPercent(const NewVal: Boolean);
    procedure ChangeShowFont(const NewVal: Boolean);
    procedure ChangeStartColour(const NewVal: TColor);
    procedure ChangeValue(const NewVal: LongInt);
  protected
    { Protected declarations }
    procedure WMERASEBKGND(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;

  published
    { Published declarations }

    property BackColour: TColor Read FBackColour Write ChangeBackColour;
    property EndColour: TColor Read FEndColour Write ChangeEndColour;
    property StartColour: TColor Read FStartColour Write ChangeStartColour;

    property Font: TFont Read FFont Write ChangeFont;
    property ShowText: Boolean Read FShowFont Write ChangeShowFont;
    property ShowTextAsPercent: Boolean Read FShowAsPercent Write ChangeShowAsPercent default True;

    property Max: LongInt Read FMax Write ChangeMax;
    property Min: LongInt Read FMin Write ChangeMin;
    property Value: LongInt Read FValue Write ChangeValue;

    property Align;
    property Cursor;
    property DragCursor;
    property Enabled;
    property Hint;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;

    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;

  end;

procedure Register;

implementation

//{$R *.DCR}

procedure TCoolGauge.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
  Msg.Result := 1; // stops flicker
end;

constructor TCoolGauge.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  ControlStyle := ControlStyle + [csOpaque];   // reduces flicker some more

  Width := 100;
  Height := 35;
  FBitmap := TBitmap.Create;
  FBitmap.Width := 100;
  FBitmap.Height := 100;

  FMin := 0;
  FMax := 100;
  FValue := 0;
  FShowAsPercent := True;

  FBackColour := clWhite;
  FStartColour := clRed;
  FEndColour := clYellow;

  FFont := TFont.Create;
  FFont.Name := 'Verdana';
  FFont.Style := FFont.Style + [fsBold];
  FFont.Size := 12;
  FFont.Color := clGray;
end;

destructor TCoolGauge.Destroy;
begin
  FBitmap.Free;
  FFont.Free;
  inherited Destroy;
end;

procedure TCoolGauge.Paint;
var
  iter: Integer;
  Change: Array[1..3] of Real;
  Curr: Array[1..3] of Byte;
  W: Real;
  W2: Integer;
  AmountText: String;
  TextBmp: TBitmap;
  r,g,b: Byte;
begin
  inherited Paint;

  if FBitmap.Width <> Width then FBitmap.Width := Width;
  if FBitmap.Height <> Height then FBitmap.Height := Height;

  FBitmap.Canvas.Brush.Color := FBackColour;
  FBitmap.Canvas.FillRect( Canvas.ClipRect);

  R := GetRValue(FStartColour);
  G := GetGValue(FStartColour);
  B := GetBValue(FStartColour);

  if (FValue - FMin) > 0 then
  begin
      Change[1] := (GetRValue( FEndColour ) - R) / 256;
      Change[2] := (GetGValue( FEndColour ) - G) / 256;
      Change[3] := (GetBValue( FEndColour ) - B) / 256;
  end;

  Curr[1] := R;
  Curr[2] := G;
  Curr[3] := B;

  if FMax - FMin = 0 then
    raise Exception.Create('Error - max and min values are the same!');

{     WIDTH / 100 = 1% strip ( = 2.09 in this example)
    (FVALUE - FMIN) * 100 / (FMAX - FMIN)  = % of progress ( = 20% here)

    (FVALUE - FMIN) * 100   *  WIDTH  =    HOW MUCH OF WIDTH TO DISPLAY,
    ---------------------      -----       THEN DIVIDE BY 256 TO GET SIZE OF
         FMAX - FMIN            100        EACH RECTANGLE TO FILL

    = 20 * 2.09

    WANTED ANSWER = 41.8...... }

  W := (((FValue - FMin) / (FMax - FMin)) * (Width)) / 256;
  W2 := Round(W + 0.5);

  if FValue > FMin then
    for iter := 0 to 255 do
    begin
      Curr[1] := R + Round(iter * Change[1]);
      Curr[2] := G + Round(iter * Change[2]);
      Curr[3] := B + Round(iter * Change[3]);

      FBitmap.Canvas.Brush.Color := RGB( Curr[1], Curr[2], Curr[3] );
      FBitmap.Canvas.FillRect(Bounds( Round(iter * W),
                                      0,
                                      W2,
                                      Height) );
    end;

  if FShowFont then
  begin
    TextBmp := TBitmap.Create;
    try
      TextBmp.Canvas.Font.Assign(FFont);

      if FShowAsPercent then
        AmountText := Format('%d%%', [(((FValue - FMin) * 100) div (FMax - FMin))])
      else
        AmountText := Format('%d', [FValue]);

      TextBmp.Width := TextBmp.Canvas.TextWidth(AmountText);
      TextBmp.Height := TextBmp.Canvas.TextHeight(AmountText);
      TextBmp.Canvas.Brush.Color := clBlack;
      TextBmp.Canvas.FillRect(TextBmp.Canvas.ClipRect);

      TextBmp.Canvas.TextOut(0,0, AmountText);
      TextBmp.Transparent := True;
      TextBmp.TransparentColor := clBlack;
      FBitmap.Canvas.Draw((FBitmap.Width - TextBmp.Canvas.TextWidth(AmountText)) shr 1,
                          (FBitmap.Height - TextBmp.Canvas.TextHeight(AmountText)) shr 1,
                           TextBmp );
    finally
      TextBmp.Free;
    end;
  end;

  BitBlt(Canvas.Handle,0,0,FBitmap.Width,FBitmap.Height,
         FBitmap.Canvas.Handle,0,0,SRCCOPY);
//    Canvas.Draw(0,0, Bitmap);
end;

procedure TCoolGauge.ChangeBackColour(const NewVal: TColor);
begin
  if NewVal <> FBackColour then
  begin
    FBackColour := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeEndColour(const NewVal: TColor);
begin
  if NewVal <> FEndColour then
  begin
    FEndColour := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeFont(const NewVal: TFont);
begin
  if NewVal <> FFont then
  begin
    FFont.Assign(NewVal);
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeMax(const NewVal: LongInt);
begin
  if FValue > NewVal then
    FValue := NewVal;

  if NewVal <= FMin then
  begin
    FMax := FMin + 1;
    Invalidate;
    Exit;
  end;

  if NewVal <> FMax then
  begin
    FMax := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeMin(const NewVal: LongInt);
begin
  if FValue < NewVal then
    FValue := NewVal;

  if NewVal >= FMax then
  begin
    FMin := FMax - 1;
    Invalidate;
    Exit;
  end;

  if NewVal <> FMin then
  begin
    FMin := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeShowAsPercent(const NewVal: Boolean);
begin
  if NewVal <> FShowAsPercent then
  begin
    FShowAsPercent := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeShowFont(const NewVal: Boolean);
begin
  if NewVal <> FShowFont then
  begin
    FShowFont := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeStartColour(const NewVal: TColor);
begin
  if NewVal <> FStartColour then
  begin
    FStartColour := NewVal;
    Invalidate;
  end;
end;

procedure TCoolGauge.ChangeValue(const NewVal: LongInt);
begin
  if NewVal <> FValue then
  begin
    if NewVal < FMin then FValue := FMin else
    if NewVal > FMax then FValue := FMax else
    FValue := NewVal;

    Invalidate;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TCoolGauge]);
end;

end.