TListBox scrolled?

[Jens Schumann]

Hallo,
das ist dank der OOP eigentlich kein Problem. Ich habe sowas mal für TSrcollbox benötigt.
D.h. wenn eine TScrollbox gescrollt wird soll die andere (oder mehrere) synchron mitscrollen.
Hier kommt der Source für die TScrollBox. Sollte sich leicht auf eine TListbox übertragen lassen.

Delphi-Quellcode:

unit ScrollBoxEx;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

Const
  CM_SCROLLBOXEXVERTSCROLL  = WM_USER+512;
  CM_SCROLLBOXEXHORIZSCROLL = WM_USER+513;

type

  TScrollEvent = procedure (Sender : TObject; Position : Integer) of Object;

  TScrollBoxEx = class(TScrollBox)
  private
    FOnVScroll      : TScrollEvent;
    fOnHScroll      : TScrollEvent;
    FGroupIndex     : Integer;
    FWallpaper      : TBitmap;
    FCanvas         : TControlCanvas;
    procedure SetGroupIndex(const Value: Integer);
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure CMSCROLLBOXEXVERTSCROLL(var Message: TMessage); message CM_SCROLLBOXEXVERTSCROLL;
    procedure CMSCROLLBOXEXHORIZSCROLL(var Message: TMessage); message CM_SCROLLBOXEXHORIZSCROLL;
    procedure SetWallpaper(const Value: TBitmap);
    procedure PaintTileWallpaper(CanvasHandle: THandle; WndRect : TRect);
    { Private-Deklarationen }
  protected
    { Protected-Deklarationen }
    procedure PaintWindow(DC: HDC); override;
  public
    { Public-Deklarationen }
    constructor Create(AOwner : TComponent); override;
    destructor  Destroy; override;
  published
    { Published-Deklarationen }
    property GroupIndex : Integer read FGroupIndex write SetGroupIndex default 0;
    property Wallpaper  : TBitmap read FWallpaper write SetWallpaper;
    property OnHScroll  : TScrollEvent read fOnHScroll write fOnHScroll;
    property OnVScroll  : TScrollEvent read fOnVScroll write fOnVScroll;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Mycomps', [TScrollBoxEx]);
end;

{ TScrollBoxEx }

constructor TScrollBoxEx.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FWallpaper:=TBitmap.Create;
  FCanvas:=TControlCanvas.Create;
  FCanvas.Control:=Self;
  FGroupIndex:=0;
  fOnVScroll:=Nil;
end;

destructor TScrollBoxEx.Destroy;
begin
  FWallpaper.Free;
  FCanvas.Free;
  inherited Destroy;
end;

procedure TScrollBoxEx.SetGroupIndex(const Value: Integer);
begin
  FGroupIndex := Value;
end;

procedure  TScrollBoxEx.WMHScroll(var Message: TWMHScroll);
var
  Msg: TMessage;
begin
  inherited;
  If Assigned(fOnHScroll) then
    fOnHScroll(Self,Message.Pos);
  if (FGroupIndex <> 0) and (Parent <> nil) then
  begin
    Msg.Msg := CM_SCROLLBOXEXHORIZSCROLL;
    Msg.WParam := FGroupIndex;
    Msg.LParam := Longint(Self);
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;

procedure  TScrollBoxEx.WMVScroll(var Message: TWMVScroll);
var
  Msg: TMessage;
begin
  inherited;
  If Assigned(fOnVScroll) then
    fOnVScroll(Self,Message.Pos);
  if (FGroupIndex <> 0) and (Parent <> nil) then
  begin
    Msg.Msg := CM_SCROLLBOXEXVERTSCROLL;
    Msg.WParam := FGroupIndex;
    Msg.LParam := Longint(Self);
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;

procedure TScrollBoxEx.CMSCROLLBOXEXVERTSCROLL(var Message: TMessage);
var
  Sender: TScrollBoxEx;
begin
  inherited;
  If FGroupIndex<=0 then Exit;
  if Message.WParam = FGroupIndex then
  begin
    Sender := TScrollBoxEx(Message.LParam);
    if Sender <> Self then
    begin
    VertScrollBar.Position:=Sender.VertScrollBar.Position;
    end;
  end;
