// Transparente
Fortschritts-Anzeige-Komponente, welche über ein "TImage"
// gelegt werden kann. Allerdings muss in der Form
procedure
TForm1.FormCreate(Sender: TObject);
begin
doublebuffered
:= true;
end;
//
eingerichtet sein, damit es nicht flackert.
// Wenn "Transparent" auf "False" steht, bestimmt die Eigenschaft
"Color"
// die Hintergrundfarbe der Komponente.
Beispiel für 3 bewegte Gauges (siehe Bild):
procedure TForm1.FormCreate(Sender: TObject);
begin
doublebuffered := true;
TransGauge1.Tag := 1;
TransGauge1.Progress := 100;
TransGauge2.Progress := 50;
TransGauge3.Progress := 75;
Timer1.Interval := 80;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
procedure doit(tg: TTransGauge);
begin
if tg.tag = 0 then begin
tg.progress := tg.progress - 5;
if tg.progress = 50 then tg.tag := 1;
end else begin
tg.progress := tg.progress + 5;
if tg.progress = 100 then tg.tag := 0;
end;
end;
begin
doit(TransGauge1);
doit(TransGauge2);
doit(TransGauge3);
end;
//--------------------------------------------------------------------
// Getestet mit D4 unter XP
unit TransGauge;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls;
type
TFontKind = (tgHorizontal, tgVertical);
TGaugeKind = (tgHorizontalBar, tgVerticalBar, tgPie);
TGaugeText = (tgCaption, tgProgress, tgPercent, tgNone);
TIntens = 0..5;
TTransGauge = class(TControl)
private
FR, FG, FB, FFF, FRD, FGD, FBD, FXR, FXG, FXB, FTR, FTG, FTB: Byte;
FStelle, FBer, FMin, FMax, FPos, FLang: integer;
FFore, FFrameCl, F2Cl, FDisCl, FDisF: TColor;
FFrame, Ftrans, FFlat, FShadow: boolean;
FNotify: TNotifyEvent;
FBmp, FHlp: TBitmap;
FDrctn: TFontKind;
FKind: TGaugeKind;
FText: TGaugeText;
FCanvas: TCanvas;
FProz: single;
FF: TIntens;
protected
procedure CMFontChanged(var aMsg: TMessage); message CM_FONTCHANGED;
procedure CMCOLOR(var M: TMessage); message CM_COLORCHANGED;
procedure WMPaint(var aMsg: TWMPaint); message WM_PAINT;
procedure setpix(i, d: integer; var p1, p2, p3: byte);
procedure setEnabled(Value: Boolean); override;
function setbyte(b, m, d: integer): byte;
procedure setText(t: TGaugeText);
procedure setDrctn(d: TFontKind);
procedure setKind(k: TGaugeKind);
procedure setFrameCl(c: TColor);
procedure setShadow(b: boolean);
procedure setFrame(b: boolean);
procedure setTrans(b: boolean);
procedure setFlat(b: boolean);
procedure setDisCl(c: TColor);
procedure setPos(i: integer);
procedure setMin(i: integer);
procedure setMax(i: integer);
procedure setFore(c: TColor);
procedure setF2Cl(c: TColor);
procedure setDisF(c: TColor);
procedure setFF(t: TIntens);
procedure settranscol;
procedure FontSwitch;
procedure setBitmap;
procedure setBereich;
procedure makefont;
procedure setrgb;
procedure sichtw;
procedure sichts;
procedure sichtk;
public
procedure WMText(var M: TMessage); message WM_SetText;
constructor Create(AOwner: TComponent); override;
property Canvas: TCanvas read FCanvas;
destructor Destroy; override;
procedure Resize; override;
procedure Loaded; override;
published
property ProgressDisabledColor: TColor read FDisCl write setDisCl;
property OnProgress: TNotifyEvent read FNotify write FNotify;
property FontDirection: TFontKind read FDrctn write setDrctn;
property FrameColor: TColor read FFrameCl write setFrameCl;
property FontShadow: boolean read FShadow write setShadow;
property FontShadowColor: TColor read F2Cl write setF2Cl;
property FontDisabledColor: TColor read FDisF write setDisF;
property Transparent: boolean read FTrans write setTrans;
property ProgressColor: TColor read FFore write setFore;
property TextMode: TGaugeText read FText write setText;
property Frame: boolean read FFrame write setframe;
property Kind: TGaugeKind read FKind write setKind;
property Progress: integer read FPos write setPos;
property Intensity: TIntens read FF write setFF;
property FLat: boolean read FFlat write setFlat;
property Min: integer read FMin write setMin;
property Max: integer read FMax write setMax;
property ParentShowHint;
property ParentColor;
property OnMouseDown;
property ParentFont;
property OnMouseUp;
property ShowHint;
property Enabled;
property Visible;
property Caption;
property Color;
property Font;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('DBR', [TTransGauge]);
end;
constructor TTransGauge.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TCanvas.Create;
FKind := tgHorizontalBar;
FDrctn := tgHorizontal;
FFrame := true;
FTrans := true;
FF := 4;
FFF := 1;
FG := 255;
FR := 0;
FB := FR;
FFore := RGB(FR, FG, FB);
FGD := 180;
FRD := FGD;
FBD := FGD;
FDisCl := RGB(FRD, FGD, FBD);
FMax := 100;
width := 100;
height := 100;
FFrameCl := $4000;
FBmp := TBitmap.create;
Fbmp.pixelformat := pf24bit;
FHlp := TBitmap.create;
FHlp.pixelformat := pf24bit;
Font.Color := clBlack;
Font.Name := 'Arial';
Font.Size := 8;
F2Cl := clwhite;
FDisF := F2Cl;
setBitmap;
setrgb;
settranscol;
FBmp.transparent := true;
end;
destructor TTransGauge.Destroy;
begin
FHlp.free;
FBmp.free;
FCanvas.Free;
inherited Destroy;
end;
procedure TTransGauge.WMPaint(var aMsg: TWMPaint);
var
s: string;
sz: TSize;
rct: TRect;
w, h: integer;
procedure horzText(f: TColor);
begin
with FBmp.Canvas do begin
if enabled then Font.Color := f
else Font.Color := FDisF;
drawtext(FBmp.Canvas.handle, pchar(s), -1, rct, dt_singleline
or dt_center or dt_vcenter);
end;
end;
procedure vertText(f: TColor; x, y: integer);
begin
with FBmp.Canvas do begin
if enabled then Font.Color := f
else Font.Color := FDisF;
textrect(rct, x, y, s);
end;
end;
begin
FCanvas.Handle := aMsg.DC;
rct := rect(3, 2, width - 2, height - 2);
FProz := FStelle * 100 / FBer;
with FBmp, Canvas do begin
copyrect(FBmp.Canvas.cliprect, FCanvas, FCanvas.cliprect);
case FText of
tgPercent: s := FormatFloat('0.0', FProz) + '%';
tgProgress: s := FormatFloat('#,#0', FPos);
tgCaption: s := caption;
else s := '';
end;
if Ftrans then
brush.style := bsClear
else brush.color := color;
if FFrame then Pen.color := FFrameCl
else Pen.color := Transparentcolor;
if FKind = tgPie then begin
pen.style := psclear;
Ellipse(0, 0, width, height);
end else
RoundRect(0, 0, width, height, 6, 6);
if FKind = tgHorizontalBar then sichtw
else if FKind = tgPie then sichtk
else sichts;
brush.style := bsClear;
if s <> '' then begin
makefont;
sz := TextExtent(s);
if FDrctn = tgVertical then begin
w := (width - sz.cy) div 2;
h := height - (height - sz.cx) div 2;
if FShadow and enabled then vertText(F2Cl, w + 1, h - 1);
vertText(self.Font.color, w, h);
end else begin
if FShadow and enabled then horzText(F2Cl);
offsetrect(rct, -1, -1);
horzText(self.Font.color);
end;
end;
end;
FCanvas.draw(0, 0, FBmp);
end;
procedure TTransGauge.setrgb;
begin
if enabled then begin
FXR := FR;
FXG := FG;
FXB := FB;
end else begin
FXR := FRD;
FXG := FGD;
FXB := FBD;
end;
end;
function TTransGauge.setbyte(b, m, d: integer): byte;
begin
result := (b div succ(FFF));
if not FFLat then
result := result * m div d;
end;
procedure TTransGauge.setpix(i, d: integer; var p1, p2, p3: byte);
var px1, px2, px3: byte;
begin
if Ftrans then begin
px1 := p1;
px2 := p2;
px3 := p3;
end else begin
px1 := $99;
px2 := px1;
px3 := px1;
end;
p1 := setbyte(FXB + px1 * FFF, i, d);
p2 := setbyte(FXG + px2 * FFF, i, d);
p3 := setbyte(FXR + px3 * FFF, i, d);
end;
procedure TTransGauge.sichts;
var x, y, by, bx, k, fy, bm, h: integer;
pm: PBytearray;
begin
bx := pred(width) * 3;
by := (bx div 6) * 3; // Farbsicherheit. Nicht "bx div 2" !
fy := height - FLang - 1;
h := height - 2;
for y := fy to h do begin
pm := FBmp.scanline[y];
k := ord((y = fy) or (y = h)) * 3;
x := 3 + k;
bm := bx - k;
while x <= by do begin
setpix(x, by, pm[x], pm[x + 1], pm[x + 2]);
inc(x, 3);
end;
x := by + 3;
while x < bm do begin
setpix(bx - x, by, pm[x], pm[x + 1], pm[x + 2]);
inc(x, 3);
end;
end;
end;
procedure TTransGauge.sichtw;
var x, y, b3, hy, hx, k, bm: integer;
pm: PBytearray;
procedure setk(b: boolean);
begin
k := ord(b) * 3;
bm := b3 - k;
x := 3 + k;
end;
begin
b3 := FLang * 3;
hx := FBmp.height - 2;
hy := hx div 2;
for y := 1 to hy do begin
setk(y = 1);
pm := FBmp.scanline[y];
while x <= bm do begin
setpix(y, hy, pm[x], pm[x + 1], pm[x + 2]);
inc(x, 3);
end;
end;
for y := hy + 1 to hx do begin
setk(y = hx);
pm := FBmp.scanline[y];
while x <= bm do begin
setpix(hx - y, hy, pm[x], pm[x + 1], pm[x + 2]);
inc(x, 3);
end;
end;
end;
procedure TTransGauge.sichtk;
var x, y, w, h, stp, b3, f, d: integer;
winkel: single;
pm, ph: PBytearray;
p1, p2, p3, pf1, pf2, pf3: byte;
procedure DrawRadial;
var
i: Integer;
Rx, Gx, Bx: byte;
begin
with FHlp, Canvas do begin
for i := 0 to stp do begin
Rx := Round((FXR / stp) * i);
Gx := Round((FXG / stp) * i);
Bx := Round((FXB / stp) * i);
Brush.Color := RGB(Rx, Gx, Bx);
Pen.Color := Brush.Color;
Ellipse(i, i, width - i, height - i);
end;
end;
end;
begin
w := width div 2;
h := height div 2;
b3 := width * 3;
if h > w then stp := w else stp := h;
case ff of
0: f := 50;
1: f := 110;
2: f := 150;
3: f := 175;
4: f := 200
else f := 255;
end;
d := 256 - f;
with FHlp.canvas do begin
brush.color := FBmp.transparentcolor;
fillrect(cliprect);
winkel := (FProz / 50) * pi;
x := round(W * sin(winkel) + W);
y := round(-H * cos(winkel) + H);
drawradial;
pen.color := FBmp.transparentcolor;
brush.color := FBmp.transparentcolor;
if FProz = 0 then
ellipse(0, 0, width, height) else
if FProz < 100 then
pie(0, 0, width, height, W, 0, x, y);
brush.style := bsclear;
ellipse(0, 0, width, height);
end;
for y := 0 to height - 1 do begin
x := 0;
pm := FBMp.ScanLine[y];
ph := FHlp.ScanLine[y];
while x < b3 do begin
if (ph[x] <> FTB) or (ph[x + 1] <> FTG) or (ph[x + 2] <> FTR)
then begin
if FTrans then begin
p1 := pm[x];
p2 := pm[x + 1];
p3 := pm[x + 2];
end else begin
p1 := $50;
p2 := p1;
p3 := p1;
end;
if not FFLat then begin
pf1 := ph[x];
pf2 := ph[x + 1];
pf3 := ph[x + 2];
end else begin
pf1 := FXB;
pf2 := FXG;
pf3 := FXR;
end;
pm[x] := ((pf1 * f) + p1 * d) shr 8;
pm[x + 1] := ((pf2 * f) + p2 * d) shr 8;
pm[x + 2] := ((pf3 * f) + p3 * d) shr 8;
end;
inc(x, 3);
end;
end;
FBmp.Canvas.brush.style := bsClear;
if FFrame then begin
FBmp.canvas.pen.color := FFrameCl;
FBmp.canvas.pen.style := psSolid;
FBmp.canvas.ellipse(0, 0, width, height);
end;
end;
procedure TTransGauge.setBitmap;
begin
FBmp.width := width;
FBmp.height := height;
FHlp.width := width;
FHlp.height := height;
end;
procedure TTransGauge.setTrans(b: boolean);
begin
if b = FTrans then exit;
FTrans := b;
invalidate;
end;
procedure TTransGauge.setFrame(b: boolean);
begin
if b = FFrame then exit;
FFrame := b;
invalidate;
end;
procedure TTransGauge.setFlat(b: boolean);
begin
if b = FFlat then exit;
FFlat := b;
invalidate;
end;
procedure TTransGauge.setShadow(b: boolean);
begin
if b = FShadow then exit;
FShadow := b;
invalidate;
end;
procedure TTransGauge.setKind(k: TGaugeKind);
begin
if k = FKind then exit;
FKind := k;
FontSwitch;
resize;
end;
procedure TTransGauge.setFore(c: TColor);
begin
c := ColorToRGB(c);
if c = FFore then exit;
FFore := c;
FR := GetRValue(c);
FG := GetGValue(c);
FB := GetBValue(c);
setrgb;
invalidate;
end;
procedure TTransGauge.setDisCl(c: TColor);
begin
c := ColorToRGB(c);
if c = FDisCl then exit;
FDisCl := c;
FRD := GetRValue(c);
FGD := GetGValue(c);
FBD := GetBValue(c);
setrgb;
if not enabled then invalidate;
end;
procedure TTransGauge.setFrameCl(c: TColor);
begin
c := ColorToRGB(c);
if c = FFrameCl then exit;
FFrameCl := c;
invalidate;
end;
procedure TTransGauge.setDisF(c: TColor);
begin
c := ColorToRGB(c);
if c = FDisF then exit;
FDisF := c;
if not enabled then invalidate;
end;
procedure TTransGauge.setF2Cl(c: TColor);
begin
c := ColorToRGB(c);
if c = F2Cl then exit;
F2Cl := c;
invalidate;
end;
procedure TTransGauge.Loaded;
begin
inherited;
Resize;
end;
procedure TTransGauge.Resize;
begin
inherited;
if width > 1000 then width := 1000
else if width < 10 then width := 10;
if height > 1000 then height := 1000
else if height < 10 then height := 10;
if assigned(FBmp) then setBitmap;
setbereich;
end;
procedure TTransGauge.setBereich;
var i: integer;
begin
FBer := FMax - FMin;
FStelle := Fpos - FMin;
if FKind = tgHorizontalBar then i := width - 2
else i := height - 2;
FLang := round(FStelle * i / FBer);
repaint;
end;
procedure TTransGauge.setMax(i: integer);
begin
if i > 1000000 then i := 1000000;
if (FMax = i) or (i <= FMin) then exit;
FMax := i;
if Fpos > i then FPos := i;
setBereich;
end;
procedure TTransGauge.setMin(i: integer);
begin
if i < -1000000 then i := -1000000;
if (FMin = i) or (i >= FMax) then exit;
FMin := i;
if FPos < i then FPos := i;
setbereich;
end;
procedure TTransGauge.setPos(i: Integer);
begin
if i < FMin then i := FMin;
if i > FMax then i := FMax;
if (FPos = i) or not enabled then exit;
FPos := i;
setBereich;
if assigned(FNotify) then FNotify(self);
end;
procedure TTransGauge.WMText(var M: TMessage);
begin
DefaultHandler(M);
invalidate;
end;
procedure TTransGauge.setText(t: TGaugeText);
begin
if FText = t then exit;
FText := t;
invalidate;
end;
procedure TTransGauge.makefont;
var
LogFont: TLogfont;
begin
GetObject(FBmp.Canvas.Font.Handle, sizeof(Logfont), @Logfont);
Logfont.lfEscapement := ord(FDrctn = tgVertical) * 900;
FBmp.Canvas.Font.Handle := CreateFontIndirect(Logfont);
end;
procedure TTransGauge.setFF(t: TIntens);
var i: integer;
begin
if t > 5 then t := 5
else if t < 0 then t := 0;
if t = FF then exit;
FF := t;
i := ord(not FFlat);
case FF of
0: FFF := 1 + i * 15;
1: FFF := 7 - i;
else FFF := 6 - FF - i;
end;
invalidate;
end;
procedure TTransGauge.setDrctn(d: TFontKind);
begin
if d = FDrctn then exit;
FDrctn := d;
FontSwitch;
invalidate;
end;
procedure TTransGauge.CMFontChanged(var aMsg: TMessage);
begin
FBmp.Canvas.Font := Font;
FontSwitch;
invalidate;
end;
procedure TTransGauge.FontSwitch;
var tm: TTextMetric;
begin
if FDrctn = tgHorizontal then exit;
GetTextMetrics(FBmp.Canvas.Handle, tm);
if (tm.tmPitchAndFamily and TMPF_TRUETYPE = 0)
then begin
Font.Name := 'Arial';
Font.Charset := DEFAULT_CHARSET;
FBmp.Canvas.Font := Font;
end;
end;
procedure TTransGauge.setEnabled(Value: Boolean);
begin
inherited;
setrgb;
end;
procedure TTransGauge.settranscol;
var c: TColor;
begin
c := ColorToRGB(color);
if odd(c) then c := c - 1
else c := c + 1;
FBmp.Transparentcolor := c;
FTR := GetRValue(c);
FTG := GetGValue(c);
FTB := GetBValue(c);
end;
procedure TTransGauge.CMCOLOR(var M: TMessage);
begin
inherited;
settranscol;
end;
end.

|