gradprogress.pas

gradprogress控件源程序,gradprogress控件源程序.

{ 
[e-mail]
25/10/98 Original version
28/10/98 Removed a whole lot of rubbish
         fixed Stepit
         added percent 
         added backcolor
Johan W. Strikkers
}

unit GradProgress;


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Extctrls, StdCtrls;

type
  TBevelWidth = 1..10;
  TGradProgress = class(TGraphicControl)
  private
    { Private declarations }
    Fr,FG,FB: integer;
    DR,DG,DB: integer;
    FBevelStyle: TBevelStyle;
    FBevelWidth: TBevelWidth;
    FStartColor: TColor;
    FEndColor: TColor;
    FBackColor: TColor;
    FPosition: integer;
    FMaxValue: integer;
    FStep: integer;
    FShowPercent: boolean;
    procedure SetBevelStyle(val: TBevelStyle);
    procedure SetBevelWidth(val: TBevelWidth);
    procedure SetStartColor(val: TColor);
    procedure SetEndColor(val: TColor);
    procedure SetPosition(val: integer);
    procedure SetMaxValue(val: integer);
    procedure SetStep(val: integer);
    procedure SetShowPercent(val: boolean);
    procedure SetBackColor(val: TColor);
    procedure PaintBevel;
    procedure CalculateDColor;
  protected
    { Protected declarations }
    procedure paint; override;
  public
    { Public declarations }
    constructor create(Aowner: TComponent); override;
    destructor destroy; override;
  published
    { Published declarations }
    property Align;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property Visible;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    
    property BevelStyle: TBevelStyle read FBevelStyle write SetBevelStyle;
    property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth;
    property StartColor: TColor read FStartColor write SetStartColor;
    property EndColor: TColor read FEndColor write SetEndColor;
    property Position: integer read FPosition write SetPosition;
    property MaxValue: integer read FMaxValue write SetMaxValue;
    property Step: integer read FStep write SetStep;
    property ShowPercent: boolean read FShowPercent write SetShowPercent;
    property BackColor: TColor read FBackColor write SetBackColor;
    procedure Stepit;
  end;

procedure Register;

implementation


constructor TGradProgress.create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Width        := 150;
  Height       := 16;
  Font.Size    := 8;
  Font.Name    := 'Default';
  Font.Color   := clWhite;
  Font.Style   := [];
  FBevelStyle  := bsLowered;
  FBevelWidth  := 1;
  FStartColor  := clBlue;
  FEndColor    := clRed;
  FBackColor   := clBtnFace;
  FPosition    := 0;
  FMaxValue    := 100;
  FShowPercent := True;
  FStep        := 1;
  CalculateDColor;
end;

destructor TGradProgress.destroy;
begin
  inherited;
end;

procedure TGradProgress.SetShowPercent(val: boolean);
begin
  if val <> FShowPercent then begin
    FShowPercent := val;
    repaint;
  end;  
end;

procedure TGradProgress.Stepit;
begin
  SetPosition(FPosition + FStep);
end;

procedure TGradProgress.SetStep(Val: integer);
begin
  if Val <> FStep then FStep := val;
end;

procedure TGradProgress.SetBevelStyle(Val: TBevelStyle);
begin
  if val <> FBevelStyle then begin
    FBevelStyle := Val;
    repaint;
  end;  
end;

procedure TGradProgress.SetBevelWidth(Val: TBevelWidth);
begin
  if val <> FBevelWidth then begin
    if (val * 2) <= (Width-4) then FBevelWidth := Val;
    repaint;
  end;  
end;

procedure TGradProgress.CalculateDColor;
begin
  FR := FStartColor  and $000000FF;  
  FG := (FStartColor shr 8) and $000000FF;
  FB := (FStartColor shr 16) and $000000FF;
  DR := (FEndColor   and $000000FF) - FR;   
  DG := ((FEndColor  shr 8) and $000000FF) - FG;
  DB := ((FEndColor  shr 16) and $000000FF) - FB;
end;

procedure TGradProgress.SetStartColor(Val: TColor);
begin
  if FStartColor <> Val then begin
    FStartColor := val;
    CalculateDColor;
    repaint;
  end;
