DBR Delphi-Ecke

// Der folgende Code erlaubt einen Rollo-Effekt für ein Panel und
// eine Radiogroup. Wenn der Mauspfeil eines der Controls berührt,
// rollt es auf. Nimmt man die Maus weg bevor es komplett
// aufgerollt ist, rollt es wieder zusammen. Ansonsten bleit das
// jeweilige Control eine bestimmte Verzögerungszeit offen,
// und rollt erst danach zusammen. Ist es komplett aufgerollt, dann
// bleit es solange offen, wie sich die Maus über dem Control
// befindet. Ist allerdings die Variable "immer1Control" auf "True"
// gesetzt, schließt das Control erst, wenn das andere aufgerollt
// wird.

// Getestet mit D4 unter XP

... 
type 
  TForm1 = class(TForm) 
    Timer1: TTimer; 
    Timer2: TTimer; 
    Timer3: TTimer; 
    Timer4: TTimer; 
    Panel1: TPanel; 
    RadioGroup1: TRadioGroup; 
    procedure FormCreate(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure Timer2Timer(Sender: TObject); 
    procedure Timer3Timer(Sender: TObject); 
    procedure Timer4Timer(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  protected 
    procedure WndProc(var M: TMessage); override; 
  public 
    procedure PanelAuf; 
    procedure PanelZu; 
    procedure RadioGroupAuf; 
    procedure RadioGroupZu; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
var 
  PH, PT, PStufe, RH, RT, RStufe: integer; 
  PUntennachoben: boolean = false; 
  RUntennachoben: boolean = true; 
  PVerzoegerung: Cardinal = 2000; 
  RVerzoegerung: Cardinal = 3000; 
  RminH: integer = 13; 
  PminH: integer = 4; 
  step: integer = 3; 
  fehler: boolean = false; 
  immer1Control: boolean = false; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Timer1.interval := 0; 
  Timer2.interval := 0; 
  Timer3.interval := 0; 
  Timer4.interval := 0; 
  if PminH < step then begin 
    fehler := true; 
    raise exception.create('Mindesthöhe des Panels zu klein'); 
  end; 
  if RminH < step then begin 
    fehler := true; 
    raise exception.create('Mindesthöhe der Radiogroup zu klein'); 
  end; 
  // --- Überlauf verhindern --- 
  Panel1.height := (Panel1.height div step) * step; 
  RadioGroup1.height := (RadioGroup1.height div step) * step; 
  PminH := (PminH div step) * step; 
  RminH := (RminH div step) * step; 
  // --------------------------- 
  PT := Panel1.top; 
  PH := Panel1.height; 
  Panel1.Caption := ''; 
  if PUntennachoben then 
    Panel1.top := PT + PH - PminH; 
  Panel1.height := PminH; 
  RT := RadioGroup1.top; 
  RH := RadioGroup1.height; 
  if RUntennachoben then 
    RadioGroup1.top := RT + RH - RminH; 
  RadioGroup1.height := RminH; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  Panel1.height := Panel1.height + PStufe; 
  if PUntennachoben then 
    Panel1.Top := Panel1.top - PStufe; 
  if (Panel1.height = PH) 
    or (Panel1.height = PminH) then 
    Timer1.interval := 0; 
end; 
 
procedure TForm1.Timer2Timer(Sender: TObject); 
begin 
  RadioGroup1.height := RadioGroup1.height + RStufe; 
  if RUntennachoben then 
    RadioGroup1.Top := RadioGroup1.top - RStufe; 
  if (RadioGroup1.height = RH) 
    or (RadioGroup1.height = RminH) then 
    Timer2.interval := 0; 
end; 
 
procedure TForm1.Timer3Timer(Sender: TObject); 
begin 
  Timer3.interval := 0; 
  if fehler then exit; 
  PStufe := -step; 
  Timer1.interval := 10; 
end; 
 
procedure TForm1.Timer4Timer(Sender: TObject); 
begin 
  Timer4.interval := 0; 
  if fehler then exit; 
  RStufe := -step; 
  Timer2.interval := 10; 
end; 
 
procedure TForm1.PanelAuf; 
begin 
  Timer3.interval := 0; 
  if fehler then exit; 
  if immer1Control and (RadioGroup1.height > RminH) 
    then Timer4Timer(Timer4); 
  if Panel1.height < PH then begin 
    PStufe := step; 
    Timer1.interval := 10; 
  end; 
end; 
 
procedure TForm1.RadioGroupAuf; 
begin 
  Timer4.interval := 0; 
  if fehler then exit; 
  if immer1Control and (Panel1.height > PminH) 
    then Timer3Timer(Timer3); 
  if RadioGroup1.height < RH then begin 
    RStufe := step; 
    Timer2.interval := 10; 
  end; 
end; 
 
procedure TForm1.PanelZu; 
var P: TPoint; 
begin 
  if fehler then exit; 
  if Panel1.height > PminH then begin 
    GetCursorpos(p); 
    p := Screentoclient(p); 
    if ptinrect(Panel1.boundsrect, p) then exit; 
    if Panel1.height = PH then 
      Timer3.interval := PVerzoegerung else 
      Timer3Timer(Timer3); 
  end; 
end; 
 
procedure TForm1.RadioGroupZu; 
var P: TPoint; 
begin 
  if fehler then exit; 
  if RadioGroup1.height > RminH then begin 
    GetCursorpos(p); 
    p := Screentoclient(p); 
    if ptinrect(RadioGroup1.boundsrect, p) then exit; 
    if RadioGroup1.height = RH then 
      Timer4.interval := RVerzoegerung else 
      Timer4Timer(Timer4); 
  end; 
end; 
 
procedure TForm1.WndProc(var M: TMessage); 
begin 
  if M.LParam = Longint(Panel1) then begin 
    case M.Msg of 
      CM_MOUSEENTER: PanelAuf; 
      CM_MOUSELEAVE: if not immer1Control then PanelZu; 
    end; 
  end else 
    if M.LParam = Longint(RadioGroup1) then 
      case M.Msg of 
        CM_MOUSEENTER: RadioGroupAuf; 
        CM_MOUSELEAVE: if not immer1Control then RadioGroupZu; 
      end; 
  inherited WndProc(M); 
end;