aligndemo.pas

来自「本系统前端界面采用WINDOWS 窗口风格」· PAS 代码 · 共 615 行 · 第 1/2 页

unit AlignDemo;

// Virtual Treeview sample form demonstrating following features:
//   - Header with images and different glyph and column alignment.
//   - Header popup with images.
//   - Multilingual treeview with english, greek, hebrew and arabic texts.
//   - Interaction between column alignment and column directionality (bidi).
// Written by Mike Lischke.

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, VirtualTrees, ComCtrls, ExtCtrls, ImgList, Menus;

type
  TAlignForm = class(TForm)
    AlignTree: TVirtualStringTree;
    Label8: TLabel;
    TreeImages: TImageList;
    HeaderImages: TImageList;
    IconPopup: TPopupMenu;
    Label1: TLabel;
    AlignCombo0: TComboBox;
    Label2: TLabel;
    Label3: TLabel;
    AlignCombo1: TComboBox;
    Label4: TLabel;
    AlignCombo2: TComboBox;
    BidiGroup0: TRadioGroup;
    BidiGroup1: TRadioGroup;
    BidiGroup2: TRadioGroup;
    GroupBox1: TGroupBox;
    ShowGlyphsOptionBox: TCheckBox;
    HotTrackOptionBox: TCheckBox;
    ShowTextOptionBox: TCheckBox;
    VisibleOptionBox: TCheckBox;
    EnabledOptionBox: TCheckBox;
    Label5: TLabel;
    LayoutCombo: TComboBox;
    procedure AlignTreeGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
      var Ghosted: Boolean; var Index: Integer);
    procedure AlignTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
      var Text: WideString);
    procedure AlignTreePaintText(Sender: TBaseVirtualTree; const Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
      TextType: TVSTTextType);
    procedure AlignTreeGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer);
    procedure AlignTreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
      var InitialStates: TVirtualNodeInitStates);
    procedure AlignTreeInitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure IconPopupPopup(Sender: TObject);
    procedure AlignComboChange(Sender: TObject);
    procedure BidiGroupClick(Sender: TObject);
    procedure AlignTreeHeaderClick(Sender: TVTHeader; Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer);
    procedure OptionBoxClick(Sender: TObject);
    procedure LayoutComboChange(Sender: TObject);
    procedure AlignTreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);
    procedure AlignTreeStateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates);
  private
    FArabicFont,
    FHebrewFont: TFont;
    procedure ChangeHeaderText;
    procedure MeasureIconItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
    procedure MenuItemClick(Sender: TObject);
  end;

var
  AlignForm: TAlignForm;

//----------------------------------------------------------------------------------------------------------------------

implementation

uses
  Main, States;
  
{$R *.DFM}

//----------------------------------------------------------------------------------------------------------------------

const
  DefaultHintColumn0 = 'Text is initially centered and has a left-to-right directionality.';
  DefaultHintColumn1 = 'Text is initially left aligned and has a left-to-right directionality.';
  DefaultHintColumn2 = 'Text is initially left aligned and has a right-to-left directionality.';
  CommonHeaderHint = 'Right click to pick a column glyph. Left click to switch sort glyph (no sorting is performed).';

type
  PAlignData = ^TAlignData;
  TAlignData = record
    MainColumnText,
    GreekText,
    RTLText: WideString;
    ImageIndex: Integer;
  end;

// These arrays store some text which is originally displayed right-to-left, so it supports the demonstration of
// alignment even more than normal text. This text will be filled at runtime from a resource file.
// Additionally, some greek text for another column is stored here too just because I like how it looks (the text,
// not the storage ;-)).
var
  GreekStrings: array[0..8] of WideString;
  ArabicStrings: array[0..3] of WideString;
  HebrewStrings: array[0..2] of WideString;

//----------------------------------------------------------------------------------------------------------------------

procedure LoadStrings;

// Helper routine to load Unicode strings from the resource. Putting these strings directly into the
// source code does not work, since Delphi does not support Unicode source code.

begin
  // Take the first arabic string as identification whether we have already loaded the strings or not.
  if Length(ArabicStrings[0]) = 0 then
  begin
    LoadUnicodeStrings('Greek', GreekStrings);
    LoadUnicodeStrings('Arabic', ArabicStrings);
    LoadUnicodeStrings('Hebrew', HebrewStrings);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.AlignTreeGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer);

// Node data size can also be set at design time (if you know the size of the record) or in FormCreate.
// We do it here just because to show this third way too.

