UNE BARRE DE PROGRESSION EN RELIEF (STYLE PRODJ)

unit MdrnG;
interface
{$R MdrGauge.dcr}
uses Windows, SysUtils, Classes, Graphics, Controls;
type
  TModernGauge = class(TCustomControl)
  private
    FMin : integer;
    FMax : integer;
    FPos : integer;
    FColor : TColor;
    FShadow : TColor;
    FOnProgress : TNotifyEvent;
    procedure SetMin(Value : integer);
    procedure SetMax(Value : integer);
    procedure SetPosition(Value : integer);
    procedure SetGlobalColor(Value : TColor);
    procedure SetShadowColor(Value : TColor);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure IncrementProgress;
     function GetPercentDone: integer;
  published
    property Align;
    property Cursor;
    property Hint;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property Min: integer read FMin write SetMin;
    property Max: integer read FMax write SetMax;
    property Position: integer read FPos write SetPosition;
    property GlobalColor: TColor read FColor write SetGlobalColor;
    property ShadowColor: TColor read FShadow write SetShadowColor;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
  end;
procedure Register;
implementation

  function SolveForY(X, Z: Integer): integer;
  begin
    if Z=0 then Result:=0
    else Result:=trunc((X*100)/Z);
  end;
  function ReverseColor(thecolor: Integer): integer;
  begin
    ReverseColor:=rgb(255-getrvalue(thecolor),255-getgvalue(thecolor),255-getbvalue(thecolor));
  end;

constructor TModernGauge.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle:=ControlStyle + [csOpaque, csCaptureMouse, csClickEvents, csDoubleClicks];
  DoubleBuffered:=true;
  Width:=100;
  Height:=100;
  FMin:=0;
  FMax:=100;
  FPos:=25;
  FColor:=rgb(160,192,240);
  FShadow:=rgb(64,96,144);
  Canvas.Font.Name:='Arial';
  Canvas.Font.Size:=9;
  Canvas.Font.Color:=ReverseColor(FColor);
  Canvas.Font.Style:=[fsBold];
end;

procedure TModernGauge.Paint;
var s : string ;
begin
  with Canvas do begin
    CopyMode:=cmSrcCopy;
//arrière plan
    Brush.Style:=bsSolid;
    Brush.Color:=clBlack;
    Brush.Style:=bsSolid;
    Brush.Color:=clBlack;
    Rectangle(0,0,Width,Height);
//progression
    Pen.Color:=FShadow;
    Brush.Color:=FColor;
    Rectangle(2,2,(Width-2) * GetPercentDone div 100,Height-2);
//rebord blanc
    Pen.Color:=clWhite;
    if (Width-2) * GetPercentDone div 100 >=2 then
      begin
        MoveTo(2,2);
          LineTo((Width-2) * GetPercentDone div 100,2);
        MoveTo(2,2);
          LineTo(2,Height-2);
      end;
//contour relief blanc
    MoveTo(0,Height-1);
      LineTo(Width,Height-1);
    MoveTo(Width-1,0);
      LineTo(Width-1,Height);
//gris foncé
    Pen.Color:=clGray;
    MoveTo(0,0);
      LineTo(Width-2,0);
    MoveTo(0,0);
      LineTo(0,Height-2);
//écrit le "__%"
    Brush.Style:=bsClear;
    Pen.Color:=FColor;
    s:=IntToStr(GetPercentDone)+'%';
    TextOut(  (Width div 2)-(TextWidth(s) div 2),
              (Height div 2)-(TextHeight(s) div 2),
              s
           );
  end;
end;

function TModernGauge.GetPercentDone: integer;
begin
  Result:=SolveForY(FPos - FMin, FMax - FMin);
end;

procedure TModernGauge.IncrementProgress;
begin
  Position:=FPos+1;
end;

procedure TModernGauge.SetMin(Value : integer);
begin
  if Value<>FMin then
    begin
      if Value>FMax then
        Value:=FMax;
      FMin:=Value;
      if FPos<Value then
        FPos:=Value;
      Refresh;
    end;
end;

procedure TModernGauge.SetMax(Value : integer);
begin
  if Value<>FMax then
    begin
      if Value<FMin then
        Value:=FMin;
      FMax:=Value;
      if FPos>Value then
        FPos:=Value;
      Refresh;
    end;
end;

procedure TModernGauge.SetPosition(Value : integer);
var TempPercent: integer;
begin
  TempPercent:=GetPercentDone;
  if Value<FMin then
    Value:=FMin
  else
    if Value>FMax then
      Value:=FMax;
  if FPos<>Value then
    begin
      FPos:=Value;
      if TempPercent<>GetPercentDone then
        Refresh;
    end;
end;

procedure TModernGauge.SetGlobalColor(Value : TColor);
begin
  if Value<>FColor then
    begin
      FColor:=Value;
      Canvas.Font.Color:=ReverseColor(Value);
      Refresh;
    end;
end;

procedure TModernGauge.SetShadowColor(Value : TColor);
begin
  if Value<>FShadow then
    begin
      FShadow:=Value;
      Refresh;
    end;
end;

procedure Register;
begin
  RegisterComponents('Supplément', [TModernGauge]);
end;
end.

Télécharger le zip

03 juillet 2005 20:17:29 :

- Epuration du Zip

18 décembre 2005 18:52:03 :

- Mise à jour des mots clé