procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
end;

procedure TForm1.QUADER14Change(Sender: TObject); 
begin 
  TrackBar1.Position := TQUADER(Sender).Position; 
end;

procedure BeiStartUndLauf(Sender: TQUADER); 
begin 
  Form1.TrackBar1.Position := Sender.Position; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
end;

procedure TForm1.FormActivate(Sender: TObject); 
begin 
  BeiStartUndLauf(QUADER14); 
end; 
 
procedure TForm1.QUADER14Change(Sender: TObject); 
begin 
  if visible then 
    BeiStartUndLauf(TQUADER(Sender)); 
end; 

//------------------------------------------------------

uses Jpeg; 
 
var 
  br: integer; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  Timer1.Interval := 0; 
end; 
 
// Bild laden und starten 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  b: TBitmap; 
  j: TJpegImage; 
begin 
  b := TBitmap.Create; 
  j := TJpegImage.Create; 
  j.LoadFromFile('D:\Bilder\Test.jpg'); 
  b.Assign(j); 
  j.Free; 
  br := b.Width div 2; 
  QUADER14.Width := br; 
  QUADER14.Picture := b; 
  b.Free; 
  Timer1.Interval := 50; 
end; 

// stoppen und Bild löschen
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Timer1.Interval := 0; 
  QUADER14.Picture := nil; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  with QUADER14 do 
  begin 
    PictOffsetHorz := PictOffsetHorz - 2; 
    if PictOffsetHorz <= -br then 
      PictOffsetHorz := 0; 
  end; 
end;

unit QUADER; 
 
interface 
 
uses 
  Windows, 
  Classes, 
  SysUtils, 
  Graphics, 
  Controls, 
  StdCtrls; 
 
type 
  TQUADER = class(TCustomLabel) 
  private 
    Fx, Fwmx, Fhmy, FLang, FStelle, Foffsh, Foffsv, Fmerk, Fdiff: Integer; 
    FHorz, Fcov, Ftrans, Fhd, Fpfo, Fpfix, Fauto, Fb2, Fflip: boolean; 
    Fc, Fclr, Fr, Fft, Ffr, Fr2, Ffl: TColor; 
    Fpt1, Fpt2: array [0 .. 4] of TPoint; 
    FBild, Fbm, Fhlp: TBitmap; 
    Fmin, Fmax, FPos: int64; 
    FEvent: TNotifyEvent; 
    Fd: Word; 
  protected 
    function korrc(c: TColor): TColor; 
    procedure korrdepth(var w: Word); 
    procedure setoffsh(i: Integer); 
    procedure setoffsv(i: Integer); 
    procedure setbild(gr: TBitmap); 
    procedure settrans(b: boolean); 
    procedure setLine2(c: TColor); 
    procedure setHorz(b: boolean); 
    procedure setauto(b: boolean); 
    procedure setflip(b: boolean); 
    procedure setpfix(b: boolean); 
    procedure setCov(b: boolean); 
    procedure HVpoly(i: Integer); 
    procedure setLine(c: TColor); 
    procedure setBack(c: TColor); 
    procedure setBart(c: TColor); 
    procedure setBarl(c: TColor); 
    procedure setBarr(c: TColor); 
    procedure setpfo(b: boolean); 
    procedure setb2(b: boolean); 
    procedure sethd(b: boolean); 
    procedure b90(Uhr: boolean); 
    procedure setmin(i: int64); 
    procedure setmax(i: int64); 
    procedure setpos(i: int64); 
    procedure setfd(w: Word); 
    procedure setbereich; 
    procedure korrOffset; 
    procedure zeichnen; 
    procedure poskorr; 
    procedure rech; 
    procedure korr; 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
    procedure Resize; override; 
    procedure Paint; override; 
  published 
    property CoverTransparent: boolean read Ftrans write settrans; 
    property PictOffsetHorz: Integer read Foffsh write setoffsh; 
    property PictOffsetVert: Integer read Foffsv write setoffsv; 
    property OnChange: TNotifyEvent read FEvent write FEvent; 
    property Horizontal: boolean read FHorz write setHorz; 
    property BorderColor2: TColor read Fr2 write setLine2; 
    property PictFaceOnly: boolean read Fpfo write setpfo; 
    property HideAtMinimum: boolean read Fhd write sethd; 
    property PictFixed: boolean read Fpfix write setpfix; 
    property DepthAuto: boolean read Fauto write setauto; 
    property PictFlip: boolean read Fflip write setflip; 
    property BorderColor1: TColor read Fr write setLine; 
    property Picture: TBitmap read FBild write setbild; 
    property CoverColor: TColor read Fc write setBack; 
    property BarColor1: TColor read Fft write setBart; 
    property BarColor2: TColor read Ffl write setBarl; 
    property BarColor3: TColor read Ffr write setBarr; 
    property BorderBack: boolean read Fb2 write setb2; 
    property Cover: boolean read Fcov write setCov; 
    property Position: int64 read FPos write setpos; 
    property Min: int64 read Fmin write setmin; 
    property Max: int64 read Fmax write setmax; 
    property Depth: Word read Fd write setfd; 
    property ParentShowHint; 
    property OnMouseMove; 
    property OnMousedown; 
    property OnDblClick; 
    property OnMouseUp; 
    property ShowHint; 
    Property Visible; 
    property Enabled; 
    property OnClick; 
    property Hint; 
  end; 
 
