TFlatListBoxUnit.pas

unit TFlatListBoxUnit;

interface

{$I DFS.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls, FlatUtilitys;

type
  TFlatListBox = class(TCustomControl)
  private
    FTransparent: TTransparentMode;
    cWheelMessage: Cardinal;
    scrollType: TScrollType;
    firstItem: Integer;
    maxItems: Integer;
    FSorted: Boolean;
    FItems: TStringList;
    FItemsRect: TList;
    FItemsHeight: Integer;
    FItemIndex: Integer;
    FSelected: set of Byte;
    FMultiSelect: Boolean;
    FScrollBars: Boolean;
    FUseAdvColors: Boolean;
    FAdvColorBorder: TAdvColors;
    FArrowColor: TColor;
    FBorderColor: TColor;
    FItemsRectColor: TColor;
    FItemsSelectColor: TColor;
    procedure SetColors (Index: Integer; Value: TColor);
    procedure SetAdvColors (Index: Integer; Value: TAdvColors);
    procedure SetUseAdvColors (Value: Boolean);
    procedure SetSorted (Value: Boolean);
    procedure SetItems (Value: TStringList);
    procedure SetItemsRect;
    procedure SetItemsHeight (Value: Integer);
    function GetSelected (Index: Integer): Boolean;
    procedure SetSelected (Index: Integer; Value: Boolean);
    function GetSelCount: Integer;
    procedure SetScrollBars (Value: Boolean);
    function GetItemIndex: Integer;
    procedure SetItemIndex (Value: Integer);
    procedure SetMultiSelect (Value: Boolean);
    procedure WMSize (var Message: TWMSize); message WM_SIZE;
    procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMParentColorChanged (var Message: TWMNoParams); message CM_PARENTCOLORCHANGED;
    procedure ScrollTimerHandler (Sender: TObject);
    procedure ItemsChanged (Sender: TObject);
    procedure WMMove (var Message: TWMMove); message WM_MOVE;
    procedure WMSetFocus (var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus (var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
    procedure SetTransparent (const Value: TTransparentMode);
    procedure WMMouseWheel (var Message: TMessage); message WM_MOUSEWHEEL;
  protected
    procedure CalcAdvColors;
    procedure DrawScrollBar (canvas: TCanvas);
    procedure Paint; override;
    procedure Loaded; override;
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure WndProc (var Message: TMessage); override;
   {$IFDEF DFS_COMPILER_4_UP}
    procedure SetBiDiMode(Value: TBiDiMode); override;
   {$ENDIF}
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    property Selected [Index: Integer]: Boolean read GetSelected write SetSelected;
    property SelCount: Integer read GetSelCount;
    property ItemIndex: Integer read GetItemIndex write SetItemIndex;
  published
    property TransparentMode: TTransparentMode read FTransparent write SetTransparent default tmNone;
    property Align;
    property Items: TStringList read FItems write SetItems;
    property ItemHeight: Integer read FItemsHeight write SetItemsHeight default 17;
    property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default false;
    property ScrollBars: Boolean read FScrollBars write SetScrollBars default false;
    property Color default $00E1EAEB;
    property ColorArrow: TColor index 0 read FArrowColor write SetColors default clBlack;
    property ColorBorder: TColor index 1 read FBorderColor write SetColors default $008396A0;
    property ColorItemsRect: TColor index 2 read FItemsRectColor write SetColors default clWhite;
    property ColorItemsSelect: TColor index 3 read FItemsSelectColor write SetColors default $009CDEF7;
    property AdvColorBorder: TAdvColors index 0 read FAdvColorBorder write SetAdvColors default 40;
    property UseAdvColors: Boolean read FUseAdvColors write SetUseAdvColors default false;
    property Sorted: Boolean read FSorted write SetSorted default false;
    property Font;
    property ParentFont;
    property ParentColor;
    property ParentShowHint;
    property Enabled;
    property Visible;
    property PopupMenu;
    property ShowHint;

    property OnClick;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
   {$IFDEF DFS_COMPILER_4_UP}
    property Anchors;
    property BiDiMode write SetBidiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
   {$ENDIF}
  end;

implementation

var
  ScrollTimer: TTimer = nil;

const
  FTimerInterval = 600; 
  FScrollSpeed = 100;

constructor TFlatListBox.Create (AOwner: TComponent);
begin
  inherited;
  if ScrollTimer = nil then
  begin
    ScrollTimer := TTimer.Create(nil);
    ScrollTimer.Enabled := False;
    ScrollTimer.Interval := FTimerInterval;
  end;
  ControlStyle := ControlStyle + [csOpaque];
  SetBounds(Left, Top, 137, 99);
  FItems := TStringList.Create;
  FItemsRect := TList.Create;
  FItemsHeight := 17;

  TStringList(FItems).OnChange := ItemsChanged;

  FMultiSelect := false;
  FScrollBars := false;
  firstItem := 0;
  FItemIndex := -1;
  FArrowColor := clBlack;
  FBorderColor := $008396A0;
  FItemsRectColor := clWhite;
  FItemsSelectColor := $009CDEF7;
  ParentColor := True;
  ParentFont := True;
  Enabled := true;
  Visible := true;
  FUseAdvColors := false;
  FAdvColorBorder := 40;
  FSorted := false;
  FTransparent := tmNone;
  cWheelMessage:= RegisterWindowMessage(MSH_MOUSEWHEEL);
end;

destructor TFlatListBox.Destroy;
var
  counter: Integer;
begin
  ScrollTimer.Free;
  ScrollTimer := nil;
  FItems.Free;
  for counter := 0 to FItemsRect.Count - 1 do
    Dispose(FItemsRect.Items[counter]);
  FItemsRect.Free;
  inherited;
end;

procedure TFlatListBox.WndProc (var Message: TMessage);
begin
  if Message.Msg = cWheelMessage then
  begin
    SendMessage (Self.Handle, WM_MOUSEWHEEL, Message.wParam, Message.lParam);
  end;
  inherited;
end;

procedure TFlatListBox.WMMouseWheel (var Message: TMessage);
var
  fScrollLines: Integer;
begin
  if not(csDesigning in ComponentState) then
  begin
    SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @fScrollLines, 0);

    if (fScrollLines = 0) then
      fScrollLines := maxItems;

    if ShortInt(Message.WParamHi) = -WHEEL_DELTA then
      if firstItem + maxItems + fScrollLines <= FItems.Count then
        Inc(firstItem, fScrollLines)
      else
        if FItems.Count - maxItems < 0 then
          firstItem := 0
        else
          firstItem := FItems.Count - maxItems
    else
      if ShortInt(Message.WParamHi) = WHEEL_DELTA then
        if firstItem - fScrollLines < 0 then
          firstItem := 0
        else
          dec(firstItem, fScrollLines);
    Invalidate;
  end;
end;

procedure TFlatListBox.ItemsChanged (Sender: TObject);
begin
  if Enabled then
  begin
    FSelected := FSelected - [0..High(Byte)];
    Invalidate;
  end;
end;

procedure TFlatListBox.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    0: FArrowColor := Value;
    1: FBorderColor := Value;
    2: FItemsRectColor := Value;
    3: FItemsSelectColor := Value;
  end;
  Invalidate;       
end;

procedure TFlatListBox.CalcAdvColors;
begin
  if FUseAdvColors then
  begin
    FBorderColor := CalcAdvancedColor(Color, FBorderColor, FAdvColorBorder, darken);
  end;
end;

procedure TFlatListBox.SetAdvColors (Index: Integer; Value: TAdvColors);
begin
  case Index of
    0: FAdvColorBorder := Value;
  end;
  CalcAdvColors;
  Invalidate;
end;

procedure TFlatListBox.SetUseAdvColors (Value: Boolean);
begin
  if Value <> FUseAdvColors then
  begin
    FUseAdvColors := Value;
    ParentColor := Value;
    CalcAdvColors;
    Invalidate;
  end;
end;

procedure TFlatListBox.SetSorted (Value: Boolean);
begin
  if Value <> FSorted then
  begin
    FSorted := Value;
    FItems.Sorted := Value;
    FSelected := FSelected - [0..High(Byte)];
    Invalidate;
  end;
end;

procedure TFlatListBox.SetItems (Value: TStringList);
var
  counter: Integer;
begin
  if Value.Count - 1 > High(Byte) then
    Exit;

  // delete all spaces at left and right
  for counter := 0 to Value.Count - 1 do
    Value[counter] := Trim(Value[counter]);

  FItems.Assign(Value);

  Invalidate;
end;

procedure TFlatListBox.SetItemsRect;
var
  counter: Integer;
  ItemRect: ^TRect;
  position: TPoint;
begin
  // Delete all curent Rects
  FItemsRect.Clear;

  // calculate the maximum items to draw
  if ScrollBars then
    maxItems := (Height - 24) div (FItemsHeight + 2)
  else
    maxItems := (Height - 4) div (FItemsHeight + 2);

  // set left/top position for the the first item
  if ScrollBars then
   position := Point(ClientRect.left + 3, ClientRect.top + 13)
  else
    position := Point(ClientRect.left + 3, ClientRect.top + 3);

  for counter := 0 to maxItems - 1 do
  begin
    // create a new Item-Rect
    New(ItemRect);
    // calculate the Item-Rect
    ItemRect^ := Rect(position.x, position.y, ClientRect.Right - 3, position.y + FItemsHeight);
    // set left/top position for next Item-Rect
    position := Point(position.x, position.y + FItemsHeight + 2);
    // add the Item-Rect to the Items-Rect-List
    FItemsRect.Add(ItemRect);
  end;
  Invalidate;
end;

procedure TFlatListBox.SetItemsHeight (Value: Integer);
begin
  if Value < 1 then
    Value := 1;

  FItemsHeight := Value;

  if not (csLoading in ComponentState) then
    if ScrollBars then
      SetBounds(Left, Top, Width, maxItems * (FItemsHeight + 2) + 24)
    else
      SetBounds(Left, Top, Width, maxItems * (FItemsHeight + 2) + 4);
      
  SetItemsRect;
end;

function TFlatListBox.GetSelected (Index: Integer): Boolean;
begin
  Result := Index in FSelected;
end;

procedure TFlatListBox.SetSelected (Index: Integer; Value: Boolean);
begin
  if MultiSelect then
    if Value then
      Include(FSelected, Index)
    else
      Exclude(FSelected, Index)
  else
    begin
      FSelected := FSelected - [0..High(Byte)];
      if Value then
        Include(FSelected, Index)
      else
        Exclude(FSelected, Index);
    end;
  Invalidate;
end;

function TFlatListBox.GetSelCount: Integer;
var
  counter: Integer;
begin
  if MultiSelect then
    begin
      Result := 0;
      for counter := 0 to High(Byte) do
        if counter in FSelected then
          Inc(Result);
    end
  else
    Result := -1;
end;

procedure TFlatListBox.SetScrollBars (Value: Boolean);
begin
  if FScrollBars <> Value then
  begin
    FScrollBars := Value;
    if not (csLoading in ComponentState) then
      if Value then
        Height := Height + 20
      else
        Height := Height - 20;
    SetItemsRect;
  end;
end;

procedure TFlatListBox.DrawScrollBar (canvas: TCanvas);
var
  x, y: Integer;
begin
  // Draw the ScrollBar background
  canvas.Brush.Color := Color;
  canvas.FillRect(Rect(ClientRect.Left, ClientRect.Top, ClientRect.Right, ClientRect.Top + 11));
  canvas.FillRect(Rect(ClientRect.Left, ClientRect.Bottom - 11, ClientRect.Right, ClientRect.Bottom));

  // Draw the ScrollBar border
  canvas.Brush.Color := FBorderColor;
  canvas.FrameRect(Rect(ClientRect.Left, ClientRect.Top, ClientRect.Right, ClientRect.Top + 11));
  canvas.FrameRect(Rect(ClientRect.Left, ClientRect.Bottom - 11, ClientRect.Right, ClientRect.Bottom));

  // Draw the up arrow
  x := (ClientRect.Right - ClientRect.Left) div 2 - 6;
  y := ClientRect.Top + 4;

  if (firstItem <> 0) and Enabled then
  begin
    canvas.Brush.Color := FArrowColor;
    canvas.Pen.Color := FArrowColor;
    canvas.Polygon([Point(x + 4, y + 2), Point(x + 8, y + 2), Point(x + 6, y)]);
  end
  else
  begin
    canvas.Brush.Color := clWhite;
    canvas.Pen.Color := clWhite;
    Inc(x); Inc(y);
    canvas.Polygon([Point(x + 4, y + 2), Point(x + 8, y + 2), Point(x + 6, y)]);
    Dec(x); Dec(y);
    canvas.Brush.Color := clGray;
    canvas.Pen.Color := clGray;
    canvas.Polygon([Point(x + 4, y + 2), Point(x + 8, y + 2), Point(x + 6, y)]);
  end;

  // Draw the down arrow
  y := ClientRect.Bottom - 7;
  if (firstItem + maxItems + 1 <= FItems.Count) and Enabled then
  begin
    canvas.Brush.Color := FArrowColor;
    canvas.Pen.Color := FArrowColor;
    canvas.Polygon([Point(X + 4, Y), Point(X + 8, Y), Point(X + 6, Y + 2)]);
  end
  else
  begin
    canvas.Brush.Color := clWhite;
    canvas.Pen.Color := clWhite;
    Inc(x); Inc(y);
    canvas.Polygon([Point(X + 4, Y), Point(X + 8, Y), Point(X + 6, Y + 2)]);
    Dec(x); Dec(y);
    canvas.Brush.Color := clGray;
    canvas.Pen.Color := clGray;
    canvas.Polygon([Point(X + 4, Y), Point(X + 8, Y), Point(X + 6, Y + 2)]);
  end;
end;

procedure TFlatListBox.Paint;
var
  memoryBitmap: TBitmap;
  counterRect, counterItem: Integer;
  itemRect: ^TRect;
  Format: UINT;
begin
  {$IFDEF DFS_COMPILER_4_UP}
  if BidiMode = bdRightToLeft then
    Format := DT_RIGHT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX
  else
    Format := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
  {$ELSE}
  Format := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
  {$ENDIF}

  // create memory-bitmap to draw flicker-free
  memoryBitmap := TBitmap.Create;
  try
    memoryBitmap.Height := ClientRect.Bottom;
    memoryBitmap.Width := ClientRect.Right;
    memoryBitmap.Canvas.Font.Assign(Self.Font);

    // Clear Background
    case FTransparent of
      tmAlways:
        DrawParentImage(Self, memoryBitmap.Canvas);
      tmNone:
        begin
          memoryBitmap.canvas.Brush.Color := FItemsRectColor;
          memoryBitmap.canvas.FillRect(ClientRect);
        end;
      tmNotFocused:
        if Focused then
        begin
          memoryBitmap.canvas.Brush.Color := FItemsRectColor;
          memoryBitmap.canvas.FillRect(ClientRect);
        end
        else
          DrawParentImage(Self, memoryBitmap.Canvas);
    end;

    // Draw Border
    memoryBitmap.canvas.Brush.Color := FBorderColor;
    memoryBitmap.canvas.FrameRect(ClientRect);

    // Draw ScrollBars
    if ScrollBars then
      DrawScrollBar(memoryBitmap.canvas);

    // Initialize the counter for the Items
    counterItem := firstItem;

    // Draw Items
    for counterRect := 0 to maxItems - 1 do
    begin
      itemRect := FItemsRect.Items[counterRect];
      if (counterItem <= FItems.Count - 1) then
      begin
        // Item is selected
        if counterItem in FSelected then
        begin
          // Fill ItemRect
          memoryBitmap.canvas.brush.color := FItemsSelectColor;
          memoryBitmap.canvas.FillRect(itemRect^);
          // Draw ItemBorder
          memoryBitmap.canvas.brush.color := FBorderColor;
          memoryBitmap.canvas.FrameRect(itemRect^);
        end;
        // Draw ItemText
        memoryBitmap.canvas.brush.style := bsClear;
        InflateRect(itemRect^, -3, 0);
        if Enabled then
          DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, Format)
        else
          begin
            OffsetRect(itemRect^, 1, 1);
            memoryBitmap.canvas.Font.Color := clBtnHighlight;
            DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, Format);
            OffsetRect(itemRect^, -1, -1);
            memoryBitmap.canvas.Font.Color := clBtnShadow;
            DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, Format);
          end;
        InflateRect(itemRect^, 3, 0);
        Inc(counterItem);
      end;
    end;
    // Copy bitmap to screen
    canvas.CopyRect(ClientRect, memoryBitmap.canvas, ClientRect);
  finally
    // delete the memory bitmap
    memoryBitmap.free;
  end;
