www.pudn.com > virdisk_source.rar > TFlatListBoxUnit.pas

unit TFlatListBoxUnit; 
 
interface 
 
{$I Version.inc} 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls, FlatUtilitys; 
 
type 
  TFlatListBox = class(TCustomControl) 
  private 
    cWheelMessage: Cardinal; 
    scrollType: TScrollType; 
    firstItem: Integer; 
    maxItems: Integer; 
    FSorted: Boolean; 
    FItems: TStringList; 
    FItemsRect: TList; 
    FItemsHeight: 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); 
    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 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; 
  public 
    constructor Create (AOwner: TComponent); override; 
    destructor Destroy; override; 
    property Selected [Index: Integer]: Boolean read GetSelected write SetSelected; 
    property SelCount: Integer read GetSelCount; 
  published 
    property Align; 
    property Items: TStringList read FItems write SetItems; 
    property ItemHeight: Integer read FItemsHeight write SetItemsHeight default 17; 
    property MultiSelect: Boolean read FMultiSelect write FMultiSelect 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 Enabled; 
    property Visible; 
    property PopupMenu; 
    property ShowHint; 
 
    property OnMouseMove; 
    property OnMouseDown; 
    property OnMouseUp; 
   {$IFDEF D4CB4} 
    property Anchors; 
    property BiDiMode; 
    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; 
  FArrowColor := clBlack; 
  FBorderColor := $008396A0; 
  FItemsRectColor := clWhite; 
  FItemsSelectColor := $009CDEF7; 
  ParentColor := True; 
  ParentFont := True; 
  Enabled := true; 
  Visible := true; 
  FUseAdvColors := false; 
  FAdvColorBorder := 40; 
  FSorted := false; 
  cWheelMessage:= RegisterWindowMessage(MSH_MOUSEWHEEL); 
end; 
 
destructor TFlatListBox.Destroy; 
begin 
  ScrollTimer.Free; 
  ScrollTimer := nil; 
  FItems.Free; 
  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 
        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; 
begin 
  // 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 
    memoryBitmap.canvas.Brush.Color := FItemsRectColor; 
    memoryBitmap.canvas.FillRect(ClientRect); 
 
    // 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^, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX) 
        else 
          begin 
            OffsetRect(itemRect^, 1, 1); 
            memoryBitmap.canvas.Font.Color := clBtnHighlight; 
            DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX); 
            OffsetRect(itemRect^, -1, -1); 
            memoryBitmap.canvas.Font.Color := clBtnShadow; 
            DrawText(memoryBitmap.canvas.Handle, PChar(FItems[counterItem]), Length(FItems[counterItem]), itemRect^, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX); 
          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     
          if (firstItem + counterRect) in FSelected then 
            Exclude(FSelected, firstItem + counterRect) 
          else 
            Include(FSelected, firstItem + counterRect) 
        else 
          begin 
            FSelected := FSelected - [0..High(Byte)]; 
            Include(FSelected, 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; 
 
end.