begin
  NodeDataSize := SizeOf(TAlignData);
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.AlignTreePaintText(Sender: TBaseVirtualTree; const Canvas: TCanvas; Node: PVirtualNode;
  Column: TColumnIndex; TextType: TVSTTextType);

begin
  // In order to display arabic and hebrew texts with a nice font we have assign one explicitely. Otherwise the
  // system picks one and this often leads to non-ideal results.
  case Column of
    1:
      // Make the second column lighter.
      Canvas.Font.Color := clSilver;
    2:
      begin
        if not Odd(Node.Parent.Index) then
          Canvas.Font := FArabicFont
        else
          Canvas.Font := FHebrewFont;
      end;
  end;

  // Reset the text color for selected and drop target nodes.
  if ((Node = Sender.DropTargetNode) or (vsSelected in Node.States)) and (Column = Sender.FocusedColumn) then
    Canvas.Font.Color := clHighlightText;
  if Node.Parent = Sender.RootNode then
    Canvas.Font.Style := [fsBold];
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.AlignTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
  TextType: TVSTTextType; var Text: WideString);

var
  Data: PAlignData;

begin
  Data := Sender.GetNodeData(Node);
  Text := '';
  case Column of
    0: // left alignd column
      Text := Data.MainColumnText;
    1: // centered column
      Text := Data.GreekText;
    2: // right aligned column
      Text := Data.RTLText;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.AlignTreeGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind;
  Column: TColumnIndex; var Ghosted: Boolean; var Index: Integer);

var
  Data: PAlignData;

begin
  if Kind in [ikNormal, ikSelected] then
  begin
    Data := Sender.GetNodeData(Node);
    Index := Data.ImageIndex;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.AlignTreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
  var InitialStates: TVirtualNodeInitStates);

var
  Data: PAlignData;

begin
  // intialize caption strings
  LoadStrings;

  Data := Sender.GetNodeData(Node);

  Data.ImageIndex := 0;                          
  if ParentNode = nil then
  begin
    with Data^ do
    begin
      if not Odd(Node.Index) then
        MainColumnText := 'Arabic texts'
      else
        MainColumnText := 'Hebrew texts';

      GreekText := GreekStrings[(Node.Index and 1) * 5];
      RTLText := '';
    end;
    InitialStates := InitialStates + [ivsHasChildren, ivsExpanded];
  end
  else
  begin
    if not Odd(ParentNode.Index) then
    begin
      with Data^ do
      begin
        MainColumnText := Format('Arabic text %d', [Node.Index]);
        GreekText := GreekStrings[Node.Index + 1];
        RTLText := ArabicStrings[Node.Index];
      end;
    end
    else
    begin
      with Data^ do
      begin
        MainColumnText := Format('Hebrew text %d', [Node.Index]);
        GreekText := GreekStrings[6 + Node.Index];
        RTLText := HebrewStrings[Node.Index];
      end;
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.AlignTreeInitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal);

begin
  if not Odd(Node.Index) then
    ChildCount := 4 // arabic text
  else
    ChildCount := 3; // hebrew text
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TAlignForm.FormCreate(Sender: TObject);

var
 I: Integer;
 NewItem: TMenuItem;

begin
  // High color image lists look much better.
  ConvertToHighColor(TreeImages);
  ConvertToHighColor(HeaderImages);

  // To display the various texts in a nice manner we use some specialized fonts of the system.
  // We could directly assign the font names used here in the OnPaintText event, but since this
  // would then be the only reference for the font it would cause the font to be recreated every
  // time it is used (a font is reference counted in Graphics.pas). In order to avoid this overhead
  // it is better to create the fonts once and for all.
  // Note: if the fonts used here are not installed on the target system then the font mapper of Windows
  //       will pick similar fonts which are capable of rendering the required glyphs (however Arial and Times New Roman
  //       should be available on any Windows system).
  FArabicFont := TFont.Create;
  with FArabicFont do
  begin
    if Screen.Fonts.IndexOf('Traditional Arabic') > -1 then
    begin
      Name := 'Traditional Arabic';
      Size := 20;
    end
    else
    begin
      Name := 'Arial';
      Size := 14;
    end;
    Color := $FF6B43;
    if Handle = 0 then
      Beep;
  end;
  FHebrewFont := TFont.Create;
  with FHebrewFont do
  begin
    Name := 'Times New Roman';
    Size := 14;
    Color := $436BFF;
  end;