Suche kompo: seti@home progress bar

[Meflin]

ok, das ist fast genau das was ich wollte (fehlt noch das von hinten nach vorne sich die einzelnen striche aufbauen und die jeweils von oben nach unten) aber ich denke das sollte mir genügen. folgenden code kann man als vcl komponente installieren:

Delphi-Quellcode:

unit uStatus3DBalken;

interface

uses
  windows, graphics, classes, controls;

type
  TStatus3DBalken = class(TCustomControl)
  private
    fMaxPos: Integer;
    fPos: Integer;
    fLineColor: TColor;
    fBalkenColor1: TColor;
    fBalkenColor2: TColor;
    fBalkenColor3: TColor;
    fTmpPic: TBitmap;
    procedure FDrawBalken;
    procedure FSetColors(AIndex: Integer; AValue: TColor);
    procedure FSetMax(AValue: Integer);
    procedure FSetPos(AValue: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    property BalkenColor1: TColor Index 0 read fBalkenColor1 write FSetColors;
    property BalkenColor2: TColor Index 1 read fBalkenColor2 write FSetColors;
    property BalkenColor3: TColor Index 2 read fBalkenColor3 write FSetColors;
    property LineColor: TColor Index 3 read fLineColor write FSetColors;
    property Color;
    property Doublebuffered;
    property Max: Integer read fMaxPos write FSetMax;
    property Position: Integer read fPos write FSetPos;
    property ParentColor;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Beispiele', [TStatus3DBalken]);
end;

constructor TStatus3DBalken.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fMaxPos := 100;
  fPos    := 25;
  Color   := clBlack;
  fLineColor := clSilver;
  fBalkenColor1 := RGB(220, 0, 0);
  fBalkenColor2 := RGB(200, 0, 0);
  fBalkenColor3 := RGB(110, 0, 0);
  fTmpPic := TBitmap.Create;
  SetBounds(Left, Top, 300, 28);
end;

destructor TStatus3DBalken.Destroy;
begin
  fTmpPic.Free;
  inherited Destroy;
end;

procedure TStatus3DBalken.FDrawBalken;
var LCanvas: TCanvas;
    LGesHeight, LGesWidth, LBWidth, LBHeight, LAbstand, LBalkenWidth, LX, LY: Integer;
    LMax, LPos: Integer;
begin
  fTmpPic.Width := Width;
  fTmpPic.Height := Height;
  LCanvas := fTmpPic.Canvas;
  //Hintergrund malen
  LCanvas.Brush.Color := Color;
  LCanvas.FillRect(Rect(0, 0, Width, Height));
  if (Width > 2) and (Height > 2) then
  begin
    LX := 0;
    LY := 0;
    LGesHeight := Height - 1;
    LGesWidth := Width;
    LAbstand := LGesHeight div 3;
    LBHeight := LAbstand * 2;
    LBWidth := LGesWidth - LAbstand - 1;
    LMax := fMaxPos;
    LPos := fPos;
    LBalkenWidth := Round(LPos * (LGesWidth - LAbstand) / LMax);


    //BackgroundLines zeichnen
    LCanvas.Pen.Color := fLineColor;
    LCanvas.MoveTo(LX + LAbstand, 0 + LY);
    LCanvas.LineTo(LX + LAbstand + LBWidth, 0 + LY);
    LCanvas.LineTo(LX + LAbstand + LBWidth, 0 + LBHeight + LY);
    LCanvas.LineTo(LX + LAbstand, 0 + LBHeight + LY);
    LCanvas.LineTo(LX + LAbstand, 0 + LY);

    LCanvas.MoveTo(LX + LAbstand, LBHeight + LY);
    LCanvas.LineTo(LX + LAbstand - (LBHeight div 2), LBHeight + (LBHeight div 2) + LY);
    LCanvas.LineTo(LX + LAbstand + LBWidth - (LBHeight div 2), LBHeight + (LBHeight div 2) + LY);
    LCanvas.LineTo(LX + LAbstand + LBWidth, LBHeight + LY);

    LCanvas.MoveTo(LX + LAbstand, 0 + LY);
    LCanvas.LineTo(LX + LAbstand - (LBHeight div 2), (LBHeight div 2) + LY);
    LCanvas.LineTo(LX + LAbstand - (LBHeight div 2), LBHeight + (LBHeight div 2) + LY);

    if LBalkenWidth > 1 then
    begin
      //Balken zeichnen
      LCanvas.Pen.Color := fBalkenColor1;
      LCanvas.Brush.Color := LCanvas.Pen.Color;
      LCanvas.FillRect(Rect(LX + 1, LAbstand + LY, LX + LBalkenWidth, LAbstand + LBHeight + LY));

      LCanvas.Pen.Color := fBalkenColor2;
      LCanvas.Brush.Color := LCanvas.Pen.Color;
      LCanvas.MoveTo(LX + LBalkenWidth, LAbstand - 1 + LY);
      LCanvas.LineTo(LX + LBalkenWidth + LAbstand - 2, 1 + LY);
      LCanvas.LineTo(LX + LBalkenWidth + LAbstand - 2, LBHeight + LY);
      LCanvas.LineTo(LX + LBalkenWidth, LBHeight + LAbstand - 2 + LY);
      LCanvas.LineTo(LX + LBalkenWidth, LAbstand - 1 + LY);
      LCanvas.FloodFill(LX + LBalkenWidth + 1, LAbstand + LY, LCanvas.Pen.Color, fsBorder);


      LCanvas.Pen.Color := fBalkenColor3;
      LCanvas.Brush.Color := LCanvas.Pen.Color;
      LCanvas.MoveTo(LX + LAbstand + 1, 1 + LY);
      LCanvas.LineTo(LX + LAbstand + LBalkenWidth - 3, 1 + LY);
      LCanvas.LineTo(LX + LBalkenWidth - 1, LAbstand - 1 + LY);
      LCanvas.LineTo(LX + 2, LAbstand - 1 + LY);
      LCanvas.LineTo(LX + LAbstand + 1, 0 + LY);
      if LBalkenwidth > 7 then LCanvas.FloodFill(LX + LAbstand + 1, 2 + LY, LCanvas.Pen.Color, fsBorder);
    end;
  end;
  BitBlt(Canvas.Handle, 0, 0, width, height, LCanvas.Handle, 0, 0, SRCCOPY);
end;

procedure TStatus3DBalken.FSetColors(AIndex: Integer; AValue: TColor);
begin
  if (AIndex = 0) and (AValue <> fBalkenColor1) then
  begin
    fBalkenColor1 := AValue;
    FDrawBalken;
  end else if (AIndex = 1) and (AValue <> fBalkenColor2) then
  begin
    fBalkenColor2 := AValue;
    FDrawBalken;
  end else if (AIndex = 2) and (AValue <> fBalkenColor3) then
  begin
    fBalkenColor3 := AValue;
    FDrawBalken;
  end else if (AIndex = 3) and (AValue <> fLineColor) then
  begin
    fLineColor := AValue;
    FDrawBalken;
  end;
end;

procedure TStatus3DBalken.Paint;
begin
  FDrawBalken;
end;

procedure TStatus3DBalken.FSetMax(AValue: Integer);
begin
  if AValue < 0 then AValue := 0;
  if AValue <> fMaxPos then
  begin
    fMaxPos := AValue;
    if not(fPos < fMaxPos) then Position := fMaxPos;
    FDrawBalken;
  end;
end;

procedure TStatus3DBalken.FSetPos(AValue: Integer);
begin
  if AValue < 0 then AValue := 0 else
  if AValue > fMaxPos then AValue := fMaxPos;
  if (AValue <= fMaxPos) and (AValue <> fPos) then
  begin
    fPos := AValue;
    FDrawBalken;
  end;
end;


end.

ich lasse hier extra offen, sollte noch jemand die exakte kompo finden...