procedure Register; 
 
implementation 
 
const 
  mn = 8; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TQUADER]); 
end; 
 
constructor TQUADER.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  autosize := false; 
  Ftrans := false; 
  FHorz := false; 
  Fpfix := true; 
  Fauto := true; 
  Fcov := true; 
  Fhd := true; 
  Fb2 := true; 
  color := 1; 
  Fclr := color; 
  Fmerk := maxint; 
  Transparent := true; 
  Fbm := TBitmap.Create;
  FBild := TBitmap.Create; 
  Fbm.Transparent := true; 
  Fbm.PixelFormat := pf24bit; 
  Fbm.TransparentColor := Fclr; 
  Fd := 10; 
  Fmax := 100; 
  width := 27; 
  height := 132; 
  Fc := $E0E0E0; 
  Fr := $707070; 
  Fr2 := $C5C5C5; 
  Fft := $FF0000; 
  Ffl := $B80000; 
  Ffr := $800000; 
end; 
 
destructor TQUADER.Destroy; 
begin 
  FBild.Free; 
  Fbm.Free; 
  inherited Destroy; 
end; 
 
Procedure TQUADER.rech; 
begin 
  if Fauto then 
  begin 
    Fd := round(sqrt(height * width) / 6); 
    korrdepth(Fd); 
  end; 
  if FHorz then 
    Fx := width - Fd 
  else 
    Fx := Fd; 
  Fwmx := pred(width - Fx); 
  Fhmy := pred(height - Fd); 
end; 
 
function TQUADER.korrc(c: TColor): TColor; 
begin 
  if odd(c) then 
    result := pred(c) 
  else 
    result := succ(c); 
end; 
 
procedure TQUADER.korr; 
begin 
  if Fr = Fclr then 
    Fr := korrc(Fr); 
  if Fr = Fc then 
  begin 
    if Fr and $100 = $100 then 
      Fr := Fr - $100 
    else 
      Fr := Fr + $100 
  end; 
end; 
 
Procedure TQUADER.zeichnen; 
var 
  x, w: Integer; 
  procedure hg; 
  begin 
    with Fbm.Canvas do 
      if Ftrans then 
        brush.color := Fclr 
      else 
        brush.color := Fc; 
  end; 
 
