jvcustomitemviewer.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvCustomItemViewer.PAS, released on 2003-12-01.

The Initial Developer of the Original Code is: Peter Th鰎nqvist
All Rights Reserved.

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
 TODO:
 * keyboard multiselect (ctrl+space)
 * caption editing
 * drag'n'drop insertion mark
 * text for imagelist viewer - DONE
 * text layout support (top, bottom) - DONE
 * drag'n'drop edge scrolling - DONE (almost, needs some tweaks to look good as well)
 * icons don't scale, should be handled differently - DONE (explicitly calls DrawIconEx)
-----------------------------------------------------------------------------}
// $Id: JvCustomItemViewer.pas,v 1.41 2005/02/18 14:17:23 ahuser Exp $

unit JvCustomItemViewer;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls, ComCtrls,
  ExtCtrls,
  JvConsts,  // for clSkyBlue
  JvExControls, JvExForms;

const
  CM_UNSELECTITEMS = WM_USER + 1;
  CM_DELETEITEM = WM_USER + 2;

type
  TJvItemViewerScrollBar = (tvHorizontal, tvVertical);
  TJvCustomItemViewer = class;

  TJvBrushPattern = class(TPersistent)
  private
    FPattern: TBitmap;
    FOddColor: TColor;
    FEvenColor: TColor;
    FActive: Boolean;
    procedure SetEvenColor(const Value: TColor);
    procedure SetOddColor(const Value: TColor);
  public
    function GetBitmap: TBitmap;
    constructor Create;
    destructor Destroy; override;

  published
    property Active: Boolean read FActive write FActive default True;
    property EvenColor: TColor read FEvenColor write SetEvenColor default clWhite;
    property OddColor: TColor read FOddColor write SetOddColor default clSkyBlue;
  end;

  // Base viewer options class. Derive from this when you need to add your own properties
  // to a viewer or publish the available ones. Declare a new Options property in
  // the viewer class (that only needs to call the inherited Options)
  // and override GetOptionsClass to return the property class type
  TJvCustomItemViewerOptions = class(TPersistent)
  private
    FVertSpacing: Integer;
    FHorzSpacing: Integer;
    FHeight: Integer;
    FWidth: Integer;
    FScrollBar: TJvItemViewerScrollBar;
    FOwner: TJvCustomItemViewer;
    FAutoCenter: Boolean;
    FSmooth: Boolean;
    FTracking: Boolean;
    FHotTrack: Boolean;
    FMultiSelect: Boolean;
    FBrushPattern: TJvBrushPattern;
    FLazyRead: Boolean;
    FAlignment: TAlignment;
    FLayout: TTextLayout;
    FShowCaptions: Boolean;
    FRightClickSelect: Boolean;
    FReduceMemoryUsage: Boolean;
    FDragAutoScroll: Boolean;
    procedure SetRightClickSelect(const Value: Boolean);
    procedure SetShowCaptions(const Value: Boolean);
    procedure SetAlignment(const Value: TAlignment);
    procedure SetLayout(const Value: TTextLayout);
    procedure SetHeight(const Value: Integer);
    procedure SetHorzSpacing(const Value: Integer);
    procedure SetScrollBar(const Value: TJvItemViewerScrollBar);
    procedure SetVertSpacing(const Value: Integer);
    procedure SetWidth(const Value: Integer);
    procedure SetAutoCenter(const Value: Boolean);
    procedure SetSmooth(const Value: Boolean);
    procedure SetTracking(const Value: Boolean);
    procedure SetHotTrack(const Value: Boolean);
    procedure SetMultiSelect(const Value: Boolean);
    procedure SetBrushPattern(const Value: TJvBrushPattern);
    procedure SetLazyRead(const Value: Boolean);
    procedure SetReduceMemoryUsage(const Value: Boolean);
  protected
    procedure Change; virtual;
  public
    constructor Create(AOwner: TJvCustomItemViewer); virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  protected
    property Owner: TJvCustomItemViewer read FOwner;
    property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
    property DragAutoScroll: Boolean read FDragAutoScroll write FDragAutoScroll default True;
    property Layout: TTextLayout read FLayout write SetLayout default tlBottom;
    property Width: Integer read FWidth write SetWidth default 120;
    property Height: Integer read FHeight write SetHeight default 120;
    property VertSpacing: Integer read FVertSpacing write SetVertSpacing default 4;
    property HorzSpacing: Integer read FHorzSpacing write SetHorzSpacing default 4;
    property ScrollBar: TJvItemViewerScrollBar read FScrollBar write SetScrollBar default tvVertical;
    property ShowCaptions: Boolean read FShowCaptions write SetShowCaptions default True;
    property LazyRead: Boolean read FLazyRead write SetLazyRead default True;
    property ReduceMemoryUsage: Boolean read FReduceMemoryUsage write SetReduceMemoryUsage default False;
    property AutoCenter: Boolean read FAutoCenter write SetAutoCenter;
    property Smooth: Boolean read FSmooth write SetSmooth default False;
    property Tracking: Boolean read FTracking write SetTracking default True;
    property HotTrack: Boolean read FHotTrack write SetHotTrack;
    property MultiSelect: Boolean read FMultiSelect write SetMultiSelect;
    property BrushPattern: TJvBrushPattern read FBrushPattern write SetBrushPattern;
    property RightClickSelect: Boolean read FRightClickSelect write SetRightClickSelect default False;
  end;

  TJvItemViewerOptionsClass = class of TJvCustomItemViewerOptions;

  TJvViewerItem = class(TPersistent)
  private
    FOwner: TJvCustomItemViewer;
    FData: Pointer;
    FState: TCustomDrawState;
    FDeleting: Boolean;
    FHint: string;
    procedure SetData(const Value: Pointer);
    procedure SetState(const Value: TCustomDrawState);
  protected
    function Changing: Boolean; virtual;
    procedure Changed; virtual;
    procedure ReduceMemoryUsage; virtual;
  public
    constructor Create(AOwner: TJvCustomItemViewer); virtual;
    procedure Delete;
  protected
    property Deleting: Boolean read FDeleting;
    property Owner: TJvCustomItemViewer read FOwner;
  public
    property State: TCustomDrawState read FState write SetState;
    property Hint: string read FHint write FHint;
    property Data: Pointer read FData write SetData;
  end;

  TJvViewerItemClass = class of TJvViewerItem;

  // TODO
  TJvViewerDrawStage = (vdsBeforePaint, vdsAfterPaint);
  TJvViewerAdvancedDrawEvent = procedure(Sender: TObject; Stage: TJvViewerDrawStage;
    Canvas: TCanvas; R: TRect; var DefaultDraw: Boolean) of object;
  TJvViewerAdvancedItemDrawEvent = procedure(Sender: TObject; Stage: TJvViewerDrawStage;
    Index: Integer; State: TCustomDrawState; Canvas: TCanvas; ItemRect, TextRect: TRect;
    var DefaultDraw: Boolean) of object;

  TJvViewerItemDrawEvent = procedure(Sender: TObject; Index: Integer; State: TCustomDrawState;
    Canvas: TCanvas; ItemRect, TextRect: TRect) of object;
  TJvViewerItemChangingEvent = procedure(Sender: TObject; Item: TJvViewerItem; var Allow: Boolean) of object;
  TJvViewerItemChangedEvent = procedure(Sender: TObject; Item: TJvViewerItem) of object;
  TJvViewerItemHintEvent = procedure(Sender: TObject; Index: Integer;
    var HintInfo: THintInfo; var Handled: Boolean) of object;

  TJvCustomItemViewer = class(TJvExScrollingWinControl)
  private
    FCanvas: TCanvas;
    FItems: TList;
    FOptions: TJvCustomItemViewerOptions;
    FTopLeft: TPoint;
    FItemSize: TSize;
    FOnDrawItem: TJvViewerItemDrawEvent;
    FDragImages: TDragImageList;
    FUpdateCount, FCols, FRows, FTempSelected, FSelectedIndex, FLastHotTrack: Integer;
    FBorderStyle: TBorderStyle;
    FTopLeftIndex: Integer;
    FBottomRightIndex: Integer;
    FOnScroll: TNotifyEvent;
    FOnOptionsChanged: TNotifyEvent;
    FOnItemChanged: TJvViewerItemChangedEvent;
    FOnItemChanging: TJvViewerItemChangingEvent;
    FScrollTimer: TTimer;
    ScrollEdge: Integer;
    FOnDeletion: TJvViewerItemChangedEvent;
    FOnInsertion: TJvViewerItemChangedEvent;
    FOnItemHint: TJvViewerItemHintEvent;
    procedure DoScrollTimer(Sender: TObject);

    procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
    procedure WMNCPaint(var Messages: TWMNCPaint); message WM_NCPAINT;
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
    procedure WMNCHitTest(var Msg: TMessage); message WM_NCHITTEST;
    procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE;

    procedure CMUnselectItem(var Msg: TMessage); message CM_UNSELECTITEMS;
    procedure CMDeleteItem(var Msg: TMessage); message CM_DELETEITEM;
    procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;

    procedure SetOptions(const Value: TJvCustomItemViewerOptions);
    function GetItems(Index: Integer): TJvViewerItem;
    procedure SetItems(Index: Integer; const Value: TJvViewerItem);
    procedure SetSelectedIndex(const Value: Integer);
    procedure SetBorderStyle(const Value: TBorderStyle);
    function GetCount: Integer;
    procedure SetCount(const Value: Integer);
    function GetSelected(Item: TJvViewerItem): Boolean;
    procedure SetSelected(Item: TJvViewerItem; const Value: Boolean);
    procedure StopScrollTimer;
  protected
    procedure MouseLeave(Control: TControl); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

    procedure GetDlgCode(var Code: TDlgCodes); override;
    procedure BoundsChanged; override;
    procedure FocusSet(Focuseded: HWND); override;

    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override;
    procedure DoEndDrag(Sender: TObject; X, Y: Integer); override;
    procedure DragCanceled; override;

    procedure DoUnSelectItems(ExcludeIndex: Integer);
    procedure ToggleSelection(Index: Integer; SetSelection: Boolean);
    procedure ShiftSelection(Index: Integer; SetSelection: Boolean);
    function FindFirstSelected: Integer;
    function FindLastSelected: Integer;
    procedure UpdateAll;
    procedure UpdateOffset;
    procedure CalcIndices;
    procedure DoReduceMemory;

    procedure CheckHotTrack;
    procedure InvalidateClipRect(R: TRect);
    function ItemRect(Index: Integer; IncludeSpacing: Boolean): TRect;
    function ColRowToIndex(ACol, ARow: Integer): Integer;
    procedure OptionsChanged;
    procedure Changed;

    function GetTextRect(const S: WideString; var ItemRect: TRect): TRect; virtual;
    function GetTextHeight: Integer; virtual;
    function GetDragImages: TDragImageList; override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure IndexToColRow(Index: Integer; var ACol, ARow: Integer);
    procedure DrawItem(Index: Integer; State: TCustomDrawState; Canvas: TCanvas; ItemRect, TextRect: TRect); virtual;
    function GetItemClass: TJvViewerItemClass; virtual;
    function GetOptionsClass: TJvItemViewerOptionsClass; virtual;
    function GetItemState(Index: Integer): TCustomDrawState; virtual;
    procedure Inserted(Item: TJvViewerItem); virtual;
    procedure Deleted(Item: TJvViewerItem); virtual;
    procedure ItemChanging(Item: TJvViewerItem; var AllowChange: Boolean); virtual;
    procedure ItemChanged(Item: TJvViewerItem); virtual;
    function HintShow(var HintInfo: THintInfo): Boolean; override;
    function DoItemHint(Index: Integer; var HintInfo: THintInfo): Boolean; virtual;

    property TopLeftIndex: Integer read FTopLeftIndex;
    property BottomRightIndex: Integer read FBottomRightIndex;
    property UpdateCount: Integer read FUpdateCount;

    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property ParentColor default False;
    property SelectedIndex: Integer read FSelectedIndex write SetSelectedIndex;
    property Selected[Item: TJvViewerItem]: Boolean read GetSelected write SetSelected;
    property Canvas: TCanvas read FCanvas;
    property Options: TJvCustomItemViewerOptions read FOptions write SetOptions;
    property Count: Integer read GetCount write SetCount;
    property Items[Index: Integer]: TJvViewerItem read GetItems write SetItems;
    property ItemSize: TSize read FItemSize;
    property OnDrawItem: TJvViewerItemDrawEvent read FOnDrawItem write FOnDrawItem;
    property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
    property OnOptionsChanged: TNotifyEvent read FOnOptionsChanged write FOnOptionsChanged;
    property OnItemChanging: TJvViewerItemChangingEvent read FOnItemChanging write FOnItemChanging;
    property OnItemChanged: TJvViewerItemChangedEvent read FOnItemChanged write FOnItemChanged;
    property OnInsertion: TJvViewerItemChangedEvent read FOnInsertion write FOnInsertion;
    property OnDeletion: TJvViewerItemChangedEvent read FOnDeletion write FOnDeletion;
    property OnItemHint: TJvViewerItemHintEvent read FOnItemHint write FOnItemHint;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ScrollBy(DeltaX, DeltaY: Integer);
    procedure ScrollIntoView(Index: Integer);
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure SelectAll;
    procedure SelectItems(StartIndex, EndIndex: Integer; AppendSelection: Boolean);
    procedure UnselectItems(StartIndex, EndIndex: Integer);
    procedure Clear;
    function Add(AItem: TJvViewerItem): Integer;
    procedure Insert(Index: Integer; AItem: TJvViewerItem);
    procedure Delete(Index: Integer);
    function IndexOf(Item: TJvViewerItem): Integer;
    function ItemAtPos(X, Y: Integer; Existing: Boolean): Integer; virtual;
  end;

