drawtreedemo.pas

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

unit DrawTreeDemo;

// Virtual Treeview sample form demonstrating following features:
//   - General use of TVirtualDrawTree.
//   - Use of vertical node image alignment.
//   - Effective use of node initialization on demand to load images.
// Written by Mike Lischke.
//
// Note: define the symbol "GraphicEx" if you have my GraphicEx library
// available (see http://www.delphi-gems.com) which allows to load
// more image formats into the application.
// Otherwise disable the conditional symbol to compile this demo.

{.$define GraphicEx}

{$ifdef VER140}
  {$define RemoveWarnings}
{$endif VER140}
{$ifdef VER150}
  {$define RemoveWarnings}
{$endif VER150}

{$ifdef RemoveWarnings}
  // We do not need warnings for platform specific stuff.
  {$warn UNIT_PLATFORM OFF}
  {$warn SYMBOL_PLATFORM OFF}
{$endif}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VirtualTrees, StdCtrls, {$ifdef GraphicEx} GraphicEx, {$else} JPEG, {$endif}
  ImgList, ComCtrls;

type
  TDrawTreeForm = class(TForm)
    VDT1: TVirtualDrawTree;
    Label7: TLabel;
    SystemImages: TImageList;
    Label1: TLabel;
    TrackBar1: TTrackBar;
    Label3: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure VDT1CompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex;
      var Result: Integer);
    procedure VDT1DrawHint(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex);
    procedure VDT1DrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo);
    procedure VDT1FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
    procedure VDT1GetHintSize(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var R: TRect);
    procedure VDT1GetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
      var Ghosted: Boolean; var Index: Integer);
    procedure VDT1GetNodeWidth(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
      var NodeWidth: Integer);
    procedure VDT1HeaderClick(Sender: TVTHeader; Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer);
    procedure VDT1InitChildren(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal);
    procedure VDT1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
      var InitialStates: TVirtualNodeInitStates);
    procedure TrackBar1Change(Sender: TObject);
    procedure VDT1StateChange(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates);
  private
    FThumbSize: Integer;
    FExtensionsInitialized: Boolean;
    FExtensionList: TStringList;
    FDriveStrings: string;
    function CanDisplay(const Name: String): Boolean;
    function GetDriveString(Index: Integer): string;
    function ReadAttributes(const Name: WideString): Cardinal;
    procedure RescaleImage(Source, Target: TBitmap);
  end;

var
  DrawTreeForm: TDrawTreeForm;

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

implementation

uses
  FileCtrl, ShellAPI, Mask, ShlObj, ActiveX, States;

{$R *.DFM}

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

type
  // This data record contains all necessary information about a particular file system object.
  // This can either be a folder (virtual or real) or an image file.
  PShellObjectData = ^TShellObjectData;
  TShellObjectData = record
    FullPath,
    Display: WideString;
    Attributes: Cardinal;
    OpenIndex,
    CloseIndex: Integer;      // image indices into the system image list
    Image: TBitmap;
    Properties: WideString;   // some image properties, preformatted
  end;

//----------------- utility functions ----------------------------------------------------------------------------------

function IncludeTrailingBackslash(const S: string): string;

begin
  if not IsPathDelimiter(S, Length(S)) then
    Result := S + '\'
  else
    Result := S;
end;

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

function ExcludeTrailingBackslash(const S: string): string;

begin
  Result := S;
  if IsPathDelimiter(Result, Length(Result)) then
    SetLength(Result, Length(Result) - 1);
end;

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

function HasChildren(const Folder: string): Boolean;

// Determines whether folder contains other file objects.

var
  SR: TSearchRec;

begin
  Result := FindFirst(IncludeTrailingBackslash(Folder) + '*.*', faReadOnly or faHidden or faSysFile or faArchive, SR) = 0;
  if Result then
    FindClose(SR);
end;

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

function GetIconIndex(Name: string; Flags: Cardinal): Integer;

// Returns the index of the system icon for the given file object.

var
  SFI: TSHFileInfo;

begin
  if SHGetFileInfo(PChar(Name), 0, SFI, SizeOf(TSHFileInfo), Flags) = 0 then
    Result := -1
  else
    Result := SFI.iIcon;
end;

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

procedure GetOpenAndClosedIcons(Name: string; var Open, Closed: Integer);