begin 
  korr; 
  Fbm.width := width; 
  Fbm.height := height; 
  with Fbm.Canvas do 
  begin 
    brush.color := Fclr; 
    fillrect(cliprect); 
    if FHorz then 
    begin 
      if (not Fhd) or (FPos > Fmin) then 
      begin 
        Pen.color := Ffr; 
        brush.color := Ffr; 
        polygon(Fpt1); 
        Pen.color := Fft; 
        brush.color := Fft; 
        polygon(Fpt2); 
        Pen.color := Ffl; 
        brush.color := Ffl; 
        rectangle(0, Fd, FLang + 1, height); 
        if not FBild.empty then 
        begin 
          if FBild.width + Foffsh > FLang then 
            w := FLang - Foffsh + 1 
          else 
            w := FBild.width; 
          if not Fpfo then 
            for x := Foffsv to Fd - 1 do 
              copyrect(rect(Fd - x, x, w + Foffsh + Fd - x, x + 1), 
                FBild.Canvas, rect(-Foffsh, x - Foffsv, w, 
                  x + 1 - Foffsv)); 
          copyrect(rect(Foffsh, Fd, Foffsh + w, FBild.height + Foffsv), 
            FBild.Canvas, rect(0, Fd - Foffsv, w, FBild.height)); 
        end; 
      end 
      else if Fcov and Fb2 then 
      begin 
        hg; 
        Pen.color := Fr2; 
        polygon(Fpt1); 
      end; 
      if Fcov then 
      begin 
        Pen.color := Fr; 
        brush.Style := bsclear; 
        rectangle(0, Fd, Fx, height); 
        hg; 
        moveto(0, Fd); 
        lineto(Fd, 0); 
        lineto(width - 1, 0); 
        lineto(width - 1, Fhmy); 
        lineto(Fx - 1, height - 1); 
        if FLang < Fx - 2 then 
        begin 
          Floodfill(width - 2, 2, pixels[width - 2, 2], fsSurface); 
          Pen.color := brush.color; 
          moveto(Fx, height - 3); 
          lineto(width - 2, Fhmy); 
        end; 
        if FLang < Fx - 3 then 
          Floodfill(Fx - 2, height - 2, pixels[Fx - 2, height - 2], fsSurface); 
        Pen.color := Fr; 
        moveto(Fx - 1, Fd); 
        lineto(width - 1, 0); 
        if Fb2 then 
        begin 
          Pen.color := Fr2; 
          moveto(Fpt1[2].x + 1, Fpt1[2].y); 
          if FLang + Fwmx < Fx - 1 then 
          begin 
            lineto(Fx - 1, Fpt1[2].y); 
            moveto(Fx, Fpt1[2].y); 
          end; 
          lineto(width - 1, Fpt1[2].y); 
        end; 
      end; 
    end 
    else 
    begin 
      if (not Fhd) or (FPos > Fmin) then 
      begin 
        Pen.color := Fft; 
        brush.color := Fft; 
        polygon(Fpt1); 
        Pen.color := Ffl; 
        brush.color := Ffl; 
        polygon(Fpt2); 
        Pen.color := Ffr; 
        brush.color := Ffr; 
        rectangle(Fx, height - FLang - 1, width, height); 
        if not FBild.empty then 
        begin 
          if FBild.height > FLang + Foffsv then 
            w := FLang + 1 
          else 
            w := FBild.height - Foffsv; 
          if not Fpfo then 
            for x := 0 to Fd - 1 do 
            begin 
              copyrect(rect(x, height - w - Fd + x, x + 1, height - Fd + x), 
                FBild.Canvas, rect(x - Foffsh, FBild.height - w - Foffsv, 
                  x + 1 - Foffsh, FBild.height - Foffsv)); 
            end; 
          copyrect(rect(Fd, height - FLang - 1, FBild.width + Foffsh, 
              height + Foffsv), FBild.Canvas, 
            rect(Fd - Foffsh, FBild.height - FLang - Foffsv - 1, FBild.width, 
              FBild.height)); 
        end; 
      end 
      else if Fcov and Fb2 then 
      begin 
        hg; 
        Pen.color := Fr2; 
        polygon(Fpt1); 
      end; 
      if Fcov then 
      begin 
        Pen.color := Fr; 
        brush.Style := bsclear; 
        rectangle(Fx, Fd, width, height); 
        hg; 
        moveto(Fx + 1, height); 
        lineto(0, Fhmy); 
        lineto(0, 0); 
        lineto(Fwmx, 0); 
        lineto(width - 1, Fd); 
        if FLang < Fhmy - 1 then 
        begin 
          Floodfill(1, 1, pixels[1, 1], fsSurface); 
          Pen.color := brush.color; 
          moveto(Fwmx, 1); 
          lineto(width - 2, Fd); 
        end; 
        if FLang < Fhmy - 2 then 
          Floodfill(width - 2, Fd + 1, pixels[width - 2, Fd + 1], fsSurface); 
        Pen.color := Fr; 
        moveto(0, 0); 
        lineto(Fx, Fd); 
        if Fb2 then 
        begin 
          Pen.color := Fr2; 
          moveto(Fpt1[2].x, Fpt1[2].y - 1); 
          if FLang + Fd < Fhmy then 
          begin 
            lineto(Fpt1[2].x, Fd); 
            moveto(Fpt1[2].x, Fd - 1); 
          end; 
          lineto(Fpt1[2].x, 0); 
        end; 
      end; 
    end; 
  end; 
  Canvas.draw(0, 0, Fbm); 