end;

procedure TGradProgress.SetEndColor(Val: TColor);
begin
  if FEndColor <> Val then begin
    FEndColor := val;
    CalculateDColor;
    repaint;
  end;  
end;

procedure TGradProgress.SetBackColor;
begin
  if FBackColor <> Val then begin
    FBackColor := val;
    repaint;
  end;  
end;

procedure TGradProgress.SetPosition(Val: integer);
begin
  if (Fposition <> Val) and
     (Val <= FMaxValue) and
     (Val >= 0) then begin
    FPosition := Val;
  if (csDesigning in ComponentState) then repaint
  else paint;
  end;  
end;

procedure TGradProgress.SetMaxValue(Val: integer);
begin
  if Val <> FMaxValue then begin
    FMaxValue := Val;
    if Fposition > FMaxValue then FPosition := FMaxValue;
    repaint;
  end;  
end;

procedure TGradProgress.paint;
var
  BM: TBitmap;
  str: string;
  Rect : Trect;
  x:integer;
  Step: integer;
  FPos:integer;
  Ro,Gr,Bl: Byte;
begin
  PaintBevel;
  FPos := MulDiv(FPosition, Width, FMaxValue);
  Rect.Top    := FBevelWidth + 1;
  Rect.Left   := FBevelWidth + 1;
  Rect.Bottom := Height - FBevelWidth;
  Rect.Right  := Width - FBevelWidth; 
  BM := TBitmap.Create;
  with BM.Canvas do begin
    BM.Width  := Rect.Right;  //Width;
    BM.Height := Rect.Bottom; //Height;
    Pen.Style := psSolid;
    Pen.Width := 0;
    for x := 0 to FPos do begin  
      Step := MulDiv(255,x,FPos);
      Ro   := fr + MulDiv(Step, dr, 255);
      Gr   := fg + MulDiv(Step, dg, 255);
      Bl   := fb + MulDiv(Step, db, 255);
      Pen.Color := RGB(Ro, Gr, Bl);
      MoveTo(x, Rect.top);
      LineTo(x, Rect.bottom);
    end;
    Brush.Color := FBackColor;
    rectangle(Fpos,Rect.Top-1,Width,Height);
//    Pen.Color := FBackColor;
//    for x := FPos to width do begin
//      MoveTo(x, Rect.top);
//      LineTo(x, Rect.bottom);
//    end;
    Brush.Style := Bsclear;
  end;
  if FShowPercent then begin
    With BM.Canvas.Font do begin
    Color := font.color;
    Size  := Font.Size;
    Style := Font.Style;
    Name  := Font.Name;
    end;
    str := Inttostr(muldiv(FPos, 100, width)) + '%';
    Drawtext(bm.Canvas.Handle, Pchar(str), Length(str),
             Rect, Dt_Center Or Dt_Vcenter Or Dt_Singleline);
  end;  
  Canvas.CopyRect(rect,BM.Canvas,rect);
  bm.free;
end;

procedure TGradProgress.PaintBevel;
var
  pcBottom: TColor;
  pcTop: TColor;
  bw: integer;
begin
  With canvas do begin
    Pen.Style := psSolid;
    Pen.Width := 0;
    if FBevelStyle = bsRaised  then begin
      pcTop    := clWhite;
      pcBottom := clGray;
    end else begin
      pcTop    := clGray;
      pcBottom := clWhite;
    end;
    Pen.Color := pcTop;  
    for bw := 0 to FBevelWidth do begin
      MoveTo(bw, bw);
      LineTo(width - bw, bw);
      MoveTo(bw, bw);
      LineTo(bw, Height - bw);
    end;  
    Pen.Color := pcBottom;
    for bw := 0 to FBevelWidth do begin
      MoveTo(Width - bw, Height - bw);
      LineTo(width - bw, bw - 1);
      MoveTo(width - bw, Height - bw);
      LineTo(bw - 1, Height - bw);
    end;
  end;
end;

procedure Register;
begin
  RegisterComponents('JWS', [TGradProgress]);
end;

end.