end;

procedure TFlatListBox.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  cursorPos: TPoint;
  counterRect: Integer;
  currentRect: ^TRect;
begin
  GetCursorPos(cursorPos);
  cursorPos := ScreenToClient(cursorPos);

  if (FItems.Count > 0) and (Button = mbLeft) then
  begin
    for counterRect := 0 to FItemsRect.Count - 1 do
    begin
      currentRect := FItemsRect.Items[counterRect];
      if PtInRect(currentRect^, cursorPos) then
      begin
        if MultiSelect then
        begin
          if (firstItem + counterRect) in FSelected then
            Exclude(FSelected, firstItem + counterRect)
          else
            Include(FSelected, firstItem + counterRect);
          FItemIndex := firstItem + counterRect;
        end
        else
        begin
          FSelected := FSelected - [0..High(Byte)];
          Include(FSelected, firstItem + counterRect);
          FItemIndex := firstItem + counterRect;
        end;
        SetFocus;
        Invalidate;
        Exit;
      end;
    end;
  end;

  if ScrollBars then
  begin
    if PtInRect(Rect(ClientRect.Left, ClientRect.Top, ClientRect.Right, ClientRect.Top + 11), cursorPos) then
    begin
      if (firstItem - 1) < 0 then
        firstItem := 0
      else
        Dec(firstItem);
      SetFocus;
      Invalidate;
      scrollType := up;
      if ScrollTimer.Enabled then
        ScrollTimer.Enabled := False;
      ScrollTimer.OnTimer := ScrollTimerHandler;
      ScrollTimer.Enabled := True;
    end;
    if PtInRect(Rect(ClientRect.Left, ClientRect.Bottom - 11, ClientRect.Right, ClientRect.Bottom), cursorPos) then
    begin
      if firstItem + maxItems + 1 <= FItems.Count then
        Inc(firstItem);
      SetFocus;
      Invalidate;
      scrollType := down;
      if ScrollTimer.Enabled then
        ScrollTimer.Enabled := False;
      ScrollTimer.OnTimer := ScrollTimerHandler;
      ScrollTimer.Enabled := True;
    end;
  end;
  Inherited;