begin
  Closed := GetIconIndex(Name, SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  Open := GetIconIndex(Name, SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_OPENICON);
end;

//----------------- TDrawTreeForm --------------------------------------------------------------------------------------

procedure TDrawTreeForm.FormCreate(Sender: TObject);

var
  SFI: TSHFileInfo;
  I,
  Count: Integer;
  DriveMap,
  Mask: Cardinal;

begin
  VDT1.NodeDataSize := SizeOf(TShellObjectData);

  // Fill root level of image tree. Determine which drives are mapped.
  Count := 0;
  DriveMap := GetLogicalDrives;
  Mask := 1;
  for I := 0 to 25 do
  begin
    if (DriveMap and Mask) <> 0 then
      Inc(Count);
    Mask := Mask shl 1;
  end;
  VDT1.RootNodeCount := Count;
  // Determine drive strings which are used in the initialization process.
  Count := GetLogicalDriveStrings(0, nil);
  SetLength(FDriveStrings, Count);
  GetLogicalDriveStrings(Count, PChar(FDriveStrings));
  
  SystemImages.Handle := SHGetFileInfo('', 0, SFI, SizeOf(SFI), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  SystemImages.ShareImages := True;

  FThumbSize := 100;
end;

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

function TDrawTreeForm.CanDisplay(const Name: string): Boolean;

// Determines whether the given file is one we can display in the image tree.

var
  Ext: string;
  I: Integer;
  
begin
  if not FExtensionsInitialized then
  begin
    FExtensionsInitialized := True;
    FExtensionList := TStringList.Create;
    {$ifdef GraphicEx}
      FileFormatList.GetExtensionList(FExtensionList);
      for I := 0 to FExtensionList.Count - 1 do
        FExtensionList[I] := '.' + FExtensionList[I];
    {$else}
    // GraphicEx is not used so add some default extensions
    with FExtensionList do
    begin
      Add('.bmp');
      Add('.ico');
      Add('.jpg');
      Add('.jpeg');
      Add('.wmf');
      Add('.emf');
    end;
    {$endif}
    FExtensionList.Sort;
  end;

  Ext := ExtractFileExt(Name);
  Result := FExtensionList.Find(Ext, I);
end;

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

function TDrawTreeForm.GetDriveString(Index: Integer): string;

// Helper method to extract a sub string (given by Index) from FDriveStrings.

var
  Head, Tail: PChar;

begin
  Head := PChar(FDriveStrings);
  Result := '';
  repeat
    Tail := Head;
    while Tail^ <> #0 do
      Inc(Tail);
    if Index = 0 then
    begin
      SetString(Result, Head, Tail - Head);
      Break;
    end;
    Dec(Index);
    Head := Tail + 1;
  until Head^ = #0;
end;

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

function TDrawTreeForm.ReadAttributes(const Name: WideString): Cardinal;

// Determines the attributes of the given shell object (file, folder).

const
  SFGAO_CONTENTSMASK = $F0000000; // This value is wrongly defined in ShlObj.

var
  Desktop: IShellFolder;
  Eaten: Cardinal;
  PIDL: PItemIDList;
  Malloc: IMalloc;

begin
  // Get the root folder of the shell name space.
  SHGetDesktopFolder(Desktop);
  // While parsing the name also the shell object's attributes are determined.
  // These is what we are really interested in.
  Result := SFGAO_DISPLAYATTRMASK or SFGAO_CONTENTSMASK or SFGAO_COMPRESSED;
  Desktop.ParseDisplayName(0, nil, PWideChar(Name), Eaten, PIDL, Result);
  // Don't forget to free the returned PIDL. The shell folder is released automatically.
  SHGetMalloc(Malloc);
  Malloc.Free(PIDL);
end;

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

procedure TDrawTreeForm.RescaleImage(Source, Target: TBitmap);

// if source is in at least one dimension larger than the thumb size then
// rescale source but keep aspect ratio

var
  NewWidth,
  NewHeight: Integer;
begin
  if (Source.Width > FThumbSize) or (Source.Height > FThumbSize) then
  begin
    if Source.Width > Source.Height then
    begin
      NewWidth := FThumbSize;
      NewHeight := Round(FThumbSize * Source.Height / Source.Width);
    end
    else
    begin
      NewHeight := FThumbSize;
      NewWidth := Round(FThumbSize * Source.Width / Source.Height);
    end;

    Target.Width := NewWidth;
    Target.Height := NewHeight;
    SetStretchBltMode(Target.Canvas.Handle, HALFTONE);
    StretchBlt(Target.Canvas.Handle, 0, 0, NewWidth, NewHeight,
      Source.Canvas.Handle, 0, 0, Source.Width, Source.Height, SRCCOPY);
  end
  else
    Target.Assign(Source);
end;

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

procedure TDrawTreeForm.VDT1InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
  var InitialStates: TVirtualNodeInitStates);

var
  Data: PShellObjectData;
  Picture: TPicture;

begin
  Data := Sender.GetNodeData(Node);
  if ParentNode = nil then
  begin
    // top level node, initialize first enumeration
    Data.FullPath := GetDriveString(Node.Index);
    Data.Display := Data.FullPath;
    GetOpenAndClosedIcons(Data.FullPath, Data.OpenIndex, Data.CloseIndex);
  end
  else
  begin
    Picture := TPicture.Create;
    Data.Display := ExtractFileName(ExcludeTrailingBackslash(Data.FullPath));
    if (Data.Attributes and SFGAO_FOLDER) = 0 then
    try
      try
        Data.Image := TBitmap.Create;
        Picture.LoadFromFile(Data.FullPath);
        if not (Picture.Graphic is TBitmap) then
        begin
          // Some extra steps needed to keep non TBitmap descentants alive when
          // scaling. This is needed because when accessing Picture.Bitmap all
          // non-TBitmap content will simply be erased (definitly the wrong
          // action, but we can't do anything to prevent this). Hence we
          // must explicitly draw the graphic to a bitmap.
          with Data.Image do
          begin
            Width := Picture.Width;
            Height := Picture.Height;
            Canvas.Draw(0, 0, Picture.Graphic);
          end;
          Picture.Bitmap.Assign(Data.Image);
        end;
        RescaleImage(Picture.Bitmap, Data.Image);

        // Collect some additional image properties.
        Data.Properties := Data.Properties + Format('%d x %d pixels', [Picture.Width, Picture.Height]);
        case Picture.Bitmap.PixelFormat of
          pf1bit:
            Data.Properties := Data.Properties + ', 2 colors';
          pf4bit:
            Data.Properties := Data.Properties + ', 16 colors';