Динамическое создание меню по XML-файлу

Оформил: DeeCo

{ 
  The following procedure allows you to build a menu from an XML file. 
  Special feature: You only need to specify the Name of the procedure which then 
  will be attached to a OnClick handler. 
  Note that the procedure must be declared as public. 
}

 { 
  Mit folgender Prozedur kann man aus einem XML-File ein Menu 
  erstellen lassen (einfach im OnCreate aufrufen). 
  Besonderes Feature: Im XML-File gebt ihr nur den Namen der Prozedur an, 
  die dem OnClick-Ereignis zugewiesen werden soll. 
  Die einzige Einschrankung besteht darin, dass diese Prozedur 
  published sein muss. 
  Bindet einfach diese Prozedur in euer Hauptformular ein: 
}


 procedure TMainForm.CreateMenuFromXMLFile;

   function Get_Int(S: string): Integer;
   begin
     Result := 0;
     try
       Result := StrToInt(S);
     except
     end;
   end;

   procedure AddRecursive(Parent: TMenuItem; Item: IXMLNode);
   var
     I: Integer;
     Node: TMenuItem;
     Child: IXMLNode;
     Address: TMethod;
   begin
     Node := TMenuItem.Create(Parent);
     if (Uppercase(Item.Attributes['CAPTION']) <> 'SEPERATOR') then
     begin
       Node.Caption := Item.Attributes['CAPTION'];
       if (Uppercase(Item.Attributes['ID']) <> 'NONE') then
       begin
         Address.Code := MethodAddress(Item.Attributes['ID']);
         Address.Data := Self;
         if (Item.ChildNodes.Count - 1 < 0) then
           Node.OnClick := TNotifyEvent(Address);
       end;
       if (Uppercase(Item.Attributes['SHORTCUT']) <> 'NONE') then
         Node.ShortCut := TextToShortCut(Item.Attributes['SHORTCUT']);
       Node.Checked := (Item.Attributes['CHECKED'] = '1');
     end
     else
       Node.Caption := '-';
     Node.Visible := (Item.Attributes['VISIBLE'] = '1');

     if Parent <> nil then
       Parent.Add(Node)
     else
       MainMenu.Items.Add(Node);

     for I := 0 to Item.ChildNodes.Count - 1 do
     begin
       Child := item.ChildNodes[i];
       if (Child.NodeName = 'ENTRY') then
         AddRecursive(Node, Child);
     end;
   end;
 var
   Root: IXMLMENUType;
   Parent: TMenuItem;
   I: Integer;
   Child: IXMLNode;
 begin
   XMLDocument.FileName := ExtractFilePath(Application.ExeName) + XMLFile;
   if not FileExists(XMLDocument.FileName) then
   begin
     MessageDlg('Menu-XML-Document nicht gefunden!', mtError, [mbOK], 0);
     Halt;
   end;
   XMLDocument.Active := True;

   Screen.Cursor := crHourglass;
   try
     Root := GetXMLMenu(XMLDocument);
     Parent := nil;

     for I := 0 to Root.ChildNodes.Count - 1 do
     begin
       Child := Root.ChildNodes[i];
       if (Child.NodeName = 'ENTRY') then
         AddRecursive(Parent, Child);
     end;
   finally
     Screen.Cursor := crDefault;
   end;
 end;

 {---------------------------------------------------------- 
  You also need the encapsulation of the XML-File. 
  ( Save it as unit and add it to your program. 
   Created with Delphi6 -> New -> XML Data Binding Wizard ) 
-----------------------------------------------------------}

 {---------------------------------------------------------- 
  Naturlich braucht man auch die Kapselung des XML-Files 
  (Als Unit speichern und ins Programm einbinden. 
  Die Datei wurde mit Delphi 6 -> Neu -> XML-Datenbindung erstellt): 
-----------------------------------------------------------}

 {***************************************************}
 {                                                   }
 {              Delphi XML-Datenbindung              }
 {                                                   }
 {         Erzeugt am: 27.06.2002 13:25:01           }
 {                                                   }
 {***************************************************}

 unit XMLMenuTranslation;

 interface

 uses xmldom, XMLDoc, XMLIntf;

 type

   { Forward-Deklarationen }

   IXMLMENUType  = interface;
   IXMLENTRYType = interface;

   { IXMLMENUType }

   IXMLMENUType = interface(IXMLNode)
     ['{8F36F5E2-834F-41D9-918F-9B1A441C9074}']
     { Zugriff auf Eigenschaften }
     function Get_ENTRY: IXMLENTRYType;
     { Methoden & Eigenschaften }
     property ENTRY: IXMLENTRYType read Get_ENTRY;
   end;

   { IXMLENTRYType }

   IXMLENTRYType = interface(IXMLNode)
     ['{AD85CD05-725E-40F8-A8D7-D6EC05FD4360}']
     { Zugriff auf Eigenschaften }
     function Get_CAPTION: WideString;
     function Get_VISIBLE: Integer;
     function Get_ID: Integer;
     function Get_ENTRY: IXMLENTRYType;
     procedure Set_CAPTION(Value: WideString);
     procedure Set_VISIBLE(Value: Integer);
     procedure Set_ID(Value: Integer);
     { Methoden & Eigenschaften }
     property Caption: WideString read Get_CAPTION write Set_CAPTION;
     property Visible: Integer read Get_VISIBLE write Set_VISIBLE;
     property ID: Integer read Get_ID write Set_ID;
     property ENTRY: IXMLENTRYType read Get_ENTRY;
   end;

   { Forward-Deklarationen }

   TXMLMENUType  = class;
   TXMLENTRYType = class;

   { TXMLMENUType }

   TXMLMENUType = class(TXMLNode, IXMLMENUType)
   protected
     { IXMLMENUType }
     function Get_ENTRY: IXMLENTRYType;
   public
     procedure AfterConstruction; override;
   end;

   { TXMLENTRYType }

   TXMLENTRYType = class(TXMLNode, IXMLENTRYType)
   protected
     { IXMLENTRYType }
     function Get_CAPTION: WideString;
     function Get_VISIBLE: Integer;
     function Get_ID: Integer;
     function Get_ENTRY: IXMLENTRYType;
     procedure Set_CAPTION(Value: WideString);
     procedure Set_VISIBLE(Value: Integer);
     procedure Set_ID(Value: Integer);
   public
     procedure AfterConstruction; override;
   end;

   { Globale Funktionen }

 function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
 function LoadMENU(const FileName: WideString): IXMLMENUType;
 function NewMENU: IXMLMENUType;

 implementation

 { Globale Funktionen }

 function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
 begin
   Result := Doc.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
 end;

 function LoadMENU(const FileName: WideString): IXMLMENUType;
 begin
   Result := LoadXMLDocument(FileName).GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
 end;

 function NewMENU: IXMLMENUType;
 begin
   Result := NewXMLDocument.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
 end;

 { TXMLMENUType }

 procedure TXMLMENUType.AfterConstruction;
 begin
   RegisterChildNode('ENTRY', TXMLENTRYType);
   inherited;
 end;

 function TXMLMENUType.Get_ENTRY: IXMLENTRYType;
 begin
   Result := ChildNodes['ENTRY'] as IXMLENTRYType;
 end;

 { TXMLENTRYType }

 procedure TXMLENTRYType.AfterConstruction;
 begin
   RegisterChildNode('ENTRY', TXMLENTRYType);
   inherited;
 end;

 function TXMLENTRYType.Get_CAPTION: WideString;
 begin
   Result := ChildNodes['CAPTION'].Text;
 end;

 procedure TXMLENTRYType.Set_CAPTION(Value: WideString);
 begin
   ChildNodes['CAPTION'].NodeValue := Value;
 end;

 function TXMLENTRYType.Get_VISIBLE: Integer;
 begin
   Result := ChildNodes['VISIBLE'].NodeValue;
 end;

 procedure TXMLENTRYType.Set_VISIBLE(Value: Integer);
 begin
   ChildNodes['VISIBLE'].NodeValue := Value;
 end;

 function TXMLENTRYType.Get_ID: Integer;
 begin
   Result := ChildNodes['ID'].NodeValue;
 end;

 procedure TXMLENTRYType.Set_ID(Value: Integer);
 begin
   ChildNodes['ID'].NodeValue := Value;
 end;

 function TXMLENTRYType.Get_ENTRY: IXMLENTRYType;
 begin
   Result := ChildNodes['ENTRY'] as IXMLENTRYType;
 end;

 end.

 {--------------------------------------------------------------------- 

  Finally, I'll show you an example for the XML-File. 
  The Procedure Name is assigned to the ID which then will be called. 

---------------------------------------------------------------------}

 {--------------------------------------------------------------------- 

  Als Beispiel fur das XML-File hier noch eines aus 
  einem meiner Programme. 

  In ID steht der Name der Prozedur, die man als OnClick aufrufen will
   - denkt auch daran, dass diese Prozedur unbedingt als published
   deklariert sein muss, sonst liefert MethodAddress() Nil zuruck.

 ----------------------------------------------------------------------}

 { 
<?xml version="1.0" encoding="ISO-8859-1"?> 
<MENU> 
    <ENTRY CAPTION="Datei" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="Beenden" VISIBLE="1" ID="CloseProgram" SHORTCUT="Strg+X" CHECKED="0"></ENTRY> 
    </ENTRY> 

    <ENTRY CAPTION="Anzeige" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="Toolbar" VISIBLE="1" ID="ShowToolbar"  SHORTCUT="None" CHECKED="1"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Optionen" VISIBLE="1" ID="ShowOptionen"  SHORTCUT="Strg+O" CHECKED="0"></ENTRY> 
    </ENTRY> 

    <ENTRY CAPTION="News" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="Refresh" VISIBLE="1" ID="RefreshAll"  SHORTCUT="F5" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Administration" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="neue Nachricht hinzufugen" VISIBLE="1" ID="NewMarkedNews" SHORTCUT="Strg+N" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="markierte Nachricht bearbeiten" VISIBLE="1" ID="EditMarkedNews" SHORTCUT="Strg+E" CHECKED="0"></ENTRY> 
     <ENTRY CAPTION="markierte Nachricht loschen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Film hinzufugen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY> 
     <ENTRY CAPTION="markierten Film loschen" VISIBLE="1" ID="DeleteMPG" SHORTCUT="None" CHECKED="0"></ENTRY> 
    </ENTRY> 
    </ENTRY> 

    <ENTRY CAPTION="Hilfe" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="LogView" VISIBLE="1" ID="ShowLog" SHORTCUT="Strg+L" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="eMail schreiben" VISIBLE="1" ID="WriteEMail" SHORTCUT="None" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Uber" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY> 
    </ENTRY> 

</MENU> 
}