main.~pas

此程序演示了利用xml控件（当然也可以不通过xml控件）

{ Unit Main

  This unit is the main unit for XmlEditor.exe.

  XmlEditor uses the VirtualTreeView component written by Mike Lischke

  Author: Nils Haeck
  email:  [e-mail]
  Date:   21-07-2001

  Changes:
  20 Feb 2002: Adapted for changed versions of TVirtualStringTree and XML
  29 Jul 2003: Adapted for use with NativeXml.pas
  14 Nov 2003: Cleaned up
  16 Sep 2005: Added editing capabilities

  copyright (c) 2001 - 2005 Nils Haeck  www.simdesign.nl

  This source of this editor may be used in freeware or commercial applications
  provided that:
  - this notice stays intact and that a mention of contribution is made
    in the "about" box. A mention of www.simdesign.nl would be appreciated.
  - A license is purchased for NativeXml.pas

}
unit Main;

interface

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

type
  TfrmMain = class(TForm)
    ControlBar1: TControlBar;
    tbMain: TToolBar;
    tbNew: TToolButton;
    ilMenu: TImageList;
    alMain: TActionList;
    acFileOpen: TAction;
    acFileNew: TAction;
    tbOpen: TToolButton;
    sbMain: TStatusBar;
    nbMain: TNotebook;
    Splitter1: TSplitter;
    nbData: TNotebook;
    pcData: TPageControl;
    tsTags: TTabSheet;
    odFileOpen: TOpenDialog;
    nbTree: TNotebook;
    pcTree: TPageControl;
    tsXmlTree: TTabSheet;
    stXmlTree: TVirtualStringTree;
    mnuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuNew: TMenuItem;
    mnuOpen: TMenuItem;
    acSingleNodeAsAttrib: TAction;
    mnuOptions: TMenuItem;
    ilData: TImageList;
    tsXmlSource: TTabSheet;
    mmXMLSource: TMemo;
    acFileSaveAs: TAction;
    sdFileSave: TSaveDialog;
    tbSave: TToolButton;
    mnuSave: TMenuItem;
    acHideSingleNodes: TAction;
    Singlenodesastags1: TMenuItem;
    Hidesinglenodes1: TMenuItem;
    acReadableNames: TAction;
    Readablenamesfornodes1: TMenuItem;
    Edit1: TMenuItem;
    acAddComment: TAction;
    acAddStyleSheet: TAction;
    AddComment1: TMenuItem;
    AddStylesheet1: TMenuItem;
    acOutputReadable: TAction;
    Outputinreadableformat1: TMenuItem;
    acElementDelete: TAction;
    acFileExit: TAction;
    N1: TMenuItem;
    acFileExit1: TMenuItem;
    pmTree: TPopupMenu;
    DeleteElement1: TMenuItem;
    InsertElement1: TMenuItem;
    acElementInsertBefore: TAction;
    acElementInsertAfter: TAction;
    acElementInsertSub: TAction;
    BeforeNode1: TMenuItem;
    AfterNode1: TMenuItem;
    Exit1: TMenuItem;
    InsertComment1: TMenuItem;
    acCommentInsert: TAction;
    acElementUp: TAction;
    acElementDown: TAction;
    MoveUp1: TMenuItem;
    MoveDown1: TMenuItem;
    N2: TMenuItem;
    stAttributes: TVirtualStringTree;
    acAttributeAdd: TAction;
    acAttributeDelete: TAction;
    acAttributeUp: TAction;
    acAttributeDown: TAction;
    pmAttributes: TPopupMenu;
    AddAttribute1: TMenuItem;
    DeleteAttribute1: TMenuItem;
    MoveUp2: TMenuItem;
    MoveDown2: TMenuItem;
    procedure acFileOpenExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure stXmlTreeInitNode(Sender: TBaseVirtualTree; ParentNode,
      Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates);
    procedure stXmlTreeExpanding(Sender: TBaseVirtualTree;
      Node: PVirtualNode; var Allowed: Boolean);
    procedure stXmlTreeChange(Sender: TBaseVirtualTree; Node: PVirtualNode);
    procedure acFileSaveAsExecute(Sender: TObject);
    procedure acSingleNodeAsAttribExecute(Sender: TObject);
    procedure acFileNewExecute(Sender: TObject);
    procedure acHideSingleNodesExecute(Sender: TObject);
    procedure acReadableNamesExecute(Sender: TObject);
    procedure pcTreeChange(Sender: TObject);
    procedure acAddCommentExecute(Sender: TObject);
    procedure acAddStyleSheetExecute(Sender: TObject);
    procedure acOutputReadableExecute(Sender: TObject);
    procedure stXmlTreeEditing(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
    procedure stXmlTreeGetImageIndex(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
      var Ghosted: Boolean; var ImageIndex: Integer);
    procedure stXmlTreeGetText(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
      var CellText: WideString);
    procedure stXmlTreeKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure acElementDeleteExecute(Sender: TObject);
    procedure acFileExitExecute(Sender: TObject);
    procedure stXmlTreeNewText(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; NewText: WideString);
    procedure acElementInsertBeforeExecute(Sender: TObject);
    procedure acElementInsertAfterExecute(Sender: TObject);
    procedure acElementInsertSubExecute(Sender: TObject);
    procedure acCommentInsertExecute(Sender: TObject);
    procedure acElementUpExecute(Sender: TObject);
    procedure acElementDownExecute(Sender: TObject);
    procedure stAttributesGetText(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
      var CellText: WideString);
    procedure stAttributesGetImageIndex(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
      var Ghosted: Boolean; var ImageIndex: Integer);
    procedure stAttributesEditing(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
    procedure stAttributesNewText(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; NewText: WideString);
    procedure acAttributeAddExecute(Sender: TObject);
    procedure acAttributeDeleteExecute(Sender: TObject);
    procedure acAttributeUpExecute(Sender: TObject);
    procedure acAttributeDownExecute(Sender: TObject);
    procedure stAttributesChange(Sender: TBaseVirtualTree;
      Node: PVirtualNode);
    procedure stAttributesKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    FXmlDoc: TNativeXml;    // Xml document currently displayed
    FFileName: string;      // Last opened filename
    FFocusedNode: TXmlNode; // Focused TXmlNode
    FFocusedAttributeIndex: integer;
    FUpdateCount: integer;   // If 0 we can update otherwise we're in begin/end update block
    procedure GetPropertyInfo(Node: PVirtualNode;
      var IsAttribute: boolean; var Index: integer);
    procedure Regenerate;
    procedure RegenerateFromNode(ANode: TXmlNode);
    procedure RegenerateProperties;
    function ElementTypeToImageIndex(AElementType: TXmlElementType): integer;
    function IsSingleNode(ANode: TXmlNode): boolean;
    function NiceString(const Value: string): string;
    function MultiAttrCount(ANode: TXmlNode): integer;
    function MultiNodeCount(ANode: TXmlNode): integer;
    function MultiNodeByIndex(ANode: TXmlNode; AIndex: integer): TXmlNode;
    procedure XmlUnicodeLoss(Sender: TObject);
    procedure UpdateMenu;
  public
    procedure BeginUpdate;
    function IsUpdating: boolean;
    procedure EndUpdate;
  end;

var
  frmMain: TfrmMain;

const

  cAppVersion        = 'v2.1';
  cFormHeader        = 'Xml Editor (c) 2001-2005 SimDesign B.V.';
  cDefaultStyleSheet = 'type="text/xsl" href="mystylesheet.xsl"';

resourcestring
  sCannotInsertRootElement = 'You cannot insert another root element!';

implementation

{$R *.DFM}

type
  // This is the node record that is appended to each node in the virtual treeview
  PNodeRec = ^TNodeRec;
  TNodeRec = record
     FNode: TXmlNode;
  end;

{ TFrmMain }

procedure TfrmMain.acAddCommentExecute(Sender: TObject);
begin
  FXmlDoc.CommentString := InputBox('Add a comment', 'Comment:', FXmlDoc.CommentString);
end;

procedure TfrmMain.acAddStyleSheetExecute(Sender: TObject);
var
  S: string;
begin
  S := FXmlDoc.StyleSheetString;
  if Length(S) = 0 then
    S := cDefaultStyleSheet;
  FXmlDoc.StyleSheetString := InputBox('Add stylesheet string', 'Stylesheet string:', S);
end;

procedure TfrmMain.acHideSingleNodesExecute(Sender: TObject);
begin
  acHideSingleNodes.Checked := not acHideSingleNodes.Checked;
  Regenerate;
end;

procedure TfrmMain.acFileNewExecute(Sender: TObject);
// Create a blank Xml document with a blank root
begin
  FXmlDoc.Clear;
  // Set to UTF8
  FXmlDoc.EncodingString := 'UTF-8';
  FXmlDoc.Utf8Encoded := True;
  FXmlDoc.ExternalEncoding := seUTF8;
  FXmlDoc.Root.Name := 'root';
  Regenerate;
end;

procedure TfrmMain.acFileOpenExecute(Sender: TObject);
begin
  // Open an new setup
  if odFileOpen.Execute then begin
    FFileName := odFileOpen.FileName;
    try
      FXmlDoc.LoadFromFile(FFilename);
      // if you want to resolve all the entity references, then uncomment the next line
      // FXmlDoc.ResolveEntityReferences;
      // Display properties on statusbar
      with FXmlDoc do begin
        sbMain.SimpleText := Format('Version="%s"', [VersionString]);
        if Length(EncodingString) > 0 then
          sbMain.SimpleText := sbMain.SimpleText +
            Format(' Encoding="%s"', [EncodingString]);
      end;
    except
      // Show exception on status bar
      on E: Exception do
        sbMain.SimpleText := E.Message;
    end;
    Regenerate;
  end;
end;

procedure TfrmMain.acFileSaveAsExecute(Sender: TObject);
begin
  // Save a file
  if sdFileSave.Execute then begin
    FFileName := sdFileSave.FileName;
    FXmlDoc.SaveToFile(FFilename);
    Regenerate;
  end;
end;

procedure TfrmMain.acOutputReadableExecute(Sender: TObject);
begin
  if IsUpdating then exit;
  case FXmlDoc.XmlFormat of
  xfReadable: FXmlDoc.XmlFormat := xfCompact;
  xfCompact:  FXmlDoc.XmlFormat := xfReadable;
  end;
  UpdateMenu;
end;

procedure TfrmMain.acReadableNamesExecute(Sender: TObject);
begin
  acReadableNames.Checked := not acReadableNames.Checked;
  Regenerate;
end;

procedure TfrmMain.acSingleNodeAsAttribExecute(Sender: TObject);
begin
  acSingleNodeAsAttrib.Checked := not acSingleNodeAsAttrib.Checked;
  if acSingleNodeAsAttrib.Checked then
    tsTags.Caption := 'Attributes and child elements'
  else
    tsTags.Caption := 'Attributes';
  RegenerateProperties;
end;

procedure TfrmMain.BeginUpdate;
begin
  inc(FUpdateCount);
end;

function TfrmMain.ElementTypeToImageIndex(
  AElementType: TXmlElementType): integer;
begin
  case AElementType of
  xeNormal:      Result := 1;
  xeComment:     Result := 2;
  xeCData:       Result := 3;
  xeCharData:    Result := 4;
  xeDeclaration: Result := 5;
  xeStylesheet:  Result := 6;
  xeDoctype:     Result := 7;
  xeElement:     Result := 8;
  xeAttList:     Result := 9;
  xeEntity:      Result := 10;
  xeNotation:    Result := 11;
  xeExclam:      Result := 12;
  xeQuestion:    Result := 13;
  else
    Result := 13;
  end;//case
end;

procedure TfrmMain.EndUpdate;
begin
  dec(FUpdateCount);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FXmlDoc := TNativeXml.Create;
  FXmlDoc.OnUnicodeLoss := XmlUnicodeLoss;
  FXmlDoc.Utf8Encoded := True;
  // Open cmdline parameter 1 file (when associated with this tool)
  if length(ParamStr(1)) > 0 then begin
    FXmlDoc.LoadFromFile(ParamStr(1));
    Regenerate;
  end else
    acFileNew.Execute;
  FFocusedAttributeIndex := -1;
end;

function TfrmMain.IsSingleNode(ANode: TXmlNode): boolean;
begin
  Result := True;
  if assigned(ANode) then
    if (ANode.NodeCount > 0) or (ANode.AttributeCount > 0) then
      Result := False;
end;

function TfrmMain.IsUpdating: boolean;
begin
  Result := FUpdateCount > 0;
end;

procedure TfrmMain.GetPropertyInfo(Node: PVirtualNode;
  var IsAttribute: boolean; var Index: integer);
var
  AIndex, ANodeIndex: integer;
begin
  IsAttribute := True;
  Index := -1;
  // Get the data of the tag's properties
  if assigned(FFocusedNode) then with FFocusedNode do begin
    AIndex := Node.Index;
    // Attributes
    if (AIndex >= 0) and (AIndex < AttributeCount) then begin
      Index := AIndex;
      exit;
    end;
    // Special feature: show single nodes as attribute
    AIndex := AIndex - AttributeCount;
    if acSingleNodeAsAttrib.Checked then begin
      // Find the single node at AIndex
      ANodeIndex := -1;
      while AIndex >= 0 do begin
        inc(ANodeIndex);
        if not assigned(Nodes[ANodeIndex]) then exit;
        if IsSingleNode(Nodes[ANodeIndex]) then
          dec(AIndex);
      end;
      if assigned(Nodes[ANodeIndex]) then begin
        IsAttribute := False;
        Index := ANodeIndex;
      end;
    end;
  end;
end;

procedure TfrmMain.stAttributesGetText(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
  var CellText: WideString);
var
  IsAttribute: boolean;
  Index: integer;
  ANode: TXmlNode;
begin
  GetPropertyInfo(Node, IsAttribute, Index);
  if Index < 0 then exit;
  if IsAttribute then begin
    case Column of
    0: CellText := NiceString(FFocusedNode.AttributeName[Index]);
    1: CellText := FFocusedNode.ToWidestring(FFocusedNode.AttributeValue[Index]);
    end;//case
  end else begin
    ANode := FFocusedNode.Nodes[Index];
    case Column of
    0: CellText := NiceString(ANode.Name);
    1: CellText := ANode.ValueAsWidestring;
    end;//case
  end;
end;

procedure TfrmMain.stAttributesGetImageIndex(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
  var Ghosted: Boolean; var ImageIndex: Integer);
var
  IsAttribute: boolean;
  Index: integer;
  ANode: TXmlNode;
begin
  ImageIndex := -1;
  if Kind = ikOverlay then exit;
  if Column > 0 then exit;
  GetPropertyInfo(Node, IsAttribute, Index);
  if Index < 0 then exit;
  if IsAttribute then
    ImageIndex := 0
  else
    ImageIndex := ElementTypeToImageIndex(FFocusedNode.Nodes[Index].ElementType);
end;

procedure TfrmMain.stAttributesEditing(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
begin
  Allowed := True;
end;

procedure TfrmMain.stAttributesNewText(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex; NewText: WideString);
var
  IsAttribute: boolean;
  Index: integer;
  ANode: TXmlNode;
begin
  GetPropertyInfo(Node, IsAttribute, Index);
  if Index < 0 then exit;
  if IsAttribute then begin
    case Column of
    0: FFocusedNode.AttributeName[Index] := NewText;