unit Schieber; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls; 
 
type 
  TSchieber = class(TWinControl) 
  private 
    FLeft, FTop, FRight, FBottom, FDo, FDl, FDr, FDu: Integer; 
    FTransparent, FErlaubt, FSchiebung, FAnders: boolean; 
    FRegion1, FRegion2: HRgn; 
    FBitmap: TBitmap; 
    FColor: TColor; 
    FPunkt: TPoint; 
    FDc: HDC; 
  protected 
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseUp(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure paint(var M: TMessage); message wm_paint; 
    procedure setBottom(i: integer); 
    procedure setRight(i: integer); 
    procedure settrans(b: boolean); 
    procedure setLeft(i: integer); 
    procedure setcolor(c: TColor); 
    procedure setTop(i: integer); 
    procedure setbm(b: TBitmap); 
    procedure loaded; override; 
    procedure Resize; override; 
    procedure BuildRegion; 
    procedure setFarbe; 
    procedure region; 
    procedure gross; 
  public 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
  published 
    property SchiebenErlaubt: boolean read FErlaubt write FErlaubt; 
    property Transparent: boolean read FTransparent write settrans; 
    property TransparentColor: TColor read FColor write setcolor; 
    property GrenzeUnten: Integer read FBottom write setBottom; 
    property GrenzeRechts: Integer read FRight write setRight; 
    property GrenzeLinks: Integer read FLeft write setLeft; 
    property GrenzeOben: Integer read FTop write setTop; 
    property Bitmap: TBitmap read FBitmap write setbm; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnDblClick; 
    property PopupMenu; 
    property OnMouseUp; 
    property ShowHint; 
    property Visible; 
    property Enabled; 
    property OnClick; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TSchieber]); 
end; 
 
procedure TSchieber.BuildRegion; 
var p: PBytearray; 
  x, y: integer; 
  ro, gr, bl: byte; 
  F: TColor; 
  function kombine(a: integer): integer; 
  var b, c: integer; 
  begin 
    b := -1; 
    while a < FBitmap.width * 3 do begin 
      if (p[a] <> bl) or (p[a + 1] <> gr) or (p[a + 2] <> ro) 
        then begin 
        b := a div 3; 
        if FDo < 0 then FDo := y; 
        if b < FDl then FDl := b; 
        FDu := height; 
        break; 
      end; 
      inc(a, 3); 
    end; 
    if b < 0 then begin 
      if FDu = height then FDu := y; 
      result := a; 
      exit; 
    end; 
    while a < FBitmap.width * 3 do begin 
      if (p[a] = bl) and (p[a + 1] = gr) and (p[a + 2] = ro) 
        then begin 
        break; 
      end; 
      inc(a, 3); 
    end; 
    c := a div 3; 
    if c > FDr then FDr := c; 
    result := a; 
    FRegion2 := CreateRectRgn(b, y, a div 3, succ(y)); 
    CombineRgn(FRegion1, FRegion1, FRegion2, RGN_OR); 
    DeleteObject(FRegion2); 
  end; 
begin 
  FBitmap.pixelformat := pf24bit; 
  F := ColorToRGB(FColor); 
  ro := getrvalue(F); 
  gr := getgvalue(F); 
  bl := getbvalue(F); 
  FRegion1 := CreateRectRgn(0, 0, 0, 0); 
  for y := 0 to pred(FBitmap.height) do begin 
    p := FBitmap.ScanLine[y]; 
    x := 0; 
    while x < FBitmap.width * 3 do x := kombine(x); 
  end; 
  FDr := width - FDr; 
  FDu := pred(height - FDu); 
end; 
 
constructor TSchieber.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  Fanders := false; 
  Fleft := -1000000000; 
  Ftop := -1000000000; 
  Fright := 1000000000; 
  Fbottom := 1000000000; 
  FBitmap := TBitmap.create; 
  FErlaubt := true; 
  FColor := clBtnFace; 
  Color := clBlack; 
end; 
 
destructor TSchieber.Destroy; 
begin 
  FBitmap.Free; 
  deleteobject(FRegion1); 
  inherited Destroy; 