// Creates a 8x8 brush pattern with alternate odd and even colors
// If the pattern already exists, no new pattern is created. Instead, the previous pattern is resued.
// NB! Do *not* free the returned TBitmap! It is freed when the unit is finalized or when ClearBrushPatterns
// is called
function CreateBrushPattern(const EvenColor: TColor = clWhite; const OddColor: TColor = clBtnFace): TBitmap;
// Decrements the reference count for a particular brush pattern. When the ref
// count reaches 0, the pattern is released
procedure ReleasePattern(EvenColor, OddColor: TColor);

// Clears the internal list of brush patterns.
// You don't have to call this procedure unless your program uses a lot of brush patterns
// that are only used short times
procedure ClearBrushPatterns;

function ViewerDrawText(Canvas: TCanvas; S: WideString; aLength: Integer;
  var R: TRect; Format: Cardinal; Alignment: TAlignment; Layout: TTextLayout; WordWrap: Boolean): Integer;
function CenterRect(InnerRect, OuterRect: TRect): TRect;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvCustomItemViewer.pas,v $';
    Revision: '$Revision: 1.41 $';
    Date: '$Date: 2005/02/18 14:17:23 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  SysUtils, Math,
  JvJCLUtils, JvJVCLUtils, JvThemes;

const
  cScrollDelay = 400;
  cScrollIntervall = 30;

