fctreeheader.pas

一套及时通讯的原码

unit fcTreeHeader;

interface
{$R-}
{$include fcifdef.pas}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, db, extctrls;

type

  TfcTreeHeader = class;
  TfcTreeHeaderControl = class;
  TfcTreeHeaderOption = (thcoAllowColumnMove, thcoSortTreeOnClick, thcoRightBorder);
  TfcTreeHeaderOptions = set of TfcTreeHeaderOption;

  TfcTreeHeaderSection = class(TCollectionItem)
  private
    FFieldName: string;
    FImageIndex: integer;
    FImageAlignment : TAlignment;

    FText: string;
    FWidth: Integer;
    FMinWidth: Integer;
    FMaxWidth: Integer;
    FAlignment: TAlignment;
    FStyle: THeaderSectionStyle;
    FAllowClick: Boolean;

    function GetLeft: Integer;
    function GetRight: Integer;
    procedure SetAlignment(Value: TAlignment);
    procedure SetMaxWidth(Value: Integer);
    procedure SetMinWidth(Value: Integer);
    procedure SetStyle(Value: THeaderSectionStyle);
    procedure SetText(const Value: string);
    procedure SetWidth(Value: Integer);
    procedure SetImageIndex(Value: integer);
    procedure SetImageAlignment(Value: TAlignment);
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property Left: Integer read GetLeft;
    property Right: Integer read GetRight;
    function PtInSection(pt: TPoint): boolean;
  published
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property AllowClick: Boolean read FAllowClick write FAllowClick default True;
    property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000;
    property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
    property Style: THeaderSectionStyle read FStyle write SetStyle default hsText;
    property Text: string read FText write SetText;
    property Width: Integer read FWidth write SetWidth;
    property FieldName: string read FFieldName write FFieldName;
    property ImageIndex: integer read FImageIndex write SetImageIndex;
    property ImageAlignment: TAlignment read FImageAlignment write SetImageAlignment default taLeftJustify;
  end;

  TfcTreeHeaderSections = class(TCollection)
  private
    function GetItem(Index: Integer): TfcTreeHeaderSection;
    procedure SetItem(Index: Integer; Value: TfcTreeHeaderSection);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    HeaderControl: TfcTreeHeaderControl;
    constructor Create(HeaderControl: TfcTreeHeaderControl);
    function Add: TfcTreeHeaderSection;
    property Items[Index: Integer]: TfcTreeHeaderSection read GetItem write SetItem; default;
  end;

  TfcHeaderDrawSectionEvent = procedure(HeaderControl: TfcTreeHeader;
    Section: TfcTreeHeaderSection; const Rect: TRect; Pressed: Boolean) of object;
  TfcHeaderSectionNotifyEvent = procedure(HeaderControl: TfcTreeHeader;
    Section: TfcTreeHeaderSection) of object;
  TfcHeaderSectionDefaultEvent = procedure(HeaderControl: TfcTreeHeader;
    Section: TfcTreeHeaderSection; var doDefault: boolean) of object;
  TfcHeaderSectionTrackEvent = procedure(HeaderControl: TfcTreeHeader;
    Section: TfcTreeHeaderSection; Width: Integer;
    State: TSectionTrackState) of object;
  TfcSectionDragEvent = procedure (Sender: TObject; FromSection, ToSection: TfcTreeHeaderSection) of object;
  TfcHeaderSectionMoveEvent = procedure(HeaderControl: TfcTreeHeader;
    Section: TfcTreeHeaderSection; DragFrom, DragTo: integer;
    var AllowMove: boolean) of object;

  TfcTreeHeaderControl = class(TWinControl)
  private
    FSections: TfcTreeHeaderSections;
    FSectionDragged: Boolean;
    FCanvas: TCanvas;
    FHotTrack: Boolean;

    FImageList: TImageList;
    FOptions: TfcTreeHeaderOptions;
    FTree: TWinControl; //fcDBCustomTreeView;
    FHeader: TfcTreeHeader;

    function  DoSectionDrag(FromSection, ToSection: TfcTreeHeaderSection): Boolean;
    procedure SetHotTrack(Value: Boolean);
    procedure SetSections(Value: TfcTreeHeaderSections);
    procedure UpdateItem(Message, Index: Integer);
    procedure UpdateSection(Index: Integer);
    procedure UpdateSections;
    procedure SetOptions(val: TfcTreeHeaderOptions);
    procedure SetImageList(val: TImageList);

    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

  protected
    procedure RearrangeTreeColumns; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure WndProc(var Message: TMessage); override;
  public
    DesignerForm: TCustomForm;
    HotTrackSection: integer;

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read FCanvas;
    property Tree: TWinControl read FTree write FTree;
    property Header: TfcTreeHeader read FHeader write FHeader;
    property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
    property Images: TImageList read FImageList write SetImageList;
    property Options: TfcTreeHeaderOptions read FOptions write SetOptions
       default [thcoAllowColumnMove, thcoSortTreeOnClick, thcoRightBorder];
    property Sections: TfcTreeHeaderSections read FSections write SetSections;
  end;

  TfcTreeHeader = class(TCustomPanel)
  private
    FOnDrawSection: TfcHeaderDrawSectionEvent;
    FOnResize: TNotifyEvent;
    FOnSectionMove: TfcHeaderSectionMoveEvent;
    FOnSectionClick: TfcHeaderSectionNotifyEvent;
    FOnSectionResize: TfcHeaderSectionNotifyEvent;
    FOnSectionTrack: TfcHeaderSectionTrackEvent;
    FOnSectionDrag: TfcSectionDragEvent;
    FDisableThemes: boolean;

    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

    procedure SetSections(Value: TfcTreeHeaderSections);
    function GetSections: TfcTreeHeaderSections;
    function GetHotTrack: boolean;
    procedure SetHotTrack(Value: Boolean);
    function GetImageList: TImageList;
    procedure SetImageList(Value: TImageList);
    procedure SetOptions(val: TfcTreeHeaderOptions);
    function GetOptions: TfcTreeHeaderOptions;
    function GetCanvas: TCanvas;
    function GetTree: TWinControl;
    Function GetMouseDown: TMouseEvent;
    procedure SetMouseDown(Value: TMouseEvent);
    Function GetMouseUp: TMouseEvent;
    procedure SetMouseUp(Value: TMouseEvent);
    Function GetMouseMove: TMouseMoveEvent;
    procedure SetMouseMove(Value: TMouseMoveEvent);
  protected
    procedure DrawSection(Section: TfcTreeHeaderSection; const Rect: TRect;
       Pressed: Boolean); dynamic;
    procedure SectionMove(Section: TfcTreeHeaderSection;
              DragFrom, DragTo: integer; var AllowMove: boolean); dynamic;
    procedure SectionClick(Section: TfcTreeHeaderSection); dynamic;
    procedure SectionResize(Section: TfcTreeHeaderSection); dynamic;
    procedure SectionTrack(Section: TfcTreeHeaderSection; Width: Integer;
      State: TSectionTrackState); dynamic;
    procedure SectionDrag(FromSection, ToSection: TfcTreeHeaderSection); dynamic;
  public
    HeaderControl: TfcTreeHeaderControl;

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CreateWnd; override;

    property Canvas: TCanvas read GetCanvas;
    property Tree: TWinControl read GetTree;

  published
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;
    property Sections: TfcTreeHeaderSections read GetSections write SetSections;
    property ShowHint;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property Visible;
    property Images: TImageList read GetImageList write SetImageList;
    property OnSectionDrag: TfcSectionDragEvent read FOnSectionDrag
      write FOnSectionDrag;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;

    property OnMouseDown: TMouseEvent read GetMouseDown write SetMouseDown;
    property OnMouseMove: TMouseMoveEvent read GetMouseMove write SetMouseMove;
    property OnMouseUp: TMouseEvent read GetMouseUp write SetMouseUp;
    property OnDrawSection: TfcHeaderDrawSectionEvent read FOnDrawSection write FOnDrawSection;
    property OnResize: TNotifyEvent read FOnResize write FOnResize;
    property OnSectionMove: TfcHeaderSectionMoveEvent read FOnSectionMove write FOnSectionMove;
    property OnSectionClick: TfcHeaderSectionNotifyEvent read FOnSectionClick write FOnSectionClick;
    property OnSectionResize: TfcHeaderSectionNotifyEvent read FOnSectionResize write FOnSectionResize;
    property OnSectionTrack: TfcHeaderSectionTrackEvent read FOnSectionTrack write FOnSectionTrack;
    property OnStartDrag;
    property Options: TfcTreeHeaderOptions read GetOptions write SetOptions
       default [thcoAllowColumnMove, thcoSortTreeOnClick, thcoRightBorder];
    property DisableThemes : boolean read FDisableThemes write FDisableThemes default False;

  end;