end; 
 
Procedure TQUADER.Paint; 
begin 
  setbereich; 
  zeichnen; 
end; 
 
Procedure TQUADER.setHorz(b: boolean); 
var 
  i: Integer; 
begin 
  if b <> FHorz then 
  begin 
    FHorz := b; 
    if not(csLoading in componentstate) then 
    begin 
      i := height; 
      height := width; 
      width := i; 
      if not FBild.empty then 
      begin 
        if Fflip then 
        begin 
          if b then 
          begin 
            i := Foffsv; 
            Foffsv := Foffsh; 
            Foffsh := -i; 
          end 
          else 
          begin 
            i := Foffsh; 
            Foffsh := Foffsv; 
            Foffsv := -i; 
          end; 
          b90(b); 
        end 
        else 
          poskorr; 
      end; 
      repaint; 
      if assigned(FEvent) then 
        FEvent(self); 
    end 
    else 
      invalidate; 
  end; 
end; 
 
Procedure TQUADER.setLine(c: TColor); 
begin 
  c := ColorToRgb(c); 
  if c <> Fr then 
  begin 
    Fr := c; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.setLine2(c: TColor); 
begin 
  c := ColorToRgb(c); 
  if c <> Fr2 then 
  begin 
    Fr2 := c; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.setBack(c: TColor); 
begin 
  c := ColorToRgb(c); 
  if c <> Fc then 
  begin 
    if c = Fclr then 
      c := korrc(c); 
    Fc := c; 
    Ftrans := false; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.setBart(c: TColor); 
begin 
  c := ColorToRgb(c); 
  if c <> Fft then 
  begin 
    if c = Fclr then 
      c := korrc(c); 
    Fft := c; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.setBarl(c: TColor); 
begin 
  c := ColorToRgb(c); 
  if c <> Ffl then 
  begin 
    if c = Fclr then 
      c := korrc(c); 
    Ffl := c; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.setBarr(c: TColor); 
begin 
  c := ColorToRgb(c); 
  if c <> Ffr then 
  begin 
    if c = Fclr then 
      c := korrc(c); 
    Ffr := c; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.setCov(b: boolean); 
begin 
  if b <> Fcov then 
  begin 
    Fcov := b; 
    invalidate; 
  end; 
end; 
 
Procedure TQUADER.settrans(b: boolean); 
begin 
  if b <> Ftrans then 
  begin 
    Ftrans := b; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.sethd(b: boolean); 
begin 
  if b <> Fhd then 
  begin 
    Fhd := b; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setauto(b: boolean); 
begin 
  if b <> Fauto then 
  begin 
    Fauto := b; 
    rech; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setpfo(b: boolean); 
begin 
  if b <> Fpfo then 
  begin 
    Fpfo := b; 
    if not FBild.empty then 
    begin 
      if FHorz then 
      begin 
        if b then 
          Foffsv := Foffsv + Fd 
        else 
          Foffsv := Foffsv - Fd; 
      end 
      else 
      begin 
        if b then 
          Foffsh := Foffsh + Fd 
        else 
          Foffsh := Foffsh - Fd; 
      end; 
    end; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setpfix(b: boolean); 
begin 
  if b <> Fpfix then 
  begin 
    Fpfix := b; 
    Fmerk := maxint; 
    korrOffset; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setb2(b: boolean); 
begin 
  if b <> Fb2 then 
  begin 
    Fb2 := b; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setflip(b: boolean); 
begin 
  if b <> Fflip then 
  begin 
    Fflip := b; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setmax(i: int64); 
begin 
  if i <> Fmax then 
  begin 
    if i <= Fmin then 
      i := Fmin + 1; 
    if FPos > i then 
      FPos := i; 
    Fmax := i; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setmin(i: int64); 
begin 
  if i <> Fmin then 
  begin 
    if i >= Fmax then 
      i := Fmax - 1; 
    if FPos < i then 
      FPos := i; 
    Fmin := i; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.korrOffset; 
begin 
  if not Fpfix then 
  begin 
    if FHorz then 
      Foffsh := Foffsh + Fdiff 
    else 
      Foffsv := Foffsv - Fdiff; 
    Fmerk := FLang; 
  end; 
end; 
 
procedure TQUADER.setpos(i: int64); 
begin 
  if i < Fmin then 
    i := Fmin; 
  if i > Fmax then 
    i := Fmax; 
  if not Enabled or (i = FPos) then 
    exit; 
  FPos := i; 
  setbereich; 
  korrOffset; 
  repaint; 
  if assigned(FEvent) then 
    FEvent(self); 
end; 
 
procedure TQUADER.setbereich; 
var 
  i: Integer; 
  Ber: int64; 
begin 
  rech; 
  Ber := Fmax - Fmin; 
  FStelle := FPos - Fmin; 
  if FHorz then 
    i := Fx - 2 
  else 
    i := height - Fd - 2; 
  FLang := round(FStelle * i / Ber); 
  if Fmerk < maxint then 
    Fdiff := FLang - Fmerk; 
  HVpoly(FLang); 
end; 
 
procedure TQUADER.HVpoly(i: Integer); 
var 
  hm1: Integer; 
begin 
  hm1 := pred(height); 
  if FHorz then 
  begin 
    Fpt1[0] := point(i, Fd); 
    Fpt1[1] := point(i + Fd, 0); 
    Fpt1[2] := point(i + Fd, Fhmy); 
    Fpt1[3] := point(i, hm1); 
    Fpt2[0] := point(i + Fd, 0); 
    Fpt2[1] := point(Fd, 0); 
    Fpt2[2] := point(0, Fd); 
    Fpt2[3] := point(i, Fd); 
  end 
  else 
  begin 
    Fpt1[0] := point(Fx, hm1 - i); 
    Fpt1[1] := point(0, Fhmy - i); 
    Fpt1[2] := point(Fwmx, Fhmy - i); 
    Fpt1[3] := point(width - 1, hm1 - i); 
    Fpt2[0] := point(0, Fhmy - i); 
    Fpt2[1] := point(0, Fhmy); 
    Fpt2[2] := point(Fx, hm1); 
    Fpt2[3] := point(Fx, hm1 - i); 
  end; 
  Fpt1[4] := Fpt1[0]; 
  Fpt2[4] := Fpt2[0]; 
end; 
 