type
  TScrollEdge = (seNone, seLeft, seTop, seRight, seBottom);
  TColorPattern = record
    EvenColor: TColor;
    OddColor: TColor;
    UsageCount: Integer;
    Bitmap: TBitmap;
  end;

  TViewerDrawImageList = class(TDragImageList)
  protected
    procedure Initialize; override;
  end;

var
  GlobalPatterns: array of TColorPattern = nil;
  FirstGlobalPatterns: Boolean = True;

procedure ReleasePattern(EvenColor, OddColor: TColor);
var
  I: Integer;
begin
  for I := 0 to Length(GlobalPatterns) - 1 do
    if (GlobalPatterns[I].EvenColor = EvenColor) and (GlobalPatterns[I].OddColor = OddColor) then
    begin
      if GlobalPatterns[I].UsageCount > 0 then
        Dec(GlobalPatterns[I].UsageCount);
      if GlobalPatterns[I].UsageCount = 0 then
        FreeAndNil(GlobalPatterns[I].Bitmap);
      Break;
    end;
end;

procedure ClearBrushPatterns;
var
  I: Integer;
begin
  for I := 0 to Length(GlobalPatterns) - 1 do
    GlobalPatterns[I].Bitmap.Free;
  SetLength(GlobalPatterns, 0);