end; 
 
procedure TSchieber.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  FPunkt.X := X; 
  FPunkt.Y := Y; 
  inherited; 
  FSchiebung := FErlaubt and Enabled; 
end; 
 
procedure TSchieber.MouseUp(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  inherited; 
  FSchiebung := false; 
end; 
 
procedure TSchieber.MouseMove(Shift: TShiftState; X, Y: Integer); 
var T, L: integer; 
begin 
  if FSchiebung then begin 
    T := Top - FPunkt.y + y; 
    L := Left - FPunkt.x + x; 
    if T < Ftop - FDo then T := Ftop - FDo else 
      if T + height - FDu > Fbottom then 
        T := Fbottom - height + FDu; 
    if L < Fleft - FDl then L := Fleft - FDl else 
      if L + width - FDr > Fright then 
        L := Fright - width + Fdr; 
    SetBounds(L, T, Width, Height); 
  end; 
  inherited; 
end; 
 
procedure TSchieber.paint(var M: TMessage); 
begin 
  inherited; 
  FDc := GetDc(self.handle); 
  BitBlt(FDc, 0, 0, FBitmap.width, FBitmap.height, 
    FBitmap.canvas.handle, 0, 0, srccopy); 
  DeleteDc(FDc); 
end; 
 
procedure TSchieber.region; 
begin 
  if FTransparent and not FBitmap.empty then begin 
    FDo := -1; 
    FDl := width; 
    FDu := height; 
    FDr := FDo; 
    BuildRegion; 
    setwindowRgn(handle, FRegion1, true); 
  end else begin 
    FDo := 0; 
    FDu := FDo; 
    FDl := FDo; 
    FDr := FDo; 
    deleteobject(FRegion1); 
    setwindowRgn(handle, 0, true); 
  end; 
  invalidate; 
end; 
 
procedure TSchieber.gross; 
begin 
  if FBitmap.empty then begin 
    width := 30; 
    height := 20; 
  end else begin 
    width := FBitmap.width; 
    height := FBitmap.height; 
  end; 
end; 
 
procedure TSchieber.setFarbe; 
begin 
  FColor := FBitmap.TransparentColor; 
end; 
 
procedure TSchieber.setbm(b: TBitmap); 
begin 
  FBitmap.assign(b); 
  gross; 
  if FBitmap.empty then FColor := clBtnFace 
  else setfarbe; 
  region; 
end; 
 
procedure TSchieber.settrans(b: boolean); 
begin 
  if b = FTransparent then exit; 
  FTransparent := b; 
  if not FBitmap.empty and (FColor = clBtnFace) 
    and b then setfarbe; 
  region; 
  FAnders := true; 
  setRight(FRight); 
  setLeft(FLeft); 
  setBottom(FBottom); 
  setTop(FTop); 
  FAnders := false; 
end; 
 
procedure TSchieber.Loaded; 
begin 
  inherited Loaded; 
  region; 
end; 
 
procedure TSchieber.resize; 
begin 
  gross; 
end; 
 
procedure TSchieber.setcolor(c: TColor); 
begin 
  if c = FColor then exit; 
  FColor := c; 
  region; 
end; 
 
procedure TSchieber.setLeft(i: integer); 
begin 
  if (i = FLeft) and not FAnders then exit; 
  FLeft := i; 
  if left + FDl < FLeft then left := FLeft - FDl; 
end; 
 
procedure TSchieber.setTop(i: integer); 
begin 
  if (i = FTop) and not FAnders then exit; 
  FTop := i; 
  if top + FDo < FTop then top := FTop - Fdo; 
end; 
 
procedure TSchieber.setRight(i: integer); 
begin 
  if (i = FRight) and not FAnders then exit; 
  FRight := i; 
  if left + width - FDr > FRight then left := i - width + FDr; 
end; 
 
procedure TSchieber.setBottom(i: integer); 
begin 
  if (i = FBottom) and not FAnders then exit; 
  FBottom := i; 
  if top + height - FDu > FBottom then top := i - height + FDu; 
end; 
 
end.