Delphi World - Динамическое создание меню по XML-файлу
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Динамическое создание меню по XML-файлу

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 
  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> 
}
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования