设计器

实现窗口继承

designer/tslvcldesigner.tsf

@@ -391,6 +391,10 @@ type TVclDesigner = class(tvcform)
     begin
         FProjectManager.ShowCurrentFormCode();//ShowEditor();
     end 
+    function opentfm(); //´ò¿ª×ÊÔ´Îļþ
+    begin
+        FProjectManager.ShowCurrenttfm();
+    end 
     function TreeNode2tfm(lib,itemnames,nd); //ת»»Îļþ 
     begin
     {**
@@ -1000,13 +1004,13 @@ type TVclDesigner = class(tvcform)
         try 
             prs := array();  
             obarray := array(); 
-            loadtfmtotree(Ptfm,Ptfm.gettree,FTree.RootItem,FTree,prs,obarray,const inh);
+            loadtfmtotree(Ptfm,Ptfm.gettree2,FTree.RootItem,FTree,prs,obarray,const inh);
             for i,v in prs do 
             begin
                 va := obarray[v[2]]; 
                 if va then 
                 begin
-                    v[0].SetComponentProperties(v[1],va.GetTrueComponent());
+                    v[0].SetComponentProperties(v[1],va.GetTrueComponent(),v[3]);
                 end 
             end 
             
@@ -1034,9 +1038,12 @@ type TVclDesigner = class(tvcform)
                 it := new TDPanelForm();
             end else return ;
             it.dclassname(d["class"]);
+            
             it.Imgs := fdimagelist.GetImageId("tdcreateform");
         end 
         comp := it.ComponentCreater(node,wr);
+        comp.isinherited := d["inherited"];
+        comp.inheritedparent := d["parent"];
         comp.name := d["name"];
         obarray[d["name"]] := comp;
         FVariableSelecter.additem(comp);
@@ -1064,18 +1071,19 @@ type TVclDesigner = class(tvcform)
             cls := v["class"];
             et := GetComponentPropertyType(cls);//GetPropertyType(cls);
             if not et then continue;
+            pp := ddpv["pp"];
             setddpv := et.TmfToNode(p.SampleValue(ddpv));
             if et.IfComponent() then 
             begin
-                prs[length(prs)]:= array(comp,n,setddpv);
+                prs[length(prs)]:= array(comp,n,setddpv,pp);
                 continue;
             end 
             if et.LazyProperty() then 
             begin
-                lazy[length(lazy)] := array(n,setddpv);
+                lazy[length(lazy)] := array(n,setddpv,pp);
                 continue;
             end 
-            comp.SetComponentProperties(n,setddpv);
+            comp.SetComponentProperties(n,setddpv,pp);
         end 
         for i,v in d["object"] do 
         begin    
@@ -1083,7 +1091,7 @@ type TVclDesigner = class(tvcform)
         end 
         for i,v in lazy do 
         begin
-            comp.SetComponentProperties(v[0],v[1]);
+            comp.SetComponentProperties(v[0],v[1],v[2]);
         end 
         //comp.DoControlAlign();
     end 

designer/udesignerproject.tsf

@@ -194,6 +194,7 @@ app.run();                    //
 end 
 type TProjectView = class(TVCForm) //工程文件浏览
     private
+    FAddtoolbtn;
     FTreePopUpMenu;
     type TMyToolBar=class(TToolBar)
         function Create(AOwner);override;
@@ -339,6 +340,8 @@ type TProjectView = class(TVCForm) //
         width := 300; //350
         height := max(400,rc[3]-200);
         FInput := new TNameInput(self);
+        finheritedinput := new tinheritedimput(self);
+        finheritedinput.parent := self;
         FInput.visible := false;
         FInput.parent := self;
         FTslEditer := new TTslEditer(AOwner);
@@ -391,6 +394,10 @@ type TProjectView = class(TVCForm) //
             btn.ImageId := imgs.ImageCount-1;
             btn.parent := FTreeTool;
             btn.Onclick := thisfunction(ToolClick);
+            if i="添加" then 
+            begin
+                FAddtoolbtn := btn;
+            end 
         end
         FTreeTool.ImageList := imgs;
         //**************目录树筛选功能***********************************
@@ -460,6 +467,10 @@ type TProjectView = class(TVCForm) //
         FAddMenuDir.bitmap := bmps["dir"];
         FAddMenuDir.parent := FAddMenu;
         FMoveMenu := new TMenu(self);
+        faddinherited := new TMenu(self);
+        faddinherited.Caption := "通过继承";
+        faddinherited.parent := FAddMenu;
+        FMoveMenu := new TMenu(self);
         FMoveMenu.caption := "移动到:";
         FMoveMenu.bitmap := bmps["移动"];
         FRenameMenu := new TMenu(self);
@@ -471,6 +482,7 @@ type TProjectView = class(TVCForm) //
         FAddMenuTsf.OnClick := thisfunction(Add_tsf);
         FAddMenuTsl.OnClick := thisfunction(add_tsl);
         FAddMenuDir.OnClick := thisfunction(Add_dir);
+        faddinherited.OnClick := thisfunction(add_inherited);
         FOpenMenu := new TMenu(self);
         FOpenMenu.Caption := "打开";
         FOpenMenu.bitmap := EditToolBmps["打开"];
@@ -510,9 +522,23 @@ type TProjectView = class(TVCForm) //
         if FTree.PopUpMenu then 
         begin 
             it := e.itemnew;
-            if it=ftree.RootNode then return FDesigner.ExecuteCommand("hiddrennode",nil);
+            if it=ftree.RootNode then 
+            begin
+                if FAddtoolbtn then FAddtoolbtn.Enabled := false;
+                return FDesigner.ExecuteCommand("hiddrennode",nil);
+            end 
             if it then
             begin
+                if FAddtoolbtn then 
+                begin
+                    if it.FType = "dir" then 
+                    begin
+                        FAddtoolbtn.Enabled := true;
+                    end else
+                    begin
+                        FAddtoolbtn.Enabled := false;
+                    end 
+                end 
                 if it.FType="dir" then
                 begin
                     if (it=FTree.ProjectNode)  then 
@@ -566,6 +592,16 @@ type TProjectView = class(TVCForm) //
             AddDirToCurrentNode(FInput.GetEditV());
         end
     end
+    function add_inherited();
+    begin
+        if not FCProjectPath then return Messageboxa("工程没打开","提示",0,self);
+        finheritedinput.setinfo();
+        if finheritedinput.ShowModal() then 
+        begin
+            //echo tostn(finheritedinput.GetInfo());
+            AddinheritdToCurrentDir(finheritedinput.GetInfo());
+        end 
+    end 
     function DoRename();
     begin
         if not FCProjectPath then return Messageboxa("工程没打开","提示",0,self);
@@ -679,7 +715,12 @@ type TProjectView = class(TVCForm) //
         if r then FTslEditer.OpenAndGotoFileByName(r);
         ShowEditor();
     end
-
+    function ShowCurrenttfm();
+    begin
+        if  FCurrentOpend then r := FCurrentOpend.gettmfname();
+        if r then FTslEditer.OpenAndGotoFileByName(r);
+        ShowEditor();
+    end 
     function AddAFiled(n); //添加成员
     begin
         if ifstring(n)and FCurrentOpend and(FCurrentOpend["type"] in array("form","panel"))then
@@ -728,6 +769,7 @@ type TProjectView = class(TVCForm) //
         ShowEditor();
         return r;
     end
+
     function OpenFileByName(n); //打开文件 
     begin
         fio := ioFileseparator();
@@ -767,13 +809,7 @@ type TProjectView = class(TVCForm) //
                     FCurrentOpend := nil;
                     return messageboxa("文件不存在","错误",0,self);
                 end
-                classinfo := FTslEditer.GetClassInfo(it);
+                inh := getwindowinherited(n);
-                if not(ifarray(classinfo)and classinfo)then
-                begin
-                    FCurrentOpend := nil;
-                    return messageboxa("非窗口类,或者该文件已经损坏","错误",0,self);
-                end
-                inh := classinfo["inherited"];
                 if not(ifarray(inh)and(inh intersect array("tdcreateform","tdcreatepanel")))then
                 begin                    
                     FCurrentOpend := nil;
@@ -781,6 +817,7 @@ type TProjectView = class(TVCForm) //
                 end
                 //打开界面
                 FDesigner.caption := "TVCL界面设计器 "+FprojName+"->"+FCurrentOpend["name"];
+                FTmfParser.fssourdirs := FCurrentOpend.gettmfdirs();
                 FTmfParser.ScriptPath := FCurrentOpend.gettmfname();
                 FTfmComponets := array();
                 FTmfParser.GetAllSubObjects(nil,FTfmComponets);
@@ -796,6 +833,36 @@ type TProjectView = class(TVCForm) //
             end
         end
     end
+    function getwindowinherited2(fn);
+    begin
+        it := FTslEditer.OpenAndGoLineByName(fn);   
+        classinfo := FTslEditer.GetClassInfo(it); 
+        if not(ifarray(classinfo)and classinfo) then return 0;
+        inh := classinfo["inherited"];
+        for i,v in inh do 
+        begin
+            if v = "tdcreateform" then return array("tdcreateform");
+            else if v = "tdcreatepanel" then return array("tdcreatepanel");
+        end 
+        for i,v in inh do 
+        begin 
+            r := getwindowinherited(v);
+            if r then return r;
+        end 
+    end 
+    function getwindowinherited(n);//获得继承
+    begin
+        nopend := FTree.NameInTree(n,nil,false);
+        if not nopend then return 0;
+        case FCurrentOpend["type"] of 
+            "form","panel":
+            begin
+                fn := nopend.gettsfname();
+                return getwindowinherited2(fn);
+            end 
+        
+        end 
+    end 
     function OpenMainForm(); //打开主函数
     begin
         nd := FTree.NameInTree(FMainForm,nil,true);
@@ -929,9 +996,7 @@ type TProjectView = class(TVCForm) //
                     end
                 end;
             end
-            //FTree.DeleteNode(nd);
             FTree.DeleteCurrentNode();
-            //nd.Recycling();
             SaveProjInfo();
         end
     end
@@ -951,6 +1016,49 @@ type TProjectView = class(TVCForm) //
         if cn then FTree.InvalidateItem(cn);
         SaveProjInfo();
     end
+    function AddinheritdToCurrentDir(info);
+    begin
+        n := info[1];
+        if not(LegalVariableName(n))then return MessageboxA("名字不合法,请重试","提示",0,self);
+        if FTree.NameInTree(lowercase(n),nil,true)then return MessageboxA("重复的文件名","提示",0,self);
+        nd := info[0];
+        if not ifobj(nd) then return  MessageboxA("父窗口错误","提示",0,self);
+        ph := FTree.CurrentNode.FPath;
+        fio := ioFileseparator();
+        fn := array("name":n,"type":nd.FType,"dir":ph);
+        cprojpath := FCProjectPath;
+        if ph then ph += fio;
+        else ph := "";
+        ph := cprojpath+ph+n+".tsf";
+        if not(FileExists("",ph))then
+        begin
+r := format(%%
+type %s=class(%s)
+    function create(AOwner);
+    begin
+        inherited;
+    end 
+
+end 
+
+%%,n,nd.Fname);
+            ReWriteString(ph,r);            
+            FTmfParser.ScriptPath := nd.gettmfname();
+            r := FTmfParser.inheritedcoy(n+"1",n,nd.Fname);
+            ReWriteString((FCProjectPath+"resource.tfm"+fio+n+".tfm"),r);
+        end  else 
+        begin
+            FTslParser.ScriptPath := ph;
+            cc := FTslParser.GetClassAbstract();
+            if ifarray(cc)then
+            begin
+                inh := cc["inherited"]; 
+             
+            end    
+        end 
+        FTree.SetFileToNode(fn);
+        SaveProjInfo();
+    end 
     function AddFormToCurrentDir(n); //添加窗口
     begin
         if not(LegalVariableName(n))then return MessageboxA("名字不合法,请重试","提示",0,self);
@@ -970,28 +1078,17 @@ type TProjectView = class(TVCForm) //
             ReWriteString((FCProjectPath+"resource.tfm"+fio+n+".tfm"),r);
         end else //已经存在
         begin
-            FTslParser.ScriptPath := ph;
+            inh := getwindowinherited2(ph);
-            cc := FTslParser.GetClassAbstract();
+            if inh = array("tdcreateform") then 
-            if ifarray(cc)then
             begin
-                inh := cc["inherited"];
+                fn["type"]:= "form";
-                if ifarray(inh)and lowercase(n)=cc["name"]then
+            end else 
-                begin
+            if inh = array("tdcreatepanel") then 
-                    if("tdcreateform"=inh[0])and FileExists("",(FCProjectPath+"resource.tfm"+fio+n+".tfm"))then
+            begin
-                    begin
+                fn["type"]:= "panel";
-                        fn["type"]:= "form";
+            end else 
-                    end else
+            begin
-                    if("tdcreatepanel"=inh[0])and FileExists("",(FCProjectPath+"resource.tfm"+fio+n+".tfm"))then
+                fn["type"]:= "tsf";
-                    begin
-                        fn["type"]:= "panel";
-                    end else
-                    begin
-                        fn["type"]:= "tsf";
-                    end
-                end else
-                begin
-                    fn["type"]:= "tsf";
-                end
             end 
         end
         FTree.SetFileToNode(fn);
@@ -1016,28 +1113,17 @@ type TProjectView = class(TVCForm) //
             ReWriteString((FCProjectPath+"resource.tfm"+fio+n+".tfm"),r);
         end else
         begin
-            FTslParser.ScriptPath := ph;
+            inh := getwindowinherited2(ph);
-            cc := FTslParser.GetClassAbstract();
+            if inh = array("tdcreateform") then 
-            if ifarray(cc)then
             begin
-                inh := cc["inherited"];
+                fn["type"]:= "form";
-                if ifarray(inh)and lowercase(n)=cc["name"]then
+            end else 
-                begin
+            if inh = array("tdcreatepanel") then 
-                    if("tdcreateform"=inh[0])and FileExists("",(FCProjectPath+"resource.tfm"+fio+n+".tfm"))then
+            begin
-                    begin
+                fn["type"]:= "panel";
-                        fn["type"]:= "form";
+            end else 
-                    end else
+            begin
-                    if("tdcreatepanel"=inh[0])and FileExists("",(FCProjectPath+"resource.tfm"+fio+n+".tfm"))then
+                fn["type"]:= "tsf";
-                    begin
-                        fn["type"]:= "panel";
-                    end else
-                    begin
-                        fn["type"]:= "tsf";
-                    end
-                end else
-                begin
-                    fn["type"]:= "tsf";
-                end
             end 
         end
         FTree.SetFileToNode(fn);
@@ -1429,6 +1515,9 @@ type TProjectView = class(TVCForm) //
         if parseregexpr(format("object\\s+\\w+:(%s)\\s*",brs),s,"mibes",result,mpos,mlen)=1 then 
         begin 
         end else
+        if parseregexpr(format("inherited\\s+\\w+:(%s)\\s*",brs),s,"mibes",result,mpos,mlen)=1 then 
+        begin 
+        end else
         begin
             return false;
         end 
@@ -1510,6 +1599,7 @@ type TProjectView = class(TVCForm) //
     FDelDirBtn;
     FOpenBtn;
     FInput;
+    finheritedinput;
     FScriptHandle;
     
     FTmfParser;
@@ -1524,6 +1614,7 @@ type TProjectView = class(TVCForm) //
     FRenameMenu;
     FAddMenu;
     FAddMenuDir;
+    faddinherited;
     FAddMenuForm;
     FAddMenuPanel;
     FAddMenuTsf;
@@ -1531,6 +1622,7 @@ type TProjectView = class(TVCForm) //
     FOpenMenu;
     public
     FTslEditer;  
+    property tree read ftree;  
     private 
 end
 
@@ -1796,6 +1888,13 @@ type TFileTree = class(TTreeCtl)
                 return Owner.fprojectpath+"resource.tfm"+fio+nn+".tfm";
             end 
         end 
+        function gettmfdirs();//获得tmfdir
+        begin
+            if FFType in array( "form","panel") then 
+            begin
+                return array( Owner.fprojectpath+"resource.tfm"+fio);
+            end     
+        end 
         property FFileInfo read FFFileInfo write setfileinfo;
         fio;
         fdtree;
@@ -1925,7 +2024,11 @@ type TFileTree = class(TTreeCtl)
         Rnd := RootNode;
         GetLeafNodeByName(Rnd,nds,n);
     end
-    
+    function GetNodesBytype(nds,n);
+    begin
+        Rnd := RootNode;
+        getleafnodebytype(Rnd,nds,n);
+    end    
     function GetLeafNodeByName(nd,nds,n);
     begin
         if not ifarray(nds) then nds := array();
@@ -1944,6 +2047,24 @@ type TFileTree = class(TTreeCtl)
             end 
         end         
     end 
+    function getleafnodebytype(nd,nds,ns);
+    begin
+        if not ifarray(nds) then nds := array();
+        for i:= 0 to nd.ItemCount-1 do 
+        begin
+            cnd := nd.GetNodeByIndex(i);
+            tp := cnd.FType;
+            if tp = "dir" then 
+            begin
+                getleafnodebytype(cnd,nds,ns);    
+            end else 
+            if ifarray(ns) and  (tp in ns) then
+            begin
+                nds[length(nds)] := cnd;
+            end  
+           
+        end     
+    end 
     function NodeSelChanged(o,e); //切换
     begin
         it := e.ItemNew;
@@ -2344,6 +2465,113 @@ type TKeyValueList = class(TListBox) //kvalue list
 	    private 
     FCurrentIndex;
 end 
+
+type tinheritedimput = class(TVCForm)
+
+    function Create(AOwner);override;
+    begin
+        inherited;
+        info := %%
+        object tinheritedinput1:tinheritedinput
+           visible = false 
+           caption="通过继承构建窗口"
+           height=338
+           left=420
+           top=232
+           width=300
+           minmaxbox=false
+           object label3:tlabel
+              left=6
+              top=9
+              caption="父类窗口"
+           end
+           object listbox1:tlistbox
+              caption="listbox1"
+              height=178
+              left=6
+              top=40
+              visible=true
+              width=274
+           end
+           object btn1:tbtn
+              caption="取消"
+              height=25
+              left=79
+              top=262
+           end
+           object btn2:tbtn
+              caption="确定"
+              height=27
+              left=187
+              top=261
+           end
+           object label1:tlabel
+              left=7
+              top=225
+              width=53
+              height=24
+              caption="名称"
+           end
+           object edit1:tedit
+              caption="edit1"
+              left=62
+              top=226
+              width=208
+           end
+        end
+        %%;
+        WSSizebox := false;
+        loader.LoadFromTfmScript(self,info);
+        rc := _wapi.GetScreenRect();
+        left :=(rc[2]-rc[0])/2-280;
+        top :=(rc[3]-rc[1])/2-230;
+        
+        Onclose := thisfunction(CloseEndModalForm);
+        btn1.onClick := function(o,e)
+        begin
+            Endmodal(0);
+        end
+        btn2.onClick := function(o,e);
+        begin
+            Endmodal(1);
+        end 
+    end
+    function CloseEndModalForm(o,e);
+    begin
+        e.skip := true;
+        o.Endmodal(0);
+    end 
+    function getinfo();
+    begin
+        return array(fnds[listbox1.getCurrentSelection()],edit1.text);
+    end 
+    function setinfo();
+    begin
+        if parent then 
+        begin
+            tr := parent.tree;
+            fnds := array();
+            tr.GetNodesBytype(fnds,array("form","panel"));
+            ss := array();
+            for i,v in fnds do 
+            begin
+                ss[i] := v.Fname;
+            end 
+            
+        end 
+        listbox1.Items := ss;
+        edit1.ExecuteCommand("ecselall");
+    end
+    public //成员变量 
+    fnds;
+    label3;
+    listbox1;
+    btn1;
+    btn2;
+    label1;
+    edit1;
+      
+end
 type TNameInput=class(TCustomControl) //输入文件名窗口
     function Create(AOwner);override;
     begin

designer/utslcodeeditor.tsf

@@ -1425,7 +1425,7 @@ type TPageEditerItem=class(TPageItem)
         FEditer.ChangedFlag := false;
         if not FTslSynText then return;
         if not(s)then return;
-        r := tsl_tokenizeex_2_(s,1);
+        {r := tsl_tokenizeex_2_(s,1);
         cs := r["class"];
         if ifarray(cs)and cs[0]then
         begin
@@ -1438,8 +1438,9 @@ type TPageEditerItem=class(TPageItem)
                 end;
                 return; //返回
             end
-        end
+        end}
-        FTslParser := nil;
+        if not FTslParser then FTslParser := new ttslscripparser(); #! end
+        //FTslParser := nil;
     end
     function GetClassInfo(); //获得信息
     begin

designer/utslvcldcomponents.tsf

@@ -469,7 +469,7 @@ type TDComponent = class()
         FTreeNode := nil;
         FCwnd := nil;
     end 
-    function SetComponentProperties(n,v);
+    function SetComponentProperties(n,v,pp);
     begin
     {**
         @explan(说明)修改属性%%
@@ -480,7 +480,7 @@ type TDComponent = class()
             begin    
                 return SetComponentName(v);
             end else 
-                return FCwnd.SetPublish(n,v);
+                return FCwnd.SetPublish(n,v,pp);
         end 
     end 
     function GetTrueComponent();virtual;
@@ -753,7 +753,7 @@ type TDVirutalWindow = class(TCustomControl) //
         end 
         return r;
     end 
-    function SetPublish(n,v);override; //设置属性
+    function SetPublish(n,v,pp);override; //ÉèÖÃÊôÐÔ
     begin
         if n in FWindowFileds then 
         begin
@@ -761,7 +761,7 @@ type TDVirutalWindow = class(TCustomControl) //
         end 
         if FBindComponent then 
         begin
-            return FBindComponent.SetPublish(n,v);
+            return FBindComponent.SetPublish(n,v,pp);
         end 
     end 
     function DesigningSizer();override; //鼠标改变大小
@@ -885,6 +885,17 @@ type TDForm = class(TDComponent)
             d.openclassfile();
         end 
     end 
+    function opentfm(o,e);
+    begin
+        cp:=o.Component;
+        if not cp then exit;
+        nd := cp.TreeNode;
+        if nd then d := nd.owner.Designer;
+        if d then 
+        begin
+            d.opentfm();
+        end 
+    end 
     public 
     function menus();override;
     begin
@@ -892,6 +903,7 @@ type TDForm = class(TDComponent)
         //r[0] := array("type":"menu","caption":"保存窗口");
         idx := 0;
         r[idx++] := array("type":"menu","caption":"打开tsf文件","onclick":thisfunction(OpenClass));
+        r[idx++] := array("type":"menu","caption":"´ò¿ªtfmÎļþ","onclick":thisfunction(opentfm));
         r[idx++] := array("type":"menu","caption":"关闭窗口","onclick":thisfunction(closecurrentform));
         r[idx++] := array("type":"menu","caption":"保存窗口","onclick":thisfunction(savecurrentform));
         r[idx++] := array("type":"menu","caption":"粘贴","onclick":thisfunction(pasteclick));
@@ -1230,7 +1242,7 @@ type TGraphicLabelWindow = class(TDVirutalWindow)
         al := BindComp.TextAlign;
         BindComp.CanvasDrawAlignText(self.canvas,self.ClientRect,self.caption,al);
     end 
-    function SetPublish(n,v);override;
+    function SetPublish(n,v,pp);override;
     begin
         r := inherited;
         if n="bkbitmap" then bkbitmap := v;
@@ -1262,7 +1274,7 @@ type TGraphicsplitterWindow = class(TDVirutalWindow)
         //al := BindComp.TextAlign;
         //BindComp.CanvasDrawAlignText(self.canvas,self.ClientRect,self.caption,al);
     end 
-    function SetPublish(n,v);override;
+    function SetPublish(n,v,pp);override;
     begin
         r := inherited;
         //if n="color" then color := v;

funcext/tvclib/tcomponent.tsf

@@ -450,6 +450,7 @@ public //
 #!end		
     private //设计器中属性事件相关
     FEventsProperties;
+    FChangedPropertiesflg;
     FChangedProperties;
     FVariableProperties;
     function GetPublishInfo();//属性获取
@@ -551,6 +552,7 @@ public //
         for i,vi in ps do
         begin
             n := vi["name"];
+            if ifarray(FChangedPropertiesflg) and  FChangedPropertiesflg[n] then continue;
             vv := FChangedProperties[n];
             if ifnil(vv)then continue;
             vit := vi["type"];
@@ -568,14 +570,18 @@ public //
         end
         return r;
     end
-    function SetChangedPublish(n,v);virtual;//设置属性
+    function SetChangedPublish(n,v,pp);virtual;//ÉèÖÃÊôÐÔ
     begin
         {**
         @explan(说明) 设计器相关函数 %%
         **}
         if not ifarray(FChangedProperties)then FChangedProperties := array();
+        if not ifarray(FChangedPropertiesflg)then FChangedPropertiesflg := array();
+        if pp then FChangedPropertiesflg[n] := true;
         //reindex(FChangedProperties,array(n:nil));
+        if FChangedProperties[n]=v then return ;
         FChangedProperties[n]:= v;
+        if not(pp) then reindex(FChangedPropertiesflg,array(n:nil));
     end
     function DeleteChangedPublish(n);virtual;//删除属性
     begin
@@ -585,7 +591,7 @@ public //
             reindex(FChangedProperties,array(n:nil));
         end
     end
-    function SetPublish(n,v);virtual;//设置属性
+    function SetPublish(n,v,pp);virtual;//ÉèÖÃÊôÐÔ
     begin
         {**
         @explan(说明) 修改单个值,设计器使用 %%
@@ -602,7 +608,7 @@ public //
                 if ifobj(otype)then
                 begin
                     iv := otype.UnformatEdit(v); //反转换
-                    SetChangedPublish(n,iv); //保存
+                    SetChangedPublish(n,iv,pp); //±£´æ
                     if vit="eventhandler" then //分类保存
                     begin
                         FEventsProperties[n]:= iv;

funcext/tvclib/tslvcl.tsf

@@ -208,7 +208,7 @@ type Ttfm2Component = class(TTmfParser)
             self.Script := s;
             lazydata := array();
             //lazydata[0] := array();
-            darray := gettree();
+            darray := gettree2(); 
             SetTfmData(owner,owner,darray,lazydata);
             for i,v in lazydata do
             begin
@@ -228,6 +228,17 @@ type Ttfm2Component = class(TTmfParser)
         Loadinherited(owner); //µ¼Èë
     end
     private
+    function hastfmfile(phs,cn);
+    begin
+        for i,v in phs do 
+        begin
+            pi := v+cn+".tfm";
+            if fileexists("",pi) then 
+            begin
+                return true;
+            end 
+        end 
+    end 
     function Loadtfmtoform(o,phs,cn);
     begin
         for i,v in phs do
@@ -252,20 +263,21 @@ type Ttfm2Component = class(TTmfParser)
         o2 := o;
         phs := static GetSourceDirs();
         objs := array();
+        fssourdirs := phs;
         while true do 
         begin
             ci := o2.classinfo();
             cn := ci["classname"];
-            ic := ci["inherited"][0];
+            if cn="tdcreateform" or cn="tdcreatepanel" then return ;
-            if((cn<>"tdcreateform") and (cn<>"tdcreatepanel")) then
+            if hastfmfile(phs,cn) then 
             begin
-                objs[length(objs)] := cn;
+                Loadtfmtoform(o2,phs,cn);
+                return ;
+            end 
+            ic := ci["inherited"][0];
+            if ic then 
                 o2 :=  findclass(ic,o2); 
-            end else break;        
+            else return ;                  
-        end  
-        for i := length(objs)-1 downto 0 do 
-        begin
-            Loadtfmtoform(o,phs,objs[i]);
         end        
     end  
     function GetSourceDirs();

funcext/tvclib/utslvclmenu.tsf

@@ -802,7 +802,7 @@ private
         end
     end    
     public
-    function SetChangedPublish(n,v);virtual;
+    function SetChangedPublish(n,v,pp);virtual;
     begin
         {**
         @explan(说明) 设计器相关函数 %%

funcext/tvclib/uvcpropertytypespersistence.tsf

@@ -90,7 +90,7 @@ type TTmfParserToken = class(TTmfParserbase)
     FSyms; //符号
     FNumberChar;
     FHexChar;
-    Function SetScript(S);
+    Function SetScript(S);//设置文本
     begin
         IF FScript <> S then
         begin
@@ -105,7 +105,7 @@ type TTmfParserToken = class(TTmfParserbase)
         end
     end
     public
-    class function sinit();override;
+    class function sinit();override;//初始化
     begin
         inherited;
     end
@@ -130,7 +130,7 @@ type TTmfParserToken = class(TTmfParserbase)
     begin
         return FCurrent<FScriptLen;
     end
-    class function delct(r,ct,len,n);
+    class function delct(r,ct,len,n);//处理字符
     begin
         {**
         @explan(说明) 处理当前字符 %%
@@ -147,7 +147,7 @@ type TTmfParserToken = class(TTmfParserbase)
             ct := "";
         end
     end
-    function GetNumber(len);
+    function GetNumber(len);//解析数字
     begin
         c := cchar();
         r := "";
@@ -218,7 +218,7 @@ type TTmfParserToken = class(TTmfParserbase)
             goto parnb;
         end
     end
-    function GetBinary(len);
+    function GetBinary(len); //二进制数据
     begin
         r := "";
         while whileok() do
@@ -236,7 +236,7 @@ type TTmfParserToken = class(TTmfParserbase)
             r += c;
         end
     end
-    function gettokens();
+    function gettokens();//解析字符
     begin
         {**
         @explan(说明) 解析token %%
@@ -335,7 +335,7 @@ type TTmfParserToken = class(TTmfParserbase)
         end
         return r;
     end
-    function PHexNumber();
+    function PHexNumber();//16进制解析
     begin
         {**
         @explan(说明)解析16进制数
@@ -406,12 +406,14 @@ type TTmfParser = class(TTmfParserbase)
     {**
     @explan(说明)tmf文件解析 %%
     **}
+    fssourdirs;
     private
     FCurrent;
     FTokens;
     FTokenlen;
     FParsers;
     FTree;
+    ftreeobj;
     FS;
     function SetScriptPath(fn);
     begin
@@ -421,18 +423,19 @@ type TTmfParser = class(TTmfParserbase)
             if readFile(rwraw(),"",fn,0,size,data)then
             begin
                 Script := data;
-            end
+            end else Script := "";
         end
     end
     function SetScript(s);
     begin
-        if fs <> s then
+        if (fs <> s) and ifstring(s)  then
         begin
             FParsers.Script := s;
             FTokens := FParsers.gettokens();
             FTokenlen := length(FTokens);
             FCurrent := 0;
             FTree := nil;
+            ftreeobj := nil;
         end
     end
     public
@@ -535,21 +538,6 @@ type TTmfParser = class(TTmfParserbase)
                 return v;
             end else
             return tostn(v);
-            {sa := ord("a");
-            sz := ord("z");
-            s0 := ord("0");
-            s9 := ord("9");
-            IsVariableName
-            for i := 1 to length(v) do 
-            begin
-            vi := v[i];
-            ov := ord(vi);
-            if not((ov>=sa and ov<=sz)or( ov>=s0 and ov<=s9)or(vi="_") ) then 
-            begin
-            return tostn(v);
-            end 
-            end 
-            return v;}
         end else
         return tostn(v);
     end
@@ -563,6 +551,7 @@ type TTmfParser = class(TTmfParserbase)
             r[length(r)]:= v["name"];
             call(thisfunction,v,r);
         end
+        return r;
     end
     function gettree();
     begin
@@ -574,6 +563,84 @@ type TTmfParser = class(TTmfParserbase)
         return array();
         //return echo tostn(CreateObj());
     end
+    function gettree2(); //获得继承关系树
+    begin
+        d := gettreeasobject();  
+        if d then 
+        begin  
+            d.setinhertedpaths(fssourdirs);//设置路径
+            d.initinherited(); 
+            return object2tree2(d);
+        end         
+    end 
+    function inheritedcoy(n,t,ht);
+    begin
+        d := gettreeasobject();  
+        if d then 
+        begin  
+            d.setinhertedpaths(fssourdirs);//设置路径
+            d.initinherited(); 
+            return d.inheritedstr(n,t,ht,0);
+        end 
+        return "";
+    end 
+    function object2tree2(t); //获得继承关系
+    begin
+        r := array();
+        r["inherited"] := t.ifinherited;
+        r["class"] := t.fnodetype;
+        r["name"] := t.fnodename;
+        r["parent"] := t.finheritedname;
+        ps := array();
+        vps := t.getallpropertys();
+        for i,v in vps.IndexNames() do 
+        begin
+            vi := vps[v];
+            ps[v] := array("name":v,"value":vi.fvalue,"type":vi.ftype,"pp":vi.finh);
+        end 
+        objs := array();
+        fos := t.fobjects;
+        for i,v in fos.IndexNames() do 
+        begin
+            objs[v] :=  object2tree2(fos[v]);   
+        end 
+        r["property"] := ps;
+        r["object"] := objs;
+        
+        return r;
+    end 
+    function gettreeasobject();
+    begin
+        if ftreeobj then return ftreeobj;
+        gettree();
+        if FTree then 
+        begin
+            //ttfmnode
+            ftreeobj := createndeobjects(FTree);
+            return ftreeobj;
+        end 
+        return nil;
+    end 
+    function createndeobjects(d);
+    begin
+        if ifarray(d) then 
+        begin
+            r := new ttfmnode(d["class"],d["name"]);
+            r.ifinherited := d["inherited"]; 
+            r.finheritedname := d["parent"];
+            for i,v in d["property"] do 
+            begin
+                r.setprovalue(v["name"],v["value"],v["type"]);
+            end  
+            for i,v in d["object"] do 
+            begin
+                vi := createndeobjects(v);
+                r.addobject(vi);
+            end  
+            return r;      
+        end 
+    end 
+    
     function TSLasItem(d);
     begin
         if not ifarray(d)then return totfmstr(d);
@@ -641,7 +708,13 @@ type TTmfParser = class(TTmfParserbase)
         while whileok() do
         begin
             ctoken(tv,tt);
-            if tv="object" and(tt <> TT_STR)then return getobject();
+            if (tv="object" or tv="inherited") and(tt <> TT_STR) then 
+            begin
+                r :=  getobject();
+                if tv="inherited" then 
+                    r["inherited"] := true;
+                return r;
+            end 
         end
     end
     function getobject();
@@ -660,6 +733,7 @@ type TTmfParser = class(TTmfParserbase)
         rt := getmembers();
         r["property"]:= rt["property"];
         r["object"]:= rt["object"];
+        r["parent"] := rt["parent"];
         return r;
     end
     function GetSampleValue();
@@ -727,9 +801,11 @@ type TTmfParser = class(TTmfParserbase)
         while whileok() do
         begin
             ctoken(tv,tt);
-            if tv="object" and tt <> TT_STR then
+            if (tv="object" or tv="inherited") and tt <> TT_STR then
             begin
                 ro := getobject();
+                if (tv="inherited") then 
+                    ro["inherited"] := true;
                 r["object"][objlen++]:= ro;
             end else
             if tv="end" and tt <> TT_STR then
@@ -756,6 +832,15 @@ type TTmfParser = class(TTmfParserbase)
                 end
                 pp := tv;
             end else
+            if tt=TT_SIG and tv="(" then 
+            begin
+                while whileok() do 
+                begin 
+                    ctoken(tv,tt);
+                    if tt=TT_SIG and tv=")" then break;
+                    r["parent"] := tv;
+                end                 
+            end else 
             PError("其他错误",1);
         end
         return r;
@@ -1997,6 +2082,196 @@ end
 
 //////////////////////////////////////////////////////////////////////////
 implementation
+type tproper = class()
+    function create(t,v);
+    begin
+        fvalue := v;
+        ftype := t;
+    end 
+    fvalue;
+    ftype;
+    finh;
+
+end 
+type ttfmnode = class()
+    function setinhertedpaths(phs);
+    begin
+        finheritedpaths := phs;
+    end 
+    function create(t,n);
+    begin
+        fnodename := n;
+        fnodetype := t;
+        fpropertys := new tstrindexarray();
+        fobjects := new tstrindexarray();
+        finheritedpaths := array();
+    end 
+    function initinherited();
+    begin
+        s := finheritedname;
+        if s and ifstring(s) then 
+        begin
+            for i,v in finheritedpaths do 
+            begin
+                fv := v+s+".tfm";
+                if fileexists("",fv) then 
+                begin
+                    oa := new TTmfParser();
+                    oa.ScriptPath := fv;
+                    nd := oa.gettreeasobject();
+                    
+                    if ifobj(nd) then 
+                    begin                        
+                        nd.setinhertedpaths(finheritedpaths);
+                        nd.initinherited();
+                    end 
+                    finheritednode := nd;
+                    addinheritednode(nd);
+                    return ;
+                end 
+            end 
+        end     
+    end 
+    function addinheritednode(nd); //处理继承的节点
+    begin
+        for i,v in fobjects.IndexNames() do 
+        begin
+            ov := fobjects[v];
+            if ov.ifinherited then 
+            begin
+                if ifobj(nd) then 
+                begin 
+                    fd :=  nd.getnodebyname(ov.fnodename);
+                    if fd then 
+                    begin
+                        ov.finheritednode :=fd;
+                    end else //不在
+                    begin
+                        fobjects.deleteindex(v);
+                    end 
+                end else 
+                begin
+                    fobjects.deleteindex(v);                
+                end 
+            end 
+            ov.addinheritednode(nd);
+        end         
+    end 
+    function getnodebyname(sb);//获得节点
+    begin
+        if fobjects.HaveIndex(sb) then 
+        begin
+            o := fobjects[sb];
+            return o;
+        end 
+        for i,v in  fobjects.IndexNames() do 
+        begin
+            o := fobjects[v]; 
+            r := o.getnodebyname(sb);
+            if r then return r;  
+        end       
+    end 
+    function addobject(nd);
+    begin
+        if nd then 
+        begin
+            fobjects[nd.fnodename] := nd;    
+        end 
+    end 
+    function delnodebyname(sb);//删除节点
+    begin
+        if fobjects.HaveIndex(sb) then 
+        begin
+            o := fobjects[sb];
+            fobjects.deleteindex(sb);
+            return o;
+        end 
+        for i,v in  fobjects.IndexNames() do 
+        begin
+            o := fobjects[v]; 
+            r :=  delnodebyname(sb);
+            if r then return r;  
+        end               
+    end 
+    function setprovalue(p,v,t);//设置属性
+    begin
+        if not ifstring(p) then  return ;
+        if ifnil(v) then fpropertys.deleteindex(p);
+        vobj := fpropertys[p];
+        if not vobj then 
+        begin
+            vobj := new tproper(nil,true);
+            fpropertys[p] := vobj;
+        end 
+        vobj.fvalue := v;
+        vobj.ftype := t;
+    end 
+    function setobjpropvalue(sb,p,v,t);//设置值
+    begin
+        if fobjects.HaveIndex(sb) then 
+        begin
+            o := fobjects[sb];
+            o.setprovalue(p,v,t);
+            return o;
+        end 
+        for i,v in  fobjects.IndexNames() do 
+        begin
+            o := fobjects[v]; 
+            r :=  o.setobjpropvalue(sub,p,v,t);
+            if r then return r;  
+        end       
+    end 
+    function getallpropertys();//获得所有属性
+    begin
+        if not exts then exts := array();
+        if finheritednode then 
+        begin
+            r := finheritednode.getallpropertys();
+            for i,v in r.IndexNames() do 
+            begin
+                r[i].finh := true;
+            end 
+        end 
+        if not r then r := new tstrindexarray();
+        for i,v in fpropertys.IndexNames() do 
+        begin
+            r[i] := fpropertys[v];
+        end 
+        return r;
+    end 
+    function inheritedstr(n,t,ht,h);
+    begin   
+        if ifnil(n) then n := fnodename;
+        if ifnil(t) then t := fnodetype; 
+        ws := "";
+        if not(h>=0) then h := 0;
+        for i:= 0 to h-1 do 
+        begin
+            ws+="   ";        
+        end 
+        r := ws+"inherited "+n+":"+t; 
+        if ht then r+="("+ht+")";
+        r+="\r\n";
+        for i,v in  fobjects.IndexNames() do 
+        begin
+            vo := fobjects[v];
+            r+=vo.inheritedstr(nil,nil,nil,h+1);
+        end 
+        r+="\r\n";
+        r+=ws+"end\r\n";   
+        return r;       
+    end 
+    ifinherited;
+    finheritedname;
+    finheritednode;
+    fnodetype; //属性,对象
+    fnodename;
+    fobjects;
+    private 
+    fpropertys;
+    
+    finheritedpaths;
+end 
 function tablelines(str,n);
 begin
     lines := str2array(str,"\r\n");