Tips (1541)

Tip Rating (25):

{
  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 Einschränkung 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 )
-----------------------------------------------------------}

{----------------------------------------------------------
  Natürlich 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 für 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 zurück.

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

{
<?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 hinzufügen" 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 löschen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY>
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY>
    <ENTRY CAPTION="Film hinzufügen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY>
     <ENTRY CAPTION="markierten Film löschen" 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="Über" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY>
    </ENTRY>

</MENU>
}