liujianjun
/
tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity

编辑器 

修复
This commit is contained in:
JianjunLiu 2023-05-22 15:36:07 +08:00
parent d71f0753f1
commit 7f8ea00181
15 changed files with 970 additions and 702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
designer/ctl_mgr/resource.tfm/textcompclassadder.tfm Normal file
View File

@ -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

64
designer/ctl_mgr/resource.tfm/textcompclassmgr.tfm Normal file
View File

@ -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

151
designer/ctl_mgr/textcompclassadder.tsf Normal file
View File

@ -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

97
designer/ctl_mgr/textcompclassmgr.tsf Normal file
View File

@ -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

10
designer/gettslvcldesignerstart.tsf
View File

@ -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

220
designer/tslvcldesigner.tsf
View File

@ -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

89
designer/udesignerproject.tsf
View File

@ -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}

52
designer/utslvcldcomponents.tsf
View File

@ -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),

19
designer/utslvcldesignerresource.tsf
View File

@ -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.

6
funcext/tvclib/tslvcl.tsf
View File

@ -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)
{**

52
funcext/tvclib/utslmemo.tsf
View File

@ -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<tl then
begin
if bytetype(dtx,qmzfs)=2 then qmzfs -= 1;
end
ct := min(tl-qmzfs+1,rnzf);
for i := qmzfs to qmzfs+ct step 2 do
begin
if bytetype(dtx,i)<> 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

6
funcext/tvclib/utslvclgdi.tsf
View File

@ -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

21
funcext/tvclib/utslvclgrid.tsf
View File

@ -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
{**

769
funcext/tvclib/utslvclpage.tsf
View File

@ -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 id<FTabItems.length()) then return 0;
while FScrollBtnRect and (not FTabRects[id]) do
begin
if id>FirstViewIndex 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<FTabItems.length() then
begin
if FCurrentid<>-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<FTabItems.length() then
begin
rec := FTabRects[FTabItems.length()-1];
case FTabPosition of
alTop,alBottom:
begin
if rec and (rec[2]<Fprevrect[0]) then return ;
end
alLeft,alRight :
begin
if rec and (rec[3]<Fprevrect[1]) then return ;
end
end ;
FirstViewIndex++ ;
CalcTabs();
InvalidateRect(nil,false);
end
end
public
function HitTesttabat(xy);
begin
r := array();
{if pointinrect(xy,fnextrect) then
begin
r["idx"] :=-1;
return r;
end
if pointinrect(xy,Fprevrect) then
begin
r["idx"] := -2;
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 inserttab(tbs,idx);virtual;
begin
nitem := array();
ti := 0;
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;
nitem[ti++] := it;
end
if not nitem then return 0;
len := FTabItems.length();
if not(idx>=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<ftabitems.length() and w>=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.

36
funcext/tvclib/utslvclstdctl.tsf
View File

@ -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