end;

procedure TFlatListBox.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  ScrollTimer.Enabled := False;
  ScrollTimer.Interval := FTimerInterval;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TFlatListBox.ScrollTimerHandler (Sender: TObject);
begin
  ScrollTimer.Interval := FScrollSpeed;
  if scrollType = up then
    if (firstItem - 1) < 0 then
    begin
      firstItem := 0;
      ScrollTimer.Enabled := False;
    end
    else
      Dec(firstItem)
  else
    if firstItem + maxItems + 1 <= FItems.Count then
      Inc(firstItem)
    else
      ScrollTimer.Enabled := False;
  Invalidate;
end;

procedure TFlatListBox.Loaded;
begin
  inherited;
  SetItemsRect;
end;

procedure TFlatListBox.WMSize (var Message: TWMSize);
begin
  inherited;
  // Calculate the maximum items to draw
  if ScrollBars then
    maxItems := (Height - 24) div (FItemsHeight + 2)
  else
    maxItems := (Height - 4) div (FItemsHeight + 2);

  // Set the new Bounds
  if ScrollBars then
    SetBounds(Left, Top, Width, maxItems * (FItemsHeight + 2) + 24)
  else
    SetBounds(Left, Top, Width, maxItems * (FItemsHeight + 2) + 4);

  // Recalculate the itemRects
  SetItemsRect;