procedure TQUADER.poskorr; 
begin 
  if FHorz then 
  begin 
    if Fpfix then 
      Foffsh := 0 
    else 
      Foffsh := succ(FLang - FBild.width); 
    Foffsv := ord(Fpfo) * Fd; 
  end 
  else 
  begin 
    if Fpfix then 
      Foffsv := 0 
    else 
      Foffsv := pred(FBild.height - FLang); 
    Foffsh := ord(Fpfo) * Fd; 
  end; 
  korrOffset; 
end; 
 
procedure TQUADER.setbild(gr: TBitmap); 
var 
  b1, b2: boolean; 
  x, y, w: Integer; 
  p: PByteArray; 
begin 
  b1 := FBild.empty; 
  b2 := (gr = nil) or gr.empty; 
  FBild.Assign(gr); 
  if not b2 then 
  begin 
    poskorr; 
    FBild.PixelFormat := pf24bit; 
    w := FBild.width * 3; 
    for y := 0 to FBild.height - 1 do 
    begin 
      p := FBild.ScanLine[y]; 
      x := 0; 
      while x < w do 
      begin 
        if (p[x] = 0) and (p[x + 1] = 0) then 
        begin 
          if p[x + 2] = 1 then 
            p[x + 2] := 0; 
        end; 
        inc(x, 3); 
      end; 
    end; 
  end; 
  repaint; 
  if (b1 <> b2) or not b2 then 
    if assigned(FEvent) then 
      FEvent(self); 
end; 
 
procedure TQUADER.b90(Uhr: boolean); 
var 
  a: array of array of array [0 .. 2] of byte; 
  x, y, h, w, w3: Word; 
  p: PByteArray; 
  i: byte; 
  procedure rechnen(b, c: Word); 
  var 
    j: byte; 
  begin 
    for j := 0 to 2 do 
      p[x + j] := a[b][c][j]; 
  end; 
 
begin 
  setlength(a, FBild.height); 
  h := pred(FBild.height); 
  for x := 0 to h do 
    setlength(a[x], FBild.width); 
  w3 := FBild.width * 3; 
  for y := 0 to h do 
  begin 
    p := FBild.ScanLine[y]; 
    x := 0; 
    while x < w3 do 
    begin 
      for i := 0 to 2 do 
        a[h - y][x div 3][i] := p[x + i]; 
      inc(x, 3); 
    end; 
  end; 
  x := FBild.height; 
  FBild.height := FBild.width; 
  FBild.width := x; 
  h := pred(FBild.height); 
  w3 := FBild.width * 3; 
  w := pred(FBild.width); 
  for y := 0 to h do 
  begin 
    p := FBild.ScanLine[y]; 
    x := 0; 
    while x < w3 do 
    begin 
      if Uhr then 
        rechnen(x div 3, y) 
      else 
        rechnen(w - x div 3, h - y); 
      inc(x, 3); 
    end; 
  end; 
  a := nil; 
end; 
 
procedure TQUADER.setoffsh(i: Integer); 
begin 
  if i <> Foffsh then 
  begin 
    Foffsh := i; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setoffsv(i: Integer); 
begin 
  if i <> Foffsv then 
  begin 
    Foffsv := i; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.setfd(w: Word); 
begin 
  korrdepth(w); 
  if w <> Fd then 
  begin 
    Fd := w; 
    Fauto := false; 
    invalidate; 
  end; 
end; 
 
procedure TQUADER.korrdepth(var w: Word); 
const 
  m = 3; 
var 
  x, y: Integer; 
begin 
  if width < height then 
    x := width 
  else 
    x := height; 
  y := round(x / 1.5); 
  if w < m then 
    w := m 
  else if w > y then 
    w := y; 
end; 
 
Procedure TQUADER.Resize; 
begin 
  if width < mn then 
    width := mn; 
  if height < mn then 
    height := mn; 
  korrdepth(Fd); 
end; 
 
end.