main.pas

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

unit Main;

// Virtual Treeview sample application demonstrating clipboard and drag'n drop operations.
// The treeview uses OLE for these operations but can also issue and accept VCL drag'n drop.
// Written by Mike Lischke.

interface

uses
  Windows, Messages, ActiveX, SysUtils, Forms, Dialogs, Graphics, 
  VirtualTrees, ActnList, ComCtrls, ExtCtrls, StdCtrls, Controls, Classes;

type
  TMainForm = class(TForm)
    ActionList1: TActionList;
    CutAction: TAction;
    CopyAction: TAction;
    PasteAction: TAction;
    FontDialog: TFontDialog;
    Panel3: TPanel;
    Label6: TLabel;
    Button1: TButton;
    Button3: TButton;
    Tree2: TVirtualStringTree;
    Label1: TLabel;
    Tree1: TVirtualStringTree;
    Label2: TLabel;
    PageControl1: TPageControl;
    LogTabSheet: TTabSheet;
    RichTextTabSheet: TTabSheet;
    LogListBox: TListBox;
    RichEdit1: TRichEdit;
    Label3: TLabel;
    Label7: TLabel;
    Button2: TButton;
    TabSheet1: TTabSheet;
    Label8: TLabel;
    TabSheet2: TTabSheet;
    Label4: TLabel;
    Label5: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure CutActionExecute(Sender: TObject);
    procedure CopyActionExecute(Sender: TObject);
    procedure PasteActionExecute(Sender: TObject);
    procedure Tree1GetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
      var Text: WideString);
    procedure FormCreate(Sender: TObject);
    procedure TreeDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject;
      Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);
    procedure Button2Click(Sender: TObject);
    procedure TreeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
      var InitialStates: TVirtualNodeInitStates);
    procedure Tree1NewText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; Text: WideString);
    procedure Button3Click(Sender: TObject);
    procedure Tree2DragAllowed(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
    procedure TreeDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState;
      Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean);
    procedure Tree2BeforeItemErase(Sender: TBaseVirtualTree; Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect;
      var ItemColor: TColor; var EraseAction: TItemEraseAction);
  private
    procedure AddUnicodeText(DataObject: IDataObject; Target: TVirtualStringTree; Mode: TVTNodeAttachMode);
    procedure AddVCLText(Target: TVirtualStringTree; const Text: WideString; Mode: TVTNodeAttachMode);
    function FindCPFormatDescription(CPFormat: Word): string;
    procedure InsertData(Sender: TVirtualStringTree; DataObject: IDataObject; Formats: TFormatArray; Effect: Integer;
      Mode: TVTNodeAttachMode);
  end;

var
  MainForm: TMainForm;

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

implementation                          

uses
  TypInfo, ShlObj, UrlMon;
  
{$R *.DFM}
{$R Res\Extra.res}  // Contains a little rich text for the rich edit control and a XP manifest.

type
  PNodeData = ^TNodeData;
  TNodeData = record
    Caption: WideString;
  end;

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

procedure TMainForm.Button1Click(Sender: TObject);

begin
  Close;
end;

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

procedure TMainForm.CutActionExecute(Sender: TObject);

begin
  if ActiveControl = Tree1 then
    Tree1.CutToClipboard
  else
    if ActiveControl = Tree2 then
      Tree2.CutToClipboard
    else
      if ActiveControl = RichEdit1 then
        RichEdit1.CutToClipboard;                               
end;

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

procedure TMainForm.CopyActionExecute(Sender: TObject);

begin
  if ActiveControl = Tree1 then
    Tree1.CopyToClipboard
  else
    if ActiveControl = Tree2 then
      Tree2.CopyToClipboard
    else
      if ActiveControl = RichEdit1 then
        RichEdit1.CopyToClipboard;
end;

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

procedure TMainForm.PasteActionExecute(Sender: TObject);

var
  DataObject: IDataObject;
  EnumFormat: IEnumFormatEtc;
  Format: TFormatEtc;
  Formats: TFormatArray;
  Fetched: Integer;
  Tree: TVirtualStringTree;
  
begin
  if ActiveControl is TVirtualStringTree then
  begin
    Tree := ActiveControl as TVirtualStringTree;
    
    if LogListBox.Items.Count > 0 then
      LogListBox.Items.Add('');
    if ActiveControl = Tree1 then
      LogListBox.Items.Add('----- Tree 1')
    else
      LogListBox.Items.Add('----- Tree 2');

    if Tree.PasteFromClipboard then
      LogListBox.Items.Add('Native tree data pasted.')
    else
    begin
      LogListBox.Items.Add('Other data pasted.');
      // Some other data was pasted. Enumerate the available formats and try to add the data.
      // 1) Get a data object for the data.
      OLEGetClipboard(DataObject);
      // 2) Enumerate all offered formats and create a format array from it which can be used in InsertData.
      if Succeeded(DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat)) then
      begin
        EnumFormat.Reset;
        while EnumFormat.Next(1, Format, @Fetched) = S_OK do
        begin
          SetLength(Formats, Length(Formats) + 1);
          Formats[High(Formats)] := Format.cfFormat;
        end;

        InsertData(Tree, DataObject, Formats, DROPEFFECT_COPY, Tree.DefaultPasteMode);
      end;
    end;
  end
  else
    if ActiveControl = RichEdit1 then
      RichEdit1.PasteFromClipboard;
