unit frmDFM;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, Forms, Grids, StdCtrls,
  ComCtrls, ExtCtrls, Buttons, TypInfo, Menus;

type
  TDragControl = class(TControl) //весь Drag&Drop наружу
  published
    property OnEndDrag;
    property OnDragOver;
    property OnMouseDown;
    property OnMouseUp;
  end;

  TDFMfrm = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    I: Integer;
    SL: TStringList;
    Ctrls: TList;
    DX,DY: Integer;
    procedure ParseObject(var I: Integer; Obj: TObject);
    procedure ParseObjects(var I: Integer);
    procedure _DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure _EndDrag(Sender, Target: TObject; X, Y: Integer);
    procedure _MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure _MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    { Public declarations }
  end;

var
  DFMfrm: TDFMfrm;

implementation

{$R *.DFM}

{ TDFMfrm }

procedure TDFMfrm.ParseObject(var I: Integer; Obj: TObject);
var
  S,aName,aValue: string;

  procedure Extract;
  var           
    J: Byte;
  begin
    aName := ''; aValue := '';
    for J := 1 to Length(S) do
      if S[J] <> ' ' then aName := aName + S[J] else
        if (aName <> '') then Break;
    J := Pos('=',S);
    if J = 0 then Exit;
    aValue := Copy(S,J+2,Length(S));
    if aValue[1] = '''' then aValue := Copy(aValue,2,Length(aValue)-2);
  end;

  procedure SetVal(Obj: TObject);
  var
    PropInfo: PPropInfo;
    Tmp: string;
    P: Byte;
  begin
    P := Pos('.',aName); Tmp := '';
    if P <> 0 then
    begin
      Tmp := Copy(aName,P+1,Length(aName));
      aName := Copy(aName,1,P-1);
    end;

    //RTTI нам строить и жить помогает...
    PropInfo := GetPropInfo(Obj.ClassInfo,aName);
    if PropInfo <> nil then
    begin
      if (PropInfo.PropType^.Kind = tkInteger) and (aValue[1] in ['0'..'9','-']) then
        SetOrdProp(Obj,aName,StrToInt(aValue));
      if (PropInfo.PropType^.Kind = tkString) or (PropInfo.PropType^.Kind = tkLString) then
        SetStrProp(Obj,aName,aValue);
      if PropInfo.PropType^.Kind = tkEnumeration then
        SetEnumProp(Obj,aName,aValue);
      if PropInfo.PropType^.Kind = tkSet then
        SetSetProp(Obj,aName,aValue);
      if PropInfo.PropType^.Kind = tkClass then
        if Tmp <> '' then
        begin
          Obj := GetObjectProp(Obj,aName);
          aName := Tmp;
          SetVal(Obj);
        end;
    end;
  end;

begin
  while True do
  begin
    S := SL[I]; Inc(I);
    Extract;
    if aName = 'end' then Break;
    if aName = 'object' then
    begin
      Dec(I);
      Break;
    end;

    SetVal(Obj);
    if I = SL.Count then Break;
  end;
end;

procedure TDFMfrm.ParseObjects(var I: Integer);
var
  S,aName,aIdent: string;
  Ctrl: TControl;
  C: Byte;
  J: Integer;

  function Extract: Boolean;
  var                 //вытаскиваем из строки тип
    J: Byte;          //заодно проверяем на всякий случай, object ли это
  begin
    C := 0;
    for J := 1 to Length(S) do
      if S[J] = ' ' then Inc(C) else Break;
    aName := Copy(S,Pos(':',S)+2,Length(S));
    aIdent := Copy(S,Pos('t ',S)+2,Pos(':',S)-Pos('t ',S)-2);
    Result := (Copy(S,C+1,6) = 'object');
  end;

  function GetPageControl: TPageControl;
  var                //ловим предыдущий ПэйджКонтрол
    J: Integer;      //чтобы воткнуть туда наш ТабШит
  begin
    Result := nil;
    for J := Ctrls.Count-1 downto 0 do
      if (TControl(Ctrls[J]) is TPageControl) then
      begin
        Result := TPageControl(Ctrls[J]);
        Break;
      end;
  end;

begin
  while True do
  begin
    if (I = SL.Count) then Break;
    S := SL[I]; Inc(I);
    if (Copy(S,Length(S)-2,3) = 'end') or not Extract then Continue;

    try
      if I = 1 then Ctrl := DFMfrm else
        Ctrl := TControlClass(FindClass(aName)).Create(DFMfrm);
    except
      Continue; //игнорируем классы, которые не знаем
    end;

    //ТабШит никак не может без ПэйджКонтрола!
    if aName = 'TTabSheet' then
      (Ctrl as TTabSheet).PageControl := GetPageControl;

    if Ctrl <> nil then
    begin
      Ctrl.Name := aIdent;
      Ctrl.Tag := C;
      if C <> 0 then //нам нужен пэрэнт!
        for J := Ctrls.Count-1 downto 0 do
          if TControl(Ctrls[J]).Tag < C then
          begin
            Ctrl.Parent := TWinControl(Ctrls[J]);
            Break;
          end;

      if (Ctrl.ClassName <> 'TTabSheet') and not (Ctrl is TForm) then
      begin //табшиты таскать нииззяя и формы тоже не нужно
        TDragControl(Ctrl).OnMouseDown := _MouseDown;
        TDragControl(Ctrl).OnMouseUp := _MouseUp;
      end;
      TDragControl(Ctrl).OnEndDrag := _EndDrag;
      TDragControl(Ctrl).OnDragOver := _DragOver;

      ParseObject(I,Ctrl);
      Ctrls.Add(Pointer(Ctrl));
    end;
  end;
end;

procedure TDFMfrm._DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);

function CheckParent(Sender: TObject): Boolean;
var
  Obj: TControl;    //не является ли наш будущий parent нашим child'ом? ;)))
begin
  Obj := (Sender as TControl).Parent;
  if Obj = nil then Result := True else
    if Obj = Source then Result := False else
      Result := CheckParent(Obj);
end;

begin
  Accept := ((Sender is TWinControl) or (Sender = Source)) and CheckParent(Sender);
end;

procedure TDFMfrm._EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
  if (Target = nil) then Exit;
  if (Sender <> Target) then
  begin
    (Sender as TControl).Top := Y - DY;
    (Sender as TControl).Left := X - DX;
    (Sender as TControl).Parent := (Target as TWinControl);
  end else
  begin
    (Sender as TControl).Top := (Sender as TControl).Top + Y - DY;
    (Sender as TControl).Left := (Sender as TControl).Left + X - DX;
  end;
end;

procedure TDFMfrm._MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbRight) and not (Sender is TForm) then
  begin
    DX := X; DY := Y;
    (Sender as TControl).BeginDrag(True); //раз... два... взяли!
  end;
end;

procedure TDFMfrm._MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  (Sender as TControl).EndDrag(True);     //упс... уронили!
end;

procedure TDFMfrm.FormCreate(Sender: TObject);
begin
  //Список классов, которые мы знаем...
  //Енто нужно для функции FindClass
  RegisterClasses([TTreeView,TPanel,TLabel,TButton,TListBox,TGroupBox,TPageControl,
    TEdit,TComboBox,TCheckBox,TBitBtn,TRadioGroup,TRichEdit,TStringGrid,TTabSheet]);

  I := 0;
  SL := TStringList.Create;
  SL.LoadFromFile('my.dfm');
  Ctrls := TList.Create;
  ParseObjects(I);
  SL.Free;
  Ctrls.Free;
end;

end.