end;

function CreateBrushPattern(const EvenColor: TColor = clWhite; const OddColor: TColor = clBtnFace):
  TBitmap;
var
  I, X, Y: Integer;
  Found: Boolean;
begin
  Found := False;
  Result := nil;
  for I := 0 to Length(GlobalPatterns) - 1 do
    if (GlobalPatterns[I].EvenColor = EvenColor) and (GlobalPatterns[I].OddColor = OddColor) then
    begin
      Result := GlobalPatterns[I].Bitmap;
      Found := True;
      Break;
    end;

  if not Found then
  begin
    I := Length(GlobalPatterns);
    if FirstGlobalPatterns then
      FirstGlobalPatterns := False;
    SetLength(GlobalPatterns, I + 1);
  end;
  if Result = nil then
  begin
    Result := TBitmap.Create;
    Result.Dormant; // preserve some DDB handles, use more memory
    Result.Width := 8; { must have this size }
    Result.Height := 8;
    with Result.Canvas do
    begin
      Brush.Style := bsSolid;
      Brush.Color := EvenColor;
      FillRect(Rect(0, 0, Result.Width, Result.Height));
      for Y := 0 to 7 do
        for X := 0 to 7 do
          if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }
            Pixels[X, Y] := OddColor; { on even/odd rows }
    end;
    GlobalPatterns[I].EvenColor := EvenColor;
    GlobalPatterns[I].OddColor := OddColor;
    GlobalPatterns[I].Bitmap := Result;
  end;
  Inc(GlobalPatterns[I].UsageCount);
