From 7f8ea0018186369d312df721ca58d64e4ca7806d Mon Sep 17 00:00:00 2001 From: JianjunLiu Date: Mon, 22 May 2023 15:36:07 +0800 Subject: [PATCH] =?UTF-8?q?=E7=BC=96=E8=BE=91=E5=99=A8?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 淇 --- .../resource.tfm/textcompclassadder.tfm | 80 ++ .../ctl_mgr/resource.tfm/textcompclassmgr.tfm | 64 ++ designer/ctl_mgr/textcompclassadder.tsf | 151 ++++ designer/ctl_mgr/textcompclassmgr.tsf | 97 +++ designer/gettslvcldesignerstart.tsf | 10 + designer/tslvcldesigner.tsf | 220 ++++- designer/udesignerproject.tsf | 89 +- designer/utslvcldcomponents.tsf | 52 +- designer/utslvcldesignerresource.tsf | 19 +- funcext/tvclib/tslvcl.tsf | 6 - funcext/tvclib/utslmemo.tsf | 52 +- funcext/tvclib/utslvclgdi.tsf | 6 +- funcext/tvclib/utslvclgrid.tsf | 21 + funcext/tvclib/utslvclpage.tsf | 769 ++++-------------- funcext/tvclib/utslvclstdctl.tsf | 36 +- 15 files changed, 970 insertions(+), 702 deletions(-) create mode 100644 designer/ctl_mgr/resource.tfm/textcompclassadder.tfm create mode 100644 designer/ctl_mgr/resource.tfm/textcompclassmgr.tfm create mode 100644 designer/ctl_mgr/textcompclassadder.tsf create mode 100644 designer/ctl_mgr/textcompclassmgr.tsf diff --git a/designer/ctl_mgr/resource.tfm/textcompclassadder.tfm b/designer/ctl_mgr/resource.tfm/textcompclassadder.tfm new file mode 100644 index 0000000..317d1cc --- /dev/null +++ b/designer/ctl_mgr/resource.tfm/textcompclassadder.tfm @@ -0,0 +1,80 @@ +object extcompclassadder:textcompclassadder + caption="添加" + height=406 + left=474 + minmaxbox=false + onclose=extcompclassadder_close + top=316 + width=402 + wssizebox=false + object e_classname:tedit + caption="edit1" + height=25 + left=91 + readonly=true + top=28 + width=255 + end + object label1:tlabel + left=20 + top=28 + width=50 + height=25 + caption="控件类" + end + object b_classfile:tbtn + caption="..." + height=24 + left=354 + onclick=b_classfile_clk + top=29 + width=21 + end + object label2:tlabel + left=20 + top=72 + width=64 + height=25 + caption="图标" + end + object p_imgshow:tpanel + caption="img" + height=187 + left=91 + top=120 + width=245 + wsdlgmodalframe=false + end + object b_img:tbtn + caption="添加图标" + height=25 + left=91 + onclick=b_img_clk + top=73 + width=94 + end + object b_ok:tbtn + caption="确定" + enabled=true + height=31 + left=133 + onclick=b_ok_clk + top=317 + width=72 + end + object b_cancel:tbtn + caption="取消" + height=31 + left=283 + onclick=b_cancel_clk + top=317 + width=73 + end + object f_open:topenfileadlg + left=22 + top=146 + height=30 + width=30 + caption="文件选择" + end +end \ No newline at end of file diff --git a/designer/ctl_mgr/resource.tfm/textcompclassmgr.tfm b/designer/ctl_mgr/resource.tfm/textcompclassmgr.tfm new file mode 100644 index 0000000..c92a59e --- /dev/null +++ b/designer/ctl_mgr/resource.tfm/textcompclassmgr.tfm @@ -0,0 +1,64 @@ +object extcompclassmgr:textcompclassmgr + caption="注册控件-管理" + height=467 + left=447 + minmaxbox=false + onclose=extcompclassmgr_close + top=272 + width=477 + wssizebox=true + object listbox1:tlistbox + caption="listbox1" + height=345 + left=4 + onselchanged=listbox1_sel + top=38 + width=344 + end + object b_del:tbtn + caption="删除" + enabled=false + height=31 + left=364 + onclick=b_del_clk + top=248 + width=88 + end + object b_add:tbtn + caption="添加" + height=31 + left=364 + onclick=b_add_clk + top=299 + width=88 + end + object b_ok:tbtn + caption="完成" + height=31 + left=364 + onclick=b_ok_clk + top=346 + width=88 + wssizebox=false + wssysmenu=false + end + object statusbar1:tstatusbar + caption="statusbar1" + height=25 + items= [< + width=500 + text="控件管理" + > + ] + left=0 + top=403 + width=461 + end + object label1:tlabel + left=8 + top=10 + width=80 + height=25 + caption="控件列表" + end +end \ No newline at end of file diff --git a/designer/ctl_mgr/textcompclassadder.tsf b/designer/ctl_mgr/textcompclassadder.tsf new file mode 100644 index 0000000..9b96233 --- /dev/null +++ b/designer/ctl_mgr/textcompclassadder.tsf @@ -0,0 +1,151 @@ +type textcompclassadder=class(tdcreateform) + uses tslvcl; + e_classname:tedit; + label1:tlabel; + b_classfile:tbtn; + label2:tlabel; + p_imgshow:tpanel; + b_img:tbtn; + + b_ok:tbtn; + b_cancel:tbtn; + f_open:topenfileadlg; + function Create(AOwner);override; //构造 + begin + inherited; + end + + + function extcompclassadder_close(o;e);virtual; + begin + e.skip := true; + Visible := false; + EndModal(0); + inherited; + + end + + function b_cancel_clk(o;e);virtual; + begin + EndModal(0); + end + function b_ok_clk(o;e);virtual; + begin + s := e_classname.text; + if fclasshash and fclasshash[s] then + begin + messageboxa("该控件已经注册","提示",0,self); + return ; + end + o := findclass(s); + if not (o is class(TWinControl)) then + begin + messageboxa("组件类型错误,或者组件不存在","提示",0,self); + return ; + end + if not fbmp then + begin + messageboxa("请选择合适的图标","提示",0,self); + return ; + end + EndModal(1); + end + function b_img_clk(o;e);virtual; + begin + f_open.filter := array("图片文件":"*"); + if not(f_open.OpenDlg()) then return ; + fbmp := new TBitmap(); + fbmp.id := f_open.filename; + p_imgshow.BKBitmap := fbmp; + if fbmp.HandleAllocated() then return ; + fbmp := nil; + end + + function b_classfile_clk(o;e);virtual; + begin + f_open.filter := array("控件类文件":"*.tsf"); + e_classname.text := ""; + if not(f_open.OpenDlg()) then return ; + iof := iofileseparator(); + fn := f_open.filename; + nf := fn[1:length(fn)-4]; + n := ""; + for i:= length(nf) downto 1 do + begin + vi := nf[i]; + if vi=iof then + begin + + break; + end + n := vi+n; + end + ln := lowercase(n); + e_classname.text := ln; + end + function DoControlAlign();override;//对齐子控件 + begin + //当窗口大小改变时,该函数会被调用, + //可以通过 clientrect 获取客户区大小,设置子控件的位置以及大小 + //如果自己处理了子控件的对齐,就可以去掉 inherited + inherited; + end + function Recycling();override; //回收变量 + begin + inherited; + ci := self.classinfo(); //将成员变量赋值为nil避免循环引用 + for i,v in ci["members"] do + begin + if v["static"] then continue; + invoke(self,v["name"],nil); + end + end + function createdclass(); + begin + ra := %% type %s =class(TDComponent) + uses utslvcldcomponents; + function create(AOwner); + begin + inherited; + end + function classification();override; + begin + return "自定义"; + end + function bitmapinfo();override; + begin + return "%s"; + end + function WndClass();override; + begin + return Class(%s); + end +end +%%; + r := format(ra,"td_a_"+e_classname.text,TslToHexFormatStr(fbmp.tovcon()),e_classname.text); + return r; + end + function getreginfo(); + begin + r := array(); + r["name"] := e_classname.text; + r["dclassname"] := "td_a_"+e_classname.text; + r["dclassbody"] := createdclass(); + return r; + end + property classhash read fclasshash write setclasshash; + fclasshash; + fbmp; + private + function setclasshash(v); + begin + if v<>fclasshash then + begin + fclasshash := array(); + for i,vi in v do + begin + fclasshash[vi] := true; + end + end + end +end diff --git a/designer/ctl_mgr/textcompclassmgr.tsf b/designer/ctl_mgr/textcompclassmgr.tsf new file mode 100644 index 0000000..72e7f41 --- /dev/null +++ b/designer/ctl_mgr/textcompclassmgr.tsf @@ -0,0 +1,97 @@ +type textcompclassmgr=class(tdcreateform) + uses tslvcl; + listbox1:tlistbox; + b_del:tbtn; + b_add:tbtn; + b_ok:tbtn; + statusbar1:tstatusbar; + label1:tlabel; + function Create(AOwner);override; //构造 + begin + inherited; + end + function extcompclassmgr_close(o;e);virtual; + begin + + {** + @explan(说明) 主窗口关闭回调 %% + @param(e)(tuievent) 消息对象 %% + @param(o)(ttimer) 当前主窗口 %% + **} + e.skip:= true; + Visible := false; + inherited; + + end + + function b_ok_clk(o;e);virtual; + begin + Visible := false; + end + function b_del_clk(o;e);virtual; + begin + idx := listbox1.ItemIndex; + if idx>=0 and parent then + begin + p := parent; + p.delexttypeclass(listbox1.getItemText(idx)); + relisttypeclass(); + end + end + function b_add_clk(o;e);virtual; + begin + if not fadder then + begin + fadder := new textcompclassadder(self); + fadder.Visible := false; + fadder.parent := self; + fadder.Left := left-10; + fadder.top := top-10; + end + fadder.classhash := ftypelist; + if fadder.ShowModal() then + begin + //echo tostn(fadder.getreginfo()); + p := parent; + if p then + begin + p.addexttypeclass(fadder.getreginfo()); + end + relisttypeclass(); + end + end + function relisttypeclass(); + begin + p := parent; + if p then + begin + ts := p.getexttypeclass(); + r := array(); + idx := 0; + for i,v in ts do + begin + r[idx++] := v.dclassname(); + end + if r<>ftypelist then + begin + listbox1.Items := r; + ftypelist := r; + end + end + end + function showmgr(); + begin + relisttypeclass(); + show(); + end + function listbox1_sel(o;e);virtual; + begin + idx := o.ItemIndex; + if idx>=0 then + begin + b_del.Enabled := true; + end + end + [weakref]fdesginer; + ftypelist; +end diff --git a/designer/gettslvcldesignerstart.tsf b/designer/gettslvcldesignerstart.tsf index 6acbea1..de00e5e 100644 --- a/designer/gettslvcldesignerstart.tsf +++ b/designer/gettslvcldesignerstart.tsf @@ -78,3 +78,13 @@ function PostMessageA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):in function FindWindowA(lpClassName:string;lpWindowName:string):pointer;stdcall;external "User32.dll" name "FindWindowA";//引入api {$endif} +function getdcompath(); +begin + {$ifdef linux} + bpath := ".vcl/tsl/"; + {$else} + bpath := TS_GetUserProfileHome(); + {$endif} + return bpath+"designer"+ioFileseparator()+"dcmps"+ioFileseparator(); +end + diff --git a/designer/tslvcldesigner.tsf b/designer/tslvcldesigner.tsf index f815cc3..8359b81 100644 --- a/designer/tslvcldesigner.tsf +++ b/designer/tslvcldesigner.tsf @@ -21,6 +21,7 @@ type TVclDesigner = class(tvcform) FChmHelper; //帮助文档 fdimagelist; //图标 FViewBitmap; //图片管理器 + fmgr_ctl;//控件管理 FVariableSelecter; //当前控件树的变量 FFunctionSelecter; //当前控件树的函数 //**********菜单*************** @@ -69,20 +70,27 @@ type TVclDesigner = class(tvcform) **} for i,v in class(TDComponent).GetClassItem() do begin - fdimagelist.RegisterDitem(v); - //if not v.InToolBar() then continue; - tb := new TToolButton(self); - tb.caption := v.HitTip; - tb.Enabled := v.InToolBar(); - ig := fdimagelist.GetImageId(V.dclassname); - tb.imageid := ig; - v.Imgs := ig; - tb._tag := v; - tb.onclick := thisfunction(OnToolButtonCick); - FToolBars.addbtn(tb,v.classification); + addaboolbutton(v); end end - + function addaboolbutton(v); + begin + fdimagelist.RegisterDitem(v); + //if not v.InToolBar() then continue; + tb := new TToolButton(self); + tb.caption := v.HitTip; + tb.Enabled := v.InToolBar(); + ig := fdimagelist.GetImageId(V.dclassname); + tb.imageid := ig; + v.Imgs := ig; + tb._tag := v; + tb.onclick := thisfunction(OnToolButtonCick); + FToolBars.addbtn(tb,v.classification); + end + function delttolbutton(n); + begin + FToolBars.delbtn(n); + end function calcheight(twidth); //高度计算 begin //extheight := CaptionHeight()+MenuBarHeight(); @@ -495,6 +503,7 @@ type TVclDesigner = class(tvcform) )), ("type":"menu","caption":"工具","items":( + ("type":"menu","caption":"控件管理","checked":0,"onclick":thisfunction(mgr_control)), ("type":"menu","caption":"打开图片","checked":0,"onclick":thisfunction(ViewBitmap)), ("type":"menu","caption":"编辑器颜色","checked":0,"onclick":thisfunction(showhltcolor)) )), @@ -1095,6 +1104,40 @@ type TVclDesigner = class(tvcform) end end end + public //类型注册相关 + function addexttypeclass(info);//注册额外的类 + begin + addextdtypeclass(info["dclassname"],info["dclassbody"]); //添加容器类 + addexttypeclasstoini(info["name"],info["dclassname"]);//添加ini文件 + fwilladdclasstype := info["dclassname"]; + fwilladdclass := info["name"]; + dc := findclass(fwilladdclasstype); + if not dc then return ; + addexttypeclasscomp(dc); + it := class(TDComponent).GetClassItemext(fwilladdclass); + if not it then return ; + addaboolbutton(it); + + //name + //class + //dclassbody + + //添加类型 + //添加工具栏 + + + end + function delexttypeclass(n);//删除注册类 + begin + delexttypeclassini(n);//移除ini文件 + delexttypeclasscomp(n);//移除类型 + delttolbutton(n);//移除工具栏 + end + function getexttypeclass(n);//获得注册类列表 + begin + r:= class(TDComponent).GetClassItemext(n); + return r; + end public //加载以及处理 function ExecuteCommand(cmd,p);override; begin @@ -1270,7 +1313,6 @@ type TVclDesigner = class(tvcform) function create(AOwner); begin inherited; - top := 10; left := 10; rect := _wapi.GetScreenRect(); @@ -1406,6 +1448,18 @@ type TVclDesigner = class(tvcform) begin FProjectManager.showhltcolor(); end + function mgr_control(); + begin + if not fmgr_ctl then + begin + fmgr_ctl := new textcompclassmgr(self); + fmgr_ctl.visible:= false; + fmgr_ctl.left := left+300; + fmgr_ctl.top := top+300; + fmgr_ctl.parent := self; + end + fmgr_ctl.showmgr(); + end function ViewBitmap(o,e); begin if not FViewBitmap then @@ -1743,6 +1797,7 @@ type TDesignertoolbars = class(TPageControl) // function Create(AOwner);override; begin inherited; + ftbs := array(); align := alClient; FToolbars := array(); Flabelcharlen := 0; @@ -1802,9 +1857,17 @@ type TDesignertoolbars = class(TPageControl) // tb.imagelist := fimg; FToolbars[t] := tb; end + ftbs[btn._tag.dclassname()] := btn; btn.parent := tb; end + function delbtn(n); + begin + btn := ftbs[n]; + if btn then btn.Recycling(); + end property ImageList write SetImageList; + private + [weakref]ftbs; end @@ -1918,45 +1981,112 @@ type TViewBitmap = class(TvcForm) end end - +type tdcompextmgr = class() + function create(AOwner); + begin + + fini := new TIniFileExta("",ffile); + end + function getcomplist(); + begin + class(TDComponent).GetClassItemext(); + end + function addclass(f) + begin + + end + private + fini; + ffile ; +end +function getdesignerpath(); +begin + {$ifdef linux} + bpath := ".vcl/tsl/"; + {$else} + bpath := TS_GetUserProfileHome(); + {$endif} + return bpath+"designer"+ioFileseparator(); +end +function getdesginerini(); +begin + vclini := static getdesignerpath()+"tslvcldesigner.ini"; + CreateDirWithFileName(vclini); + ini := new TIniFileExta("",vclini); + ini.LowerKey := true; + return ini; +end +function addextdtypeclass(n,body); +begin + dir := static getdesignerpath()+"dcmps"+ioFileseparator(); + nf := dir+n+".tsf"; + CreateDirWithFileName(nf); + filedelete("",nf); + len := length(body); + p := 0; + writefile(rwraw(),"",nf,p,len,body); +end +function addexttypeclasstoini(n,dn); +begin + ini := static getdesginerini(); + ini.WriteKey("components",n,dn); +end +function delexttypeclassini(n); +begin + ini := static getdesginerini(); + kn := ini.ReadKey("components",n,""); + ini.DeleteKey("components",n); + if kn then + begin + dir := static getdesignerpath()+"dcmps"+ioFileseparator(); + nf := dir+kn+".tsf"; + filedelete("",nf); + end +end +function addexttypeclasscomp(cmp); +begin + class(TDComponent).RegestorClassItemsext(array(cmp)); +end +function delexttypeclasscomp(n); +begin + class(TDComponent).unregestorclassitemsext(n); +end function staticInit(); begin + np := getdesignerpath()+"dcmps"+ioFileseparator(); + CreateDirWithFileName(np+"1.txt"); + tsl_setlibpath_( np+";"+tsl_getlibpath_()); + ini := static getdesginerini(); //class(TDSocketServer),class(TDSocketClient), - //注册的componet - vclini := pluginpath()+"tslvcldesigner.ini"; - if fileexists("",vclini) then + //注册的componet + its := array(); + for i,v in ini.ReadSectionValues("components") do //控件 begin - ini := new TIniFileExta("",vclini); - ini.LowerKey := true; - its := array(); - for i,v in ini.ReadSectionValues("components") do //控件 + if v then begin - if v then + cv := findclass(v); + if cv then begin - cv := findclass(v); - if cv then - begin - its[length(its)] := cv; - end - end - end - o := class(TDComponent); - o.RegestorClassItems(its); - its := array(); - o := class(TPropGrid); - for i,v in ini.ReadSectionValues("properties") do //属性 - begin - if v then - begin - cv := findclass(v); - if cv then - begin - it := createobject( cv,0); - o.RegCellRender(it); - end - end + its[length(its)] := cv; + end end - end + end + o := class(TDComponent); + o.RegestorClassItemsext(its); + its := array(); + o := class(TPropGrid); + for i,v in ini.ReadSectionValues("properties") do //属性 + begin + if v then + begin + cv := findclass(v); + if cv then + begin + it := createobject( cv,0); + o.RegCellRender(it); + end + end + end end ////5108321 initialization diff --git a/designer/udesignerproject.tsf b/designer/udesignerproject.tsf index 2502acf..a34853b 100644 --- a/designer/udesignerproject.tsf +++ b/designer/udesignerproject.tsf @@ -649,6 +649,92 @@ type TProjectView = class(TVCForm) // RenameCurrentDir(FInput.GetEditV(1)); end end + function add_exist(); //添加 + begin + if not FCProjectPath then return Messageboxa("工程没打开","提示",0,self); + if not ffileadder then + begin + ffileadder := new TOpenFileADlg(self); + ffileadder.parent := self; + end + if not ffileadder.OpenDlg() then return ; + fn := ffileadder.filename; + if 1=parseregexpr("(.+)(\\W)(\\w+)\\.tsl$",fn,"",m,mp,ml) then + begin + //return "add tsl"; + addexisttsl(m); + end + if 1=parseregexpr("(.+)(\\W)([A-Za-z]\\w+)\\.tsf$",fn,"",m,mp,ml) then + begin + //return "add tsf"; + addexisttsf(m); + end + // + + end + function addexisttsl(m); + begin + //检查变量名是否合规 + //拷贝文件 + //添加信息 + end + function addexisttsf(m,cnd); + begin + //检查变量名是否合规 + c_n := lowercase(m[0,3]); + if FTree.NameInTree(c_n,nil,true)then return MessageboxA("已经存在同名的文件","提示",0,self); + if cnd then + begin + ph := cnd.FPath; + end else + begin + ph := FTree.CurrentNode.FPath; + end + fn := array("name":n,"type":"tsf","dir":ph); + if fileexists("",m[0,1]+m[0,2]+m[0,3]+".tfm") then + begin + pr := new ttslscripparser(); + pr.ScriptPath := m[0,0]; + abt := pr.GetClassAbstract(); + if abt and (lowercase(abt["name"]) = c_n) then + begin + hi := abt["inherited",0]; + if ifstring(hi) then + begin + case lowercase(hi) of + "tdcreatepanel": + begin + + end + "tdcreateform": + begin + + end else + begin + ns := array(); + FTree.GetNodesByName(ns,hi) ; + for i,v in ns do + begin + if lowercase(v.Fname)=hi then + begin + + + return ; + end + + end + end + end + + end + + + end + + end + //添加普通tsf文件 + + end function Add_form(); begin if not FCProjectPath then return Messageboxa("工程没打开","提示",0,self); @@ -1817,6 +1903,7 @@ end end private //私有成员变量 FWrapFolder; + ffileadder; FDesigner; FCurrentOpend; FOpenProjectFile; @@ -2056,7 +2143,7 @@ type TDesignerProjectsRecoder = class() // function Create(); begin {$ifdef linux} - bpath := ".vcl/tsl/"; + bpath := ".vcl/tsl/"; {$else} bpath := TS_GetUserProfileHome(); {$endif} diff --git a/designer/utslvcldcomponents.tsf b/designer/utslvcldcomponents.tsf index e1ed0b4..4cf681a 100644 --- a/designer/utslvcldcomponents.tsf +++ b/designer/utslvcldcomponents.tsf @@ -12,6 +12,11 @@ type TDComponent = class() if ifnil(n) then return fdcomponentobjects; return fdcomponentobjects[n]; end + class function GetClassItemext(n); + begin + if ifnil(n) then return fdcomponentobjectsext; + return fdcomponentobjectsext[n]; + end class function RegestorClassItems(its); begin {** @@ -33,10 +38,36 @@ type TDComponent = class() end end end + class function RegestorClassItemsext(its); + begin + if not ifarray(fdcomponentobjectsext) then fdcomponentobjectsext := array(); + if not ifarray(fdcomponentobjects) then fdcomponentobjects := array(); + for i,v in its do + begin + if (v is class(TDComponent) ) then + begin + o := createobject(v); + n := o.dclassname(); + if n and ifstring(n) then + begin + n := lowercase(n); + if fdcomponentobjects[n] then continue; + fdcomponentobjectsext[n] := o; + fdcomponentobjects[n]:= o; + end + end + end + end + class function unregestorclassitemsext(n); + begin + if not fdcomponentobjectsext then return 0; + reindex(fdcomponentobjectsext,array(n:nil)); + end private fisiherted; finheritedparent; static fdcomponentobjects; + static fdcomponentobjectsext; protected fiscontainerdcmp; fcomponentclassname; @@ -3640,25 +3671,6 @@ type TDTabSheet = class(TDComponent) inherited; end end -type tdtabctl = class(TDComponent) - function HitTip();override; - begin - return inherited; - end - function bitmapinfo();override; - begin - return gettabctlbitmapinfo(); - - end - function WndClass();override; - begin - return Class(ttabctl); - end - function Create(AOwner);override; - begin - inherited; - end -end type TDPage = class(TDComponent) function HitTip();override; begin @@ -3725,7 +3737,7 @@ begin class(TDForm),class(TDPanelForm), class(TDPanel),class(TDGroupBox), class(TDPairSplitter),class(TDPairSplitterSide), - class(tdtabctl),class(TDPage),class(TDTabSheet), + class(TDPage),class(TDTabSheet), class(TDTimer), class(tdworkerctl), class(TDImageList), diff --git a/designer/utslvcldesignerresource.tsf b/designer/utslvcldesignerresource.tsf index 7962f93..08a8932 100644 --- a/designer/utslvcldesignerresource.tsf +++ b/designer/utslvcldesignerresource.tsf @@ -72,7 +72,6 @@ function gettoolbarbitmapinfo(); function getlabelbitmapinfo(); function getlistviewbitmapinfo(); function getgridctlbitmapinfo(); -function gettabctlbitmapinfo(); implementation function getexamplesbmpinfo(); begin @@ -1477,21 +1476,5 @@ BFC6105000000097048597300000EC300000EC301C76FA864000000A849444154 12E4B502CC89C700EAB666231483F3AA0AF0F4080A6710003344D453040D37C80 0EF0594008906401B620220406970F686A01C850644C2C20CA024A008D2DF8FF1 F0006015AA04B38837B0000000049454E44AE42608200"; -end -function gettabctlbitmapinfo(); -begin - return "0502000000060400000074797065000203000000696D670006040000006461746 -100025F01000089504E470D0A1A0A0000000D4948445200000014000000140806 -0000008D891D0D000000017352474200AECE1CE90000000467414D410000B18F0 -BFC6105000000097048597300000EC300000EC301C76FA864000000F449444154 -384FD595A10E84301044EF93F9051CC18244D460B120B128122C966FC0F6F236E -CD123A55072E626D96C774A67A785949731C62649E28D711C6D2C5E2CCCB2CCB6 -6D2BD1759D64152DCBF276B04E04191CC1033EC1B346CA07057D3C3B60EE088EE -7A782F33C5F0BEA1C811001E7E3790F4141757237B4D1A9602CD4FD9F0852B8A0 -41DFF736CF733B4D938CAF1074B8AEAB08354DB3313BE09765D9AA1D41878026C -3306CD50E78BEB923820E415555B210376CB9AE6BE18BA290466417970ED33495 -8C20DBD45A33E7EB22E810017875E73A24E3FC781C970E631174F8045F82EE05F -B343E9743E817101BC618FB068D943D91A4D430F90000000049454E44AE426082 -00"; -end +end end. \ No newline at end of file diff --git a/funcext/tvclib/tslvcl.tsf b/funcext/tvclib/tslvcl.tsf index ef1eb7a..3a50a38 100644 --- a/funcext/tvclib/tslvcl.tsf +++ b/funcext/tvclib/tslvcl.tsf @@ -2411,12 +2411,6 @@ type tpagecontrol = class(tcustompagecontrol) inherited; end end -type ttabctl = class(t_custom_tab_ctl) - function create(AOwner); - begin - inherited; - end -end //二分控件 type TPairSplitterSide=class(TCustomControl) {** diff --git a/funcext/tvclib/utslmemo.tsf b/funcext/tvclib/utslmemo.tsf index 8f7a9ca..6dbccea 100644 --- a/funcext/tvclib/utslmemo.tsf +++ b/funcext/tvclib/utslmemo.tsf @@ -888,7 +888,7 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) // end paintlinestext(RC,FirstLine,LastLine,FirstCol,LastCol); end - function DrawLongString(cvs,dtx,tl,r,rnzf); + {function DrawLongString2(cvs,dtx,tl,r,rnzf); begin if tl<1 then return ; bt := 0; @@ -912,7 +912,7 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) // lqgqy := 1; while idx<=(nqmzfs) do begin - nbt := bytetype(dtx,i)?1:0; + nbt := bytetype(dtx,idx)?1:0; if nbt<>bt then begin qgqy[lqgqy++] := array(idx,nbt); @@ -938,13 +938,16 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) // begin ft.charset := 134; end else + begin ft.charset := bn; + end + //echo ">>draw:",dtx2," --- ",ft.charset; cvs.DrawText(dtx2,r2,DT_NOPREFIX); end end ft.charset := bn; end - {function DrawLongString2(cvs,dtx,tl,r,rnzf); + function DrawLongString(cvs,dtx,tl,r,rnzf); begin bn := 100000; ft := cvs.Font; @@ -987,6 +990,49 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) // ft.charset := bn; end end} + function DrawLongString(cvs,dtx,tl,r,rnzf); + begin + bn := 100000; + ft := cvs.Font; + if rnzf>tl then + begin + for i := 1 to tl step 2 do + begin + if bytetype(dtx,i)<> 0 then + begin + bn := ft.charset; + ft.charset := 134; + break; + end + end + cvs.DrawText(dtx,r,DT_NOPREFIX); + end else + begin + qmzfs := max(1,integer((0-r[0])/FCharWidth)); + if qmzfs>3 and qmzfs 0 then + begin + bn := ft.charset; + ft.charset := 134; + break; + end + end + dtx2 := copy(dtx,qmzfs,ct); + r[0]+=(qmzfs-1)* FCharWidth; + r[2]:= r[0]+ct * FCharWidth; + cvs.DrawText(dtx2,r,DT_NOPREFIX); + end + if bn <> 100000 then + begin + ft.charset := bn; + end + end function paintlinestext(RC,FirstLine,LastLine,FirstCol,LastCol);virtual; begin diff --git a/funcext/tvclib/utslvclgdi.tsf b/funcext/tvclib/utslvclgdi.tsf index 35f4584..9394f8a 100644 --- a/funcext/tvclib/utslvclgdi.tsf +++ b/funcext/tvclib/utslvclgdi.tsf @@ -1819,7 +1819,8 @@ type TCustomImageList=class(tcomponent) FChanged := true; DestroyHandle(); addbmps(); - if inDesigning()then change(); + //if inDesigning()then + change(); end end function SetHeight(h); @@ -1830,7 +1831,8 @@ type TCustomImageList=class(tcomponent) FChanged := true; DestroyHandle(); addbmps(); - if inDesigning()then change(); + //if inDesigning()then + change(); //if not inDesigning() then DestroyHandle(); end end diff --git a/funcext/tvclib/utslvclgrid.tsf b/funcext/tvclib/utslvclgrid.tsf index 087471f..fe849e5 100644 --- a/funcext/tvclib/utslvclgrid.tsf +++ b/funcext/tvclib/utslvclgrid.tsf @@ -238,6 +238,27 @@ type TcustomGridCtl = class(tcustomscrollcontrol) // end return r; end + function hititemat(xy); //命中 + begin + r := array(); + if (ifarray(xy) and ifnumber(xy[0]) and ifnumber(xy[1])) then return r; + x := xy[0]; + y := xy[1]; + ri := GetRowIndexByPos(y); + if ri>=0 then + begin + ci := GetColIndexByPos(x); + if ci>=0 then + begin + r["ridx"]:=ri; + r["cidx"]:=ci; + rc := GetTureSubItemRect(ri,ci); + r["x"]:= x-rc[0]; + r["y"] := y-rc[1]; + end + end + return r; + end function InvalidateItem(i);virtual; begin {** diff --git a/funcext/tvclib/utslvclpage.tsf b/funcext/tvclib/utslvclpage.tsf index 2177c93..8e61399 100644 --- a/funcext/tvclib/utslvclpage.tsf +++ b/funcext/tvclib/utslvclpage.tsf @@ -1,564 +1,6 @@ unit utslvclpage; interface uses utslvclauxiliary,utslvclbase,utslvclgdi; -type t_custom_tab_ctl = class(TCustomControl) - private - fclocker;//锁 - FirstViewIndex; //第一个展示的序号 - FCurrentid; //当前 - FPrevid; //上一个 - FTabItems; // - [weakref]FOnSelChanged; - [weakref]FOnSelChanging; //正在改变 - //FOnrclick; - FTabPosition; - FTabHeight; - FTabItemswidth; - FScrollBtnRect; - Fprevrect; - fnextrect; - FTabRects; - FClientarea; - private - function SetTabPosition(v); - begin - if FTabPosition=v then exit; - if not(v in array(alTop,alBottom,alLeft,alRight)) then exit; - FTabPosition := v; - DoControlAlign(); - InvalidateRect(nil,false); - end - function CalcTabs(); //计算区域 - begin - rec := ClientRect; //区域 - FTabItemswidth := array(); - for i := 0 to FTabItems.length()-1 do - begin - wd := FTabItems[i].width; - FTabItemswidth[i] := wd; - end - FMaxsize := 0; - if FTabPosition in array(alLeft,alRight) then - begin - FTabItemswidth := zeros(length(FTabItemswidth))+maxvalue(FTabItemswidth); - FMaxsize := length(FTabItemswidth)*FTabHeight; - end else - begin - FMaxsize := sum(FTabItemswidth); - end - FClientarea := rec; - FScrollBtnRect := 0; - Fprevrect := 0; - fnextrect := 0; - FTabRects := array(); - case FTabPosition of - alLeft: - begin - if FTabItemswidth then - begin - FClientarea[0] :=rec[0]+FTabItemswidth[0]; - if length(FTabItemswidth)>1 and (FMaxsize>(rec[3]-rec[1])) then - begin - FScrollBtnRect := array(rec[0],rec[3]-FTabHeight*2,rec[0]+FTabItemswidth[0],rec[3]); - Fprevrect := array(rec[0],rec[3]-FTabHeight*2,rec[0]+FTabItemswidth[0],rec[3]-FTabHeight); - Fnextrect := array(rec[0],rec[3]-FTabHeight,rec[0]+FTabItemswidth[0],rec[3]); - end else - begin - FirstViewIndex := 0; - end - ybase := 0; - for i,v in FTabItemswidth do - begin - if i>=FirstViewIndex then - begin - FTabRects[i] := array(0,ybase,FTabItemswidth[0],ybase+FTabHeight); - ybase+=FTabHeight; - if ybase>(rec[3]-FTabHeight-FTabHeight) then break; - end - else FTabRects[i] := nil; - end - end - end - alRight: - begin - if FTabItemswidth then - begin - FClientarea[2] :=rec[2]-FTabItemswidth[0]; - if length(FTabItemswidth)>1 and (FMaxsize>(rec[3]-rec[1])) then - begin - FScrollBtnRect := array(rec[2]-FTabItemswidth[0],rec[3]-FTabHeight*2,rec[2],rec[3]); - Fprevrect := array(rec[2]-FTabItemswidth[0],rec[3]-FTabHeight*2,rec[2],rec[3]-FTabHeight); - Fnextrect := array(rec[2]-FTabItemswidth[0],rec[3]-FTabHeight,rec[2],rec[3]); - end else - FirstViewIndex := 0; - ybase := 0; - for i,v in FTabItemswidth do - begin - if i>=FirstViewIndex then - begin - FTabRects[i] := array(rec[2]-FTabItemswidth[0],ybase,rec[2],ybase+FTabHeight); - ybase+=FTabHeight; - if ybase>(rec[3]-FTabHeight-FTabHeight) then break; - end - else FTabRects[i] := nil; - end - end - end - alTop: - begin - if FTabItemswidth then - begin - FClientarea[1] :=rec[1]+FTabHeight; - if length(FTabItemswidth)>1 and (FMaxsize>(rec[2]-rec[0])) then - begin - FScrollBtnRect := array(rec[2]-FTabHeight*2,rec[1],rec[2],rec[1]+FTabHeight); - - Fnextrect := array(rec[2]-FTabHeight,rec[1],rec[2],rec[1]+FTabHeight); - Fprevrect := array(rec[2]-FTabHeight*2,rec[1],rec[2]-FTabHeight,rec[1]+FTabHeight); - end else FirstViewIndex := 0; - xbase := 0; - for i,v in FTabItemswidth do - begin - if i>=FirstViewIndex then - begin - FTabRects[i] := array(xbase,0,xbase+FTabItemswidth[i],FTabHeight); - xbase+=FTabItemswidth[i]; - if xbase>(rec[2]-FTabHeight-FTabHeight) then break; - end else - FTabRects[i] := nil; - end - end - end - alBottom: - begin - if FTabItemswidth then - begin - FClientarea[3] :=rec[3]-FTabHeight; - if length(FTabItemswidth)>1 and (FMaxsize>(rec[2]-rec[0])) then - begin - FScrollBtnRect := array(rec[2]-FTabHeight*2,rec[3]-FTabHeight,rec[2],rec[3]); - Fnextrect := array(rec[2]-FTabHeight,rec[3]-FTabHeight,rec[2],rec[3]); - Fprevrect := array(rec[2]-FTabHeight*2,rec[3]-FTabHeight,rec[2]-FTabHeight,rec[3]); - end else FirstViewIndex := 0; - xbase := 0; - for i,v in FTabItemswidth do - begin - if i>=FirstViewIndex then - begin - FTabRects[i] := array(xbase,rec[3]-FTabHeight,xbase+FTabItemswidth[i],rec[3]); - xbase+=FTabItemswidth[i]; - if xbase>(rec[2]-FTabHeight-FTabHeight) then break; - end else - FTabRects[i] := nil; - end - end - end - end - end - function InsureIdxVisible(id); //确保可见 - begin - if not(id>=0 and idFirstViewIndex then - begin - FirstViewIndex++; - end else - begin - FirstViewIndex--; - end - CalcTabs(); - end - end - function setselidx(id); //选择序号 - begin - if FCurrentid= id then return ; - if fclocker.locked then return ; - lk := new tcountlocker(fclocker); - if id>=0 and id-1 and fOnSelChanging then - begin - e := new tuieventbase(0,FCurrentid,id,0); //m,w,l,h - doonSelChanging(self(true),e); - if e.skip then return ; - end - FPrevid := FCurrentid; - FCurrentid := id; - InsureIdxVisible(id); - InvalidateRect(nil,false); - if FOnSelChanged then - begin - doonSelChange(self(true),new tuieventbase(0,FPrevid,FCurrentid,0)); - end - end else - if FTabItems.length()=0 then - begin - FPrevid := -1; - FCurrentid := -1; - end - end - function PaintTabs();//绘制tab - begin - lk := new tcountlocker(fclocker); - dc := Canvas; - dc.font := font; - ar := 0->(FTabItems.length()-1); - if FTabRects[FCurrentid] then - begin - ar[FCurrentid] := -100; - ar[length(ar)] := FCurrentid; - end - for ii,i in ar do - begin - rec := FTabRects[i]; - if rec then - begin - if fownerdraw and fondrawtab then - begin - e := new teventdrawtab(i,(FCurrentid=i),rec,dc); - CallMessgeFunction(fondrawtab,self(true),e); - continue; - end - dc.pen.color := 13158600;//rgb(200,200,200); - if FCurrentid=i then - begin - dc.brush.color := 0xf0f0f0;//rgb(100,192,250);//rgb(230,240,250);//rgb(200,200,200); - end else dc.brush.color := 16711422;//rgb(254,254,254); - dc.draw("roundrect",array(rec[0:1],rec[2:3],array(2,2))); - rec[1]+=2; - it := FTabItems[i]; - dc.drawtext(it.caption,rec,DT_CENTER .|DT_VCENTER); - end - end - end - function PaintScroll(); //绘制滚动 - begin - dc := Canvas; - if FScrollBtnRect then - begin - case FTabPosition of - alTop,alBottom: - begin - rc1 := array(FScrollBtnRect[0:1]+1,(FScrollBtnRect[0]+FTabHeight-1,FScrollBtnRect[3]-1)); - dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLLEFT); - rc1 := array((FScrollBtnRect[0]+FTabHeight+1,FScrollBtnRect[1]+1),FScrollBtnRect[2:3]-1); - dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLRIGHT); - end else - begin - rc1 := array(FScrollBtnRect[0:1]+1,(FScrollBtnRect[2]-1,FScrollBtnRect[3]-FTabHeight-1)); - dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLUP); - rc1 := array((FScrollBtnRect[0]+1,FScrollBtnRect[3]-FTabHeight+1),FScrollBtnRect[2:3]-1); - dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLDOWN); - end - end - end - end - function ScrollPrev(); //滚动到下一个 - begin - if FScrollBtnRect and FirstViewIndex>0 then - begin - FirstViewIndex-- ; - CalcTabs(); - InvalidateRect(nil,false); - end - end - function scrollnext(); //滚动到上一个 - begin - if FScrollBtnRect and FirstViewIndex=0 and idx<=len) then - begin - nidx := len; - end else nidx := idx; - n := length(nitem); - if FCurrentid >=idx then FCurrentid+=n; - FTabItems.splices(nidx,0,nitem); - lk := new tcountlocker(fclocker); - for i:= nidx to nidx+n do - measureidx(i); - CalcTabs(); - InvalidateRect(nil,false); - end - function deltab(idx,n); virtual;//删除 - begin - len := FTabItems.length()-1; - if not( n>0) then n := 1; - nidx := idx; - if not(idx>=0 and idx<=len) then - begin - return 0; - end - if not(idx>=0 and idx<=len) then - begin - nidx := len; - end else nidx := idx; - FTabItems.splice(nidx,n); - CalcTabs(); - if FCurrentid >(idx+n-1) then - begin - FCurrentid -=n; - InvalidateRect(nil,false); - end else - if FCurrentid>=idx and FCurrentid<(idx+n-1) then - begin - FCurrentid := -1; - setselidx( max(0,idx-1)); - end - end - function DesigningClick();override; - begin - return true; - end - function create(aowner); - begin - inherited; - fownerdraw := 0; - tabheight := 25; - end - function AfterConstruction();override; - begin - inherited; - fclocker := new tcountkernel(); - color := 0xffffff; - height := 200; - width := 200; - left := 10; - top := 10; - FTabPosition := alTop; - FirstViewIndex := 0; - FCurrentid := -1; - FPrevid := -1; - FTabItems := new tnumindexarray(); - end - - Function SetCurSel(id); //设置当前序号 - begin - if ifnumber(id) and id>=0 then - begin - iid := integer(id); - setselidx(iid); - end - end - function paint();override; //绘制 - begin - PaintTabs(); - PaintScroll(); - end - function MouseUp(o,e);override;//鼠标弹起 - begin - if csDesigning in ComponentState then return; - if e.skip then return ; - ps := e.pos(); - mb := e.button(); - if (mb=mbLeft) and FScrollBtnRect and pointinrect(ps,fnextrect) then - begin - if e.Button() = mbLeft then - ScrollNext(); - return ; - end else - if (mb=mbLeft) and FScrollBtnRect and pointinrect(ps,Fprevrect) then - begin - if e.Button() = mbLeft then - scrollprev(); - return ; - end - if not FTabRects then return ; - for i := 0 to length( FTabRects)-1 do - begin - v := FTabRects[i]; - if v and pointinrect(ps,v) then - begin - setselidx(i); - if Onclick and (mb = mbLeft) then - begin - CallMessgeFunction(Onclick,o,e); - end else - if onrclick and (mb = mbRight) then - begin - CallMessgeFunction(onrclick,o,e); - end - return ; - end - // - end - end - function doonSelChange(o,e);virtual; - begin - CallMessgeFunction(FOnSelChanged,o,e); - end - function doonSelChanging(o,e);virtual; - begin - CallMessgeFunction(fOnSelChanging,o,e); - end - function TabRect(AIndex: Integer); //获取区域 - begin - r := FTabRects[AIndex]; - if r then return r; - return array(0,0,0,0); - end - function DoControlAlign();override;//调整位置 - begin - CalcTabs(); - end - function gettabbyidx(idx); - begin - return FTabItems[idx]; - end - {** - @param(tabindex)(integer) 当前选中序号 %% - @param(tabsheet)(tcustomtabsheet) 通过下标获得页面 %% - @param(TabCount)(integer) page数量 %% - @param(OnSelChange)(function[tcustompagecontrol,tuieventbase]) 标签已经切换 %% - @param(OnSelChanging)(function[tcustompagecontrol,tuieventbase]) 标签正在切换 %% - **} - published - property tabs:strings read gettabs write settabs; - property tabindex:lazyinteger read FCurrentid write SetCurSel; - property OnSelChanged:eventhandler read FOnSelChanged write FOnSelChanged; - property OnSelChanging:eventhandler read FOnSelChanging write FOnSelChanging; - property ondrawtab:eventhandler read Fondrawtab write fondrawtab; - property ownerdraw:bool read fownerdraw write fownerdraw; - property onmeasuretabwidth:eventhandler read fonmeasuretabwidth write fonmeasuretabwidth; - property tabcount:integer read gettabcount ; - property tabheight:integer read ftabheight write settabheight; - property TabPosition read FTabPosition write SetTabPosition; - property tabwidth read gettabwidth write settabwidth; - private - function gettabs(); - begin - r := array(); - for i := 0 to FTabItems.length()-1 do - begin - r[i] := FTabItems[i].caption; - end - return r; - end - function gettabcount(); - begin - return ftabitems.length(); - end - function settabwidth(idx,w); - begin - if idx>0 and idx=0 and ftabitems[idx].width<>w then - begin - ftabitems[idx].width := w; - end - end - function gettabwidth(idx); - begin - tb := ftabitems[idx]; - if tb then - return tb.width; - return nil; - end - function settabheight(h); - begin - if h>0 and h<>FTabHeight then - begin - ftabheight := h; - CalcTabs(); - end - end - function settabs(tbs); - begin - if not ifarray(tbs) then return 0; - if tbs=gettabs() then return 0; - mtabitems := new tnumindexarray(); - ftw := font.width; - for i,v in tbs do - begin - if not ifstring(v) then return 0; - it := new t_tab_item(v); - it.width := ftw*length(v)+10; - mtabitems.Push(it); - end - FTabItems := mtabitems; - FirstViewIndex := 0; - FCurrentid := -1; - FPrevid := -1; - lk := new tcountlocker(fclocker); - for i :=0 to n-1 do - begin - measureidx(i); - end - CalcTabs(); - InvalidateRect(nil,false); - end - function measureidx(i);//测量 - begin - if onmeasuretabwidth then - begin - e := new tuieventbase(0,0,i,0); - CallMessgeFunction(onmeasuretabwidth,e); //wparam 为序号 - if e.lparam>=0 then - begin - FTabItems[i].width := e.lparam; - end - end - end - private - fownerdraw; - [weakref]fondrawtab; - [weakref]fonmeasuretabwidth; -end - - - type tcustomtabsheet = class(TCustomControl) //控件页面 {** @explan(说明)page控件页面 %% @@ -646,16 +88,27 @@ type tcustompagecontrol = class(TCustomControl) function CalcTabs(); //计算区域 begin rec := ClientRect; //区域 + fclosebtnrect := array(); ft := font; fw := ft.width; - fh := ft.height; - FTabHeight := fh+7; + if not fownerdraw then + begin + fh := ft.height; + FTabHeight := fh+7; + end FTabItemswidth := array(); + e := new tuieventbase(0,0,0,0); for i := 0 to FTabItems.length()-1 do begin pg := FTabItems[i]; ta := pg.Caption; - FTabItemswidth[i] := max(20, length(ta)*fw+10 ); + FTabItemswidth[i] := max(20, length(ta)*fw+10 ); + if fonmeasuretabwidth then + begin + e.wparam := i; + CallMessgeFunction(fonmeasuretabwidth,self(true),e); + if e.lparam>=0 then FTabItemswidth[i] := e.lparam; + end end FMaxsize := 0; if FTabPosition in array(alLeft,alRight) then @@ -665,7 +118,7 @@ type tcustompagecontrol = class(TCustomControl) end else begin FMaxsize := sum(FTabItemswidth); - end + end FClientarea := rec; FScrollBtnRect := 0; Fprevrect := 0; @@ -675,7 +128,7 @@ type tcustompagecontrol = class(TCustomControl) alLeft: begin if FTabItemswidth then - begin + begin FClientarea[0] :=rec[0]+FTabItemswidth[0]; if length(FTabItemswidth)>1 and (FMaxsize>(rec[3]-rec[1])) then begin @@ -725,14 +178,20 @@ type tcustompagecontrol = class(TCustomControl) end end alTop: - begin + begin if FTabItemswidth then - begin + begin + FClientarea[1] :=rec[1]+FTabHeight; - if length(FTabItemswidth)>1 and (FMaxsize>(rec[2]-rec[0])) then + if fclosebtn then + begin + cbt := max(0,integer((FTabHeight-16)/2)); + fclosebtnrect := array(rec[2]-18,cbt,rec[2]+2,cbt+16); + rec[2]-=21; + end + if length(FTabItemswidth)>1 and (FMaxsize>(rec[2]-rec[0]-(fclosebtn?20:0))) then begin - FScrollBtnRect := array(rec[2]-FTabHeight*2,rec[1],rec[2],rec[1]+FTabHeight); - + FScrollBtnRect := array(rec[2]-FTabHeight*2,rec[1],rec[2],rec[1]+FTabHeight); Fnextrect := array(rec[2]-FTabHeight,rec[1],rec[2],rec[1]+FTabHeight); Fprevrect := array(rec[2]-FTabHeight*2,rec[1],rec[2]-FTabHeight,rec[1]+FTabHeight); end else FirstViewIndex := 0; @@ -829,22 +288,35 @@ type tcustompagecontrol = class(TCustomControl) end function PaintTabs();//绘制tab begin + lk := new tcountlocker(fclocker); dc := Canvas; dc.font := font; - for i := 0 to FTabItems.length()-1 do + ar := 0->(FTabItems.length()-1); + if FTabRects[FCurrentid] then + begin + ar[FCurrentid] := -100; + ar[length(ar)] := FCurrentid; + end + for ii,i in ar do begin rec := FTabRects[i]; - dc.pen.color := 13158600;//rgb(200,200,200); if rec then - begin + begin + if fownerdraw and fondrawtab then + begin + e := new teventdrawtab(i,(FCurrentid=i),rec,dc); + CallMessgeFunction(fondrawtab,self(true),e); + continue; + end + dc.pen.color := 13158600;//rgb(200,200,200); if FCurrentid=i then begin dc.brush.color := 0xf0f0f0;//rgb(100,192,250);//rgb(230,240,250);//rgb(200,200,200); end else dc.brush.color := 16711422;//rgb(254,254,254); dc.draw("roundrect",array(rec[0:1],rec[2:3],array(2,2))); - //dc.draw("rectangle",array(rec[0:1],rec[2:3],array(5,5))); rec[1]+=2; - dc.drawtext(FTabItems[i].Caption,rec,DT_CENTER .|DT_VCENTER); + it := FTabItems[i]; + dc.drawtext(it.caption,rec,DT_CENTER .|DT_VCENTER); end end end @@ -869,6 +341,16 @@ type tcustompagecontrol = class(TCustomControl) end end end + if fclosebtnrect then + begin + dc.brush.color := 0x0000ff; + dc.FillRect(fclosebtnrect); + dc.pen.color := 0xf0f0f0; + dc.moveto(fclosebtnrect[0:1]); + dc.LineTo(fclosebtnrect[2:3]); + dc.moveto(array(fclosebtnrect[2],fclosebtnrect[1])); + dc.LineTo(array(fclosebtnrect[0],fclosebtnrect[3])); + end end function ScrollPrev(); //滚动到下一个 begin @@ -965,7 +447,30 @@ type tcustompagecontrol = class(TCustomControl) inherited; DoControlAlign(); end - + function hittabat(xy); //命中 + begin + r := array(); + if (FScrollBtnRect and pointinrect(xy,FScrollBtnRect)) then + begin + r["idx"] := "scroll"; + return r; + end + if (fclosebtnrect and pointinrect(xy,fclosebtnrect)) then + begin + r["idx"] := "closebtn"; + return r; + end + for i,v in FTabRects do + begin + if v and pointinrect(xy,v) then + begin + r["idx"] := i; + r["pos"] := array(xy[0]-v[0],xy[1]-v[1]); + return r; + end + end + return r; + end function getsheetrect(); //获得sheet begin {** @@ -981,7 +486,11 @@ type tcustompagecontrol = class(TCustomControl) end function create(aowner); begin - inherited; + inherited; + fclosebtn := false; + FTabHeight := font.height+7; + faccepttype := array(); + acceptsheettype(class(tcustomtabsheet)); end function AfterConstruction();override; begin @@ -1000,19 +509,19 @@ type tcustompagecontrol = class(TCustomControl) end function ControlAppended(AControl);override; begin - if not(AControl is class(tcustomtabsheet)) then return; + if not isacceptsheettype(AControl) {not(AControl is class(tcustomtabsheet))} then return; addtabitem(AControl); end function ControlDeleted(AControl);override; begin - if not(AControl is class(tcustomtabsheet)) then return; + if not isacceptsheettype(AControl){ not(AControl is class(tcustomtabsheet))} then return; id := GetPageID(AControl); RemovePageTab(id); //fcoolbands.deleteitem(AControl,true); end Function SetCurSel(id); //设置当前序号 begin - if id is class(tcustomtabsheet) then + if isacceptsheettype(id) {id is class(tcustomtabsheet)} then begin return SetCurSel(GetPageID(id)); end @@ -1029,20 +538,29 @@ type tcustompagecontrol = class(TCustomControl) end function MouseUp(o,e);override;//鼠标弹起 begin + if e.skip then return ; ps := e.pos(); mb := e.button(); //if mb=mbRight then return ; - if (mb=mbLeft) and FScrollBtnRect and pointinrect(ps,fnextrect) then - begin - if e.Button() = mbLeft then - ScrollNext(); - return ; - end else - if (mb=mbLeft) and FScrollBtnRect and pointinrect(ps,Fprevrect) then - begin - if e.Button() = mbLeft then - scrollprev(); - return ; + if(mb=mbLeft) then + begin + if fclosebtn and fclosebtnrect and pointinrect(ps,fclosebtnrect) then + begin + if fonclosebtnclick then + begin + e := new tuieventbase(0,0,0,0); + CallMessgeFunction(fonclosebtnclick,self(true),e); + end + return ; + end + if FScrollBtnRect and pointinrect(ps,fnextrect) then + begin + return ScrollNext(); + end + if FScrollBtnRect and pointinrect(ps,Fprevrect) then + begin + return scrollprev(); + end end if not FTabRects then return ; for i := 0 to length( FTabRects)-1 do @@ -1090,7 +608,7 @@ type tcustompagecontrol = class(TCustomControl) @explan(说明)获取page的序号 %% **} r := -1; - if page is class(tcustomtabsheet) then + if {page is class(tcustomtabsheet)} isacceptsheettype(page) then begin for it := 0 to FTabItems.length()-1 do begin @@ -1174,6 +692,22 @@ type tcustompagecontrol = class(TCustomControl) FOnSelChanging := nil; FTabItems.splice(0,nil); inherited; + end + function acceptsheettype(ty,del); + begin + idx := 0; + if ty is class(tcontrol) then + begin + idx := inttostr(int64(ty)); + end + if idx = 0 then return 0; + if del then + begin + reindex(faccepttype,array(idx:nil)); + end else + begin + faccepttype[idx] := ty; + end end {** @param(cursel)(integer) 当前选中序号 %% @@ -1192,6 +726,45 @@ type tcustompagecontrol = class(TCustomControl) property TabCount read GetTabCount; property TabPosition:tabalign read FTabPosition write SetTabPosition; property tabsheet read gettabesheet ; + property onmeasuretabwidth:eventhandler read fonmeasuretabwidth write fonmeasuretabwidth; + property ondrawtab:eventhandler read fondrawtab write fondrawtab; + property ownerdraw:bool read fownerdraw write fownerdraw; + property tabheight:lazyinteger read FTabHeight write settabheight; + property closebtn:bool read fclosebtn write setclosebtn; + property onclosebtnclick:eventhandler read fonclosebtnclick write fonclosebtnclick; + private + fownerdraw; + faccepttype; + fclosebtn; + fclosebtnrect; + [weakref] fondrawtab; + [weakref] fonmeasuretabwidth; + [weakref] fonclosebtnclick; + private + function isacceptsheettype(c); + begin + for i,v in faccepttype do + begin + if c is v then return true; + end + end + function setclosebtn(v); + begin + nv := v?true:false; + if nv<>fclosebtn then + begin + fclosebtn := nv; + DoControlAlign(); + end + end + function settabheight(h); + begin + if ownerdraw and ( h>=0) and FTabHeight<>h then + begin + FTabHeight := h; + DoControlAlign(); + end + end end implementation type tcustomtabitem = class() // @@ -1215,7 +788,7 @@ type tcustomtabitem = class() // if ifstring(s) and s<>FCaption then begin FCaption := s; - if PageSheet is class(tcustomtabsheet) then PageSheet.Caption := s; + if PageSheet then PageSheet.Caption := s; end end public @@ -1227,11 +800,12 @@ type tcustomtabitem = class() // published property Caption read FCaption write SetCaption; property PageSheet read FPageSheet Write FPageSheet; + _tag; end type teventdrawtab = class(tuieventbase) {** @explan(说明)单元格绘制消息对象 %% - @param(idx)(integer) 行号 %% + @param(idx)(integer) 序号 %% @param(sel)(integer) 是否选中 %% @param(rec)(array(左上右下)) 区域 %% @param(canvas)(TCanvas) 画布 %% @@ -1249,17 +823,6 @@ type teventdrawtab = class(tuieventbase) rec; canvas; end -type t_tab_item = class() - function create(s); - begin - if ifstring(s) then - caption := s; - else caption := ""; - end - _Tag; - caption; - width; -end initialization end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclstdctl.tsf b/funcext/tvclib/utslvclstdctl.tsf index d8767e8..da3fb0c 100644 --- a/funcext/tvclib/utslvclstdctl.tsf +++ b/funcext/tvclib/utslvclstdctl.tsf @@ -3180,6 +3180,21 @@ type TCustomListBoxbase=class(TCustomScrollControl) end return array(); end + function hititemat(xy); + begin + r := array(); + if not(ifarray(xy) and ifnumber(xy[0]) and ifnumber(xy[1])) then return r; + y := xy[1]; + idx := GetIdxByYpos(y); + if idx>=0 then + begin + rc := GetIdxRect(idx); + r["idx"] := idx; + r["x"] := x-rc[0]; + r["y"] := y-rc[1]; + end + return r; + end function InsureIdxInClient(idx); //确保指定项在区域中 begin {** @@ -3367,6 +3382,7 @@ type TcustomListBox=class(TCustomListBoxbase) function MouseDown(o,e);override; begin if csDesigning in ComponentState then return; + if e.skip then return ; if(e.Button()=mbLeft)and not(e.shiftdouble())then begin FFormerSelBegin := FSelBegin; @@ -3446,7 +3462,20 @@ type TcustomListBox=class(TCustomListBoxbase) nh := min(h,16); nnh := integer((h-nh)/2); rc2 := array(rc[0]+2,rc[1]+nnh,rc[0]+nh+2,rc[3]-nnh); - cvs.Draw("framecontrol",array(rc2[0:1],rc2[2:3]),DFC_BUTTON,(r)?DFCS_CHECKED:DFCS_BUTTONCHECK); + if fcheckbox=2 then + begin + cvs.Draw("framecontrol",array(rc2[0:1],rc2[2:3]),DFC_BUTTON,DFCS_BUTTONRADIO); + if r then + begin + r2 := array(rc2[0:1]+3,rc2[2:3]-3); + cvs.brush.color := 0; + cvs.draw("ellipse",r2); + end + //cvs.Draw("framecontrol",array(rc2[0:1],rc2[2:3]),DFC_BUTTON,(r)?DFCS_CHECKED:DFCS_BUTTONCHECK); + end else + begin + cvs.Draw("framecontrol",array(rc2[0:1],rc2[2:3]),DFC_BUTTON,(r)?DFCS_CHECKED:DFCS_BUTTONCHECK); + end rc1[0]+=nh+5; end PaintIdexText(idx,rc1,cvs); @@ -3880,10 +3909,9 @@ type TcustomListBox=class(TCustomListBoxbase) end function setcheckbox(c); begin - nc := c?true:false; - if nc<>fcheckbox then + if c<>fcheckbox and (c in array(0,1,2)) then begin - fcheckbox := nc; + fcheckbox := c; InvalidateRect(nil,false); end end