implementation

uses commctrl, typinfo, fccommon,
  {$ifdef fcDelphi7Up}
  themes,
  {$endif}
  {$ifdef ThemeManager}
  thememgr, themesrv, uxtheme,
  {$endif}
  fcdbtreeview;
  
type
  TfcWriteTextOption = (wtoAmpersandToUnderline, wtoEllipsis, wtoWordWrap, wtoMergeCanvas);
  TfcWriteTextOptions = Set of TfcWriteTextOption;


{3/31/98 - Determine if this is a single line edit control based on passed in rectangle}
Function wwIsSingleLineEdit(AHandle:Integer; Rect: TRect; Flags:Integer): boolean;
var OrigEditHeight,SingleLineEditHeight:Integer;
    S:String;
begin
  Flags := Flags or DT_CALCRECT;

  OrigEditHeight := Rect.Bottom-Rect.Top;

  S:=' ';
  SingleLineEditHeight := DrawText(AHandle,PChar(S),strlen(PChar(S)),Rect,Flags)+
    3 + GetSystemMetrics(SM_CYBORDER) * 2;

  result := OrigEditHeight <= SingleLineEditHeight;
end;

Procedure WriteTextLines(ACanvas: TCanvas;
    const ARect: TRect; DX, DY: Integer; S: PChar; Alignment: TAlignment;
    WriteOptions: TfcWriteTextOptions);