end;

procedure TFlatListBox.CMEnabledChanged (var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TFlatListBox.CMSysColorChange (var Message: TMessage);
begin
  if FUseAdvColors then
  begin
    ParentColor := True;
    CalcAdvColors;
  end;
  Invalidate;
end;

procedure TFlatListBox.CMParentColorChanged (var Message: TWMNoParams);
begin
  inherited;
  if FUseAdvColors then
  begin
    ParentColor := True;
    CalcAdvColors;
  end;
  Invalidate;
end;

procedure TFlatListBox.SetTransparent (const Value: TTransparentMode);
begin
  FTransparent := Value;
  Invalidate;
end;

procedure TFlatListBox.WMMove (var Message: TWMMove);
begin
  inherited;
  if not (FTransparent = tmNone) then
    Invalidate;
end;

procedure TFlatListBox.WMKillFocus (var Message: TWMKillFocus);
begin
  inherited;
  if not (FTransparent = tmNone) then
    Invalidate;
end;

procedure TFlatListBox.WMSetFocus (var Message: TWMSetFocus);
begin
  inherited;
  if not (FTransparent = tmNone) then
    Invalidate;
end;

procedure TFlatListBox.CNKeyDown (var Message: TWMKeyDown);
begin
  case Message.CharCode of
    VK_UP:
      if (firstItem - 1) < 0 then
        firstItem := 0
      else
        Dec(firstItem);
    VK_DOWN:
      if firstItem + maxItems + 1 <= FItems.Count then
        Inc(firstItem);
    VK_PRIOR:
      if (firstItem - maxItems) < 0 then
        firstItem := 0
      else
        Dec(firstItem, maxItems);
    VK_NEXT:
      if firstItem + (maxItems * 2) <= FItems.Count then
        Inc(firstItem, maxItems)
      else
        firstItem := FItems.Count - maxItems;
  else
    inherited;
  end;
  Invalidate;
end;

function TFlatListBox.GetItemIndex: Integer;
begin
  Result := FItemIndex;
end;

procedure TFlatListBox.SetItemIndex (Value: Integer);
begin
  if GetItemIndex <> Value then
  begin
    FItemIndex := Value;
    if MultiSelect then
    begin
      if (Value) in FSelected then
        Exclude(FSelected, Value)
      else
        Include(FSelected, Value);
    end
    else
    begin
      FSelected := FSelected - [0..High(Byte)];
      Include(FSelected, Value);
    end;
    Invalidate;
  end;
end;

procedure TFlatListBox.SetMultiSelect (Value: Boolean);
begin
  FMultiSelect := Value;
  if Value then
    FItemIndex := 0;
end;

{$IFDEF DFS_COMPILER_4_UP}
procedure TFlatListBox.SetBiDiMode(Value: TBiDiMode);
begin
  inherited;
  Invalidate;
end;
{$ENDIF}

end.