end;

function ViewerDrawText(Canvas: TCanvas; S: WideString; aLength: Integer;
  var R: TRect; Format: Cardinal; Alignment: TAlignment; Layout: TTextLayout; WordWrap: Boolean): Integer;
const
  Alignments: array [TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);
  Layouts: array [TTextLayout] of Cardinal = (DT_TOP, DT_VCENTER, DT_BOTTOM);
  WordWraps: array [Boolean] of Cardinal = (DT_SINGLELINE, DT_WORDBREAK);
var
  Flags: Cardinal;
begin
  Flags := Format or Alignments[Alignment] or Layouts[Layout] or WordWraps[WordWrap];
  // (p3) Do we need BiDi support here?
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    Result := DrawTextW(Canvas, PWideChar(S), aLength, R, Flags)
  else
    Result := DrawText(Canvas, PChar(string(S)), aLength, R, Flags);
end;

function CenterRect(InnerRect, OuterRect: TRect): TRect;
begin
  OffsetRect(InnerRect, -InnerRect.Left + OuterRect.Left + (RectWidth(OuterRect) - RectWidth(InnerRect)) div 2,
    -InnerRect.Top + OuterRect.Top + (RectHeight(OuterRect) - RectHeight(InnerRect)) div 2);
  Result := InnerRect;
end;

//=== { TJvBrushPattern } ====================================================

constructor TJvBrushPattern.Create;
begin
  inherited Create;
  FEvenColor := clWhite;
  FOddColor := clSkyBlue;
  FActive := True;
end;

destructor TJvBrushPattern.Destroy;
begin
  if FPattern <> nil then
    ReleasePattern(EvenColor, OddColor);
  FPattern := nil;
  inherited Destroy;
end;

function TJvBrushPattern.GetBitmap: TBitmap;
begin
  if Active then
  begin
    if FPattern = nil then
      FPattern := CreateBrushPattern(EvenColor, OddColor);
  end
  else
  begin
    if FPattern <> nil then
      ReleasePattern(EvenColor, OddColor);