end;

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

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

var
  Data: PNodeData;

begin
  if TextType = ttNormal then
  begin
    Data := Sender.GetNodeData(Node);
    Text := Data.Caption;
  end
  else
    Text := '';
end;

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

procedure TMainForm.FormCreate(Sender: TObject);

var
  Stream: TResourceStream;

begin
  Tree1.NodeDataSize := SizeOf(TNodeData);
  Tree1.RootNodeCount := 30;
  Tree2.NodeDataSize := SizeOf(TNodeData);
  Tree2.RootNodeCount := 30;

  // There is a small RTF text stored in the resource to have something to display in the rich edit control.
  Stream := TResourceStream.Create(HInstance, 'RTF', 'RCDATA');
  try
    RichEdit1.Lines.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;                                             

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

procedure TMainForm.AddUnicodeText(DataObject: IDataObject; Target: TVirtualStringTree; Mode: TVTNodeAttachMode);

// This method is called when the drop handler gets called with Unicode text as only
// understandable clipboard format. This text is retrieved and splitted in lines.
// Every line is then added as new node.

var
  FormatEtc: TFormatEtc;
  Medium: TStgMedium;
  OLEData,
  Head, Tail: PWideChar;
  TargetNode,
  Node: PVirtualNode;
  Data: PNodeData;
  
begin
  if Mode <> amNowhere then
  begin
    // fill the structure used to get the Unicode string
    with FormatEtc do
    begin
      cfFormat := CF_UNICODETEXT;
      // no specific target device
      ptd := nil;
      // normal content to render
      dwAspect := DVASPECT_CONTENT;
      // no specific page of multipage data
      lindex := -1;
      // pass the data via memory
      tymed := TYMED_HGLOBAL;
    end;

    // Check if we can get the Unicode text data.
    if DataObject.QueryGetData(FormatEtc) = S_OK then
    begin
      // Data is accessible so finally get a pointer to it
      if DataObject.GetData(FormatEtc, Medium) = S_OK then
      begin
        OLEData := GlobalLock(Medium.hGlobal);
        if Assigned(OLEData) then
        begin
          Target.BeginUpdate;
          TargetNode := Target.DropTargetNode;
          if TargetNode = nil then
            TargetNode := Target.FocusedNode;
            
          Head := OLEData;
          try
            while Head^ <> #0 do
            begin
              Tail := Head;
              while not (Tail^ in [WideChar(#0), WideChar(#13), WideChar(#10)]) do
                Inc(Tail);
              if Head <> Tail then
              begin
                // add a new node if we got a non-empty caption
                Node := Target.InsertNode(TargetNode, Mode);
                Data := Target.GetNodeData(Node);
                SetString(Data.Caption, Head, Tail - Head);
              end;
              // skip line separators
              if Tail^ = #13 then
                Inc(Tail);
              if Tail^ = #10 then
                Inc(Tail);
              Head := Tail;
            end;
          finally
            GlobalUnlock(Medium.hGlobal);
            Target.EndUpdate;
          end;
        end;
        // never forget to free the storage medium
        ReleaseStgMedium(Medium);
      end;
    end;
  end;
end;

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

procedure TMainForm.AddVCLText(Target: TVirtualStringTree; const Text: WideString; Mode: TVTNodeAttachMode);

// This method is called when the drop handler gets called with a VCL drag source.
// The given text is retrieved and splitted in lines.

var
  Head, Tail: PWideChar;
  TargetNode,
  Node: PVirtualNode;
  Data: PNodeData;
  
begin
  if Mode <> amNowhere then
  begin
    Target.BeginUpdate;
    try
      TargetNode := Target.DropTargetNode;
      if TargetNode = nil then
        TargetNode := Target.FocusedNode;

      Head := PWideChar(Text);
      while Head^ <> #0 do
      begin
        Tail := Head;
        while not (Tail^ in [WideChar(#0), WideChar(#13), WideChar(#10)]) do
          Inc(Tail);
        if Head <> Tail then
        begin
          // add a new node if we got a non-empty caption
          Node := Target.InsertNode(TargetNode, Mode);
          Data := Target.GetNodeData(Node);