const
  AlignFlags : array [TAlignment] of Integer =
    ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS,
      DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS,
      DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS);
var
  R: TRect;
  Flags: integer;
  ADrawCanvas: TCanvas;
begin
    ADrawCanvas:= ACanvas;

    with ARect do { Use offscreen bitmap to eliminate flicker and }
    begin                     { brush origin tics in painting / scrolling.    }
      if Alignment=taRightJustify then
         R := Rect(1, DY, Right - Left - 5, Bottom - Top - 1)
      else if Alignment=taLeftJustify then
         R := Rect(DX, DY, Right - Left, Bottom - Top - 1)
      else
         R := Rect(0, DY, Right - Left, Bottom - Top - 1);
      R.Left:= R.Left + ARect.Left;
      R.Right:= R.Right + ARect.Left;
//      B := Rect(0, 0, Right - Left, Bottom - Top);
    end;

    with ADrawCanvas do
    begin
      Font := ACanvas.Font;
      Font.Color := ACanvas.Font.Color;
      Brush := ACanvas.Brush;
      Brush.Style := bsSolid;

      {$ifdef fcUseThemeManager}
      if not ThemeServices.ThemesEnabled then
      {$endif}
         FillRect(ARect);

      SetBkMode(Handle, TRANSPARENT);
      Flags:= AlignFlags[Alignment];
      if not (wtoAmpersandToUnderline in WriteOptions) then
         Flags:= Flags or DT_NOPREFIX;

      {3/31/98 - Check to see if this is a single line edit control to
       determine if we should or should not have word breaks}
      if wwIsSingleLineEdit(Handle,R,Flags) or (wtoEllipsis in WriteOptions) then
         Flags := Flags and not DT_WORDBREAK;

      if wtoEllipsis in WriteOptions then
         Flags:= Flags or DT_END_ELLIPSIS;  { If text does not fit then put ellipsis at end }
      DrawText(Handle, S, StrLen(S), R, Flags);
    end;
end;


constructor TfcTreeHeaderSection.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FWidth := 50;
  FMaxWidth := 10000;
  FAllowClick := True;
  FImageIndex:= -1;
  FImageAlignment:= taLeftJustify;
end;

procedure TfcTreeHeaderSection.Assign(Source: TPersistent);
begin
  if Source is TfcTreeHeaderSection then
  begin
    Text := TfcTreeHeaderSection(Source).Text;
    Width := TfcTreeHeaderSection(Source).Width;
    MinWidth := TfcTreeHeaderSection(Source).MinWidth;
    MaxWidth := TfcTreeHeaderSection(Source).MaxWidth;
    Alignment := TfcTreeHeaderSection(Source).Alignment;
    Style := TfcTreeHeaderSection(Source).Style;
    AllowClick := TfcTreeHeaderSection(Source).AllowClick;
    FieldName:= TfcTreeHeaderSection(Source).FieldName;
    Exit;
  end;
  inherited Assign(Source);
end;

function TfcTreeHeaderSection.GetDisplayName: string;
var TempText: string;
begin
  if Text = '' then TempText:= inherited GetDisplayName
  else TempText:= text;
  Result := inttostr(Index) + ' - ' + TempText;
end;

function TfcTreeHeaderSection.GetLeft: Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to Index - 1 do
    Inc(Result, TfcTreeHeaderSections(Collection)[I].Width);
end;

function TfcTreeHeaderSection.PtInSection(pt: TPoint): boolean;
var
  I: Integer;
  StartX, EndX: integer;
begin
  StartX := 0;
  for I := 0 to Index - 1 do
    Inc(StartX, TfcTreeHeaderSections(Collection)[I].Width);
  EndX:= StartX + TfcTreeHeaderSections(Collection)[Index].Width;
  result:= (pt.x>StartX) and (pt.x<EndX);
end;

function TfcTreeHeaderSection.GetRight: Integer;
begin
  Result := Left + Width;
end;

procedure TfcTreeHeaderSection.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    Changed(False);
  end;
end;

procedure TfcTreeHeaderSection.SetMaxWidth(Value: Integer);
begin
  if Value < FMinWidth then Value := FMinWidth;
  if Value > 10000 then Value := 10000;
  FMaxWidth := Value;
  SetWidth(FWidth);
end;

procedure TfcTreeHeaderSection.SetMinWidth(Value: Integer);
begin
  if Value < 0 then Value := 0;