end;

procedure TScrollBoxEx.CMSCROLLBOXEXHORIZSCROLL(var Message: TMessage);
var
  Sender: TScrollBoxEx;
begin
  inherited;
  If FGroupIndex<=0 then Exit;
  if Message.WParam = FGroupIndex then
  begin
    Sender := TScrollBoxEx(Message.LParam);
    if Sender <> Self then
    begin
    HorzScrollBar.Position:=Sender.HorzScrollBar.Position;
    end;
  end;
end;

procedure TScrollBoxEx.SetWallpaper(const Value: TBitmap);
begin
  FWallpaper.Assign(Value);
  Invalidate;
end;

procedure TScrollBoxEx.PaintTileWallpaper(CanvasHandle: THandle; WndRect : TRect);
var
  Row                 : Integer;
  Col                 : Integer;
begin
  For Row := 0 to (WndRect.Bottom div FWallpaper.Height)+1 do
    For Col := 0 to (WndRect.Right div FWallpaper.Width)+1 do
      BitBlt(CanvasHandle,
             Col * FWallpaper.Width,
             Row * FWallpaper.Height,
             FWallpaper.Width,
             FWallpaper.Height,
             FWallpaper.Canvas.Handle,
             0,
             0,
             SRCCOPY);
end;

procedure TScrollBoxEx.PaintWindow(DC: HDC);
begin
  FCanvas.Lock;
  Try
    FCanvas.Handle := DC;
    If (FWallpaper.Width>0) and (FWallPaper.Height>0) then
      PaintTileWallpaper(FCanvas.Handle,ClientRect);
  Finally
    FCanvas.Handle := 0;
    FCanvas.UnLock;
  end;
end;

end.

Wichtig ist das abfangen der Botschaften WM_HSCROLL und WM_VSCROLL

Delphi-Quellcode:

procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;

In innerhalb der Implementation passiert folgendes:

Delphi-Quellcode:

procedure  TScrollBoxEx.WMHScroll(var Message: TWMHScroll);
var
  Msg: TMessage;
begin
  inherited; // Vorfahren aufrufen
  If Assigned(fOnHScroll) then 
    fOnHScroll(Self,Message.Pos); // Event abfeuern
  if (FGroupIndex <> 0) and (Parent <> nil) then 
  begin
    Msg.Msg := CM_SCROLLBOXEXHORIZSCROLL; // Messagewert setzen
    Msg.WParam := FGroupIndex; // den GroupIndex in wParam
    Msg.LParam := Longint(Self); // Wichtig Referenz auf sich selbst in lParam schreiben
    Msg.Result := 0;
    Parent.Broadcast(Msg); // Mit der Methode BroadCast des Parents die Botschafte an alle
                           // TWinControls senden, die den gleichen Parent haben.
                           // Habe ich bei TSpeedbutton angekupfert.
  end;
end;

Ist die Botschaft abgeschickt, wird sie durch folgende Methode verarbeitet.

Delphi-Quellcode:

...
procedure CMSCROLLBOXEXHORIZSCROLL(var Message: TMessage); message CM_SCROLLBOXEXHORIZSCROLL;
...
procedure TScrollBoxEx.CMSCROLLBOXEXHORIZSCROLL(var Message: TMessage);
var
  Sender: TScrollBoxEx;
begin
  inherited;
  If FGroupIndex<=0 then Exit;  // Wenn kein GroupIndex definiert Methode sofort verlassen
  if Message.WParam = FGroupIndex then // Wenn in wParam der gleiche GroupIndex steht dann 
  begin
    Sender := TScrollBoxEx(Message.LParam);
    if Sender <> Self then // Hat der Sender die Botschaft empfangen ? Wenn ja ignorieren
    begin
    HorzScrollBar.Position:=Sender.HorzScrollBar.Position; // Scrollbarposition setzen
    // Bei TListbox könnte hier ItemIndex gesetzt werden.
    end;
  end;
end;