tsheyongcong
/
tslediter
forked from liujianjun/tslediter
0
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

界面库 

拆分
This commit is contained in:
JianjunLiu 2022-08-08 16:14:34 +08:00
parent a5fa616a3e
commit 146101a46f
7 changed files with 2694 additions and 2528 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
designer/udesignerproject.tsf
View File

@ -1533,7 +1533,7 @@ BD141CA912494F502D48D224F45050274A21E03806FF2C7CA7516022D7D000000
WsDlgModalFrame := true; WsDlgModalFrame := true;
visible := false; visible := false;
Left := 50; Left := 50;
Top := 20; Top := 120;
Width := 1000; Width := 1000;
height := 900; height := 900;
wspopup := true; wspopup := true;

2
designer/utslvcldebuger.tsf
View File

@ -1469,7 +1469,7 @@ type TTslDebuga=class(TCustomControl)
begin begin
if FDebughandle then if FDebughandle then
begin begin
SysTerminate(-1,FDebughandle); SysTerminate(1,FDebughandle);
FDebughandle := 0; Fdebugedwhandle := 0; FDebughandle := 0; Fdebugedwhandle := 0;
end end
end end

2616
funcext/tvclib/tslvcl.tsf
View File

File diff suppressed because it is too large Load Diff

548
funcext/tvclib/utslvcldlg.tsf Normal file
View File

@ -0,0 +1,548 @@
unit utslvcldlg;
interface
uses cstructurelib,utslvclauxiliary,utslvclmemstruct,utslvclbase;
type TCommDlg=class(tcomponent)
{**
@explan(说明) 选择对话框类 %%
**}
private
FChooseOk;
FWndOwner;
FCaption;
function SetParent(p);
begin
FWndOwner := p;
end
protected
function SetCaption(v);virtual;
begin
FCaption := v;
end
public
function create(AOwner);override;
begin
inherited;
end
function Notification(AComponent,Operation);override;
begin
if Operation=opRemove then
begin
if AComponent=FWndOwner then FWndOwner := nil;
end
inherited;
end
function OpenDlg();
begin
{**
@explan(说明) 打开对话框 %%
**}
return FChooseOk := ChooseDlg();
end
function ChooseDlg();virtual;
begin
{**
@explan(说明) 打开对话框虚函数
**}
end
property ChooseOk read FChooseOk;
property WndOwner:variable read FWndOwner write FWndOwner;
property Parent read FWndOwner write SetParent;
property Caption:string read FCaption write SetCaption;
{**
@param(ChooseOk)(bool) 是否执行成功 %%
@param(WndOwner)(TWinControl) 所属窗口 %%
**}
end
type TcustommsgADlg=class(TCommDlg)
{**
@explan(说明) 消息提示框 %%
**}
private
FmbText;
Fbtnvals;
Ficonvals;
Fbtnval;
Ficonval;
function setMbtext(v)
begin
if FmbText <> v then
begin
FmbText := v;
end
end
function setcaption(v);override;
begin
if caption=v then exit;
inherited;
end
function setmbbtnstyle(v)
begin
if Fbtnval <> v and(v in Fbtnvals)then
begin
Fbtnval := v;
end
end
function setmbiconstyle(v)
begin
if Ficonval <> v and(v in Ficonvals)then
begin
Ficonval := v;
end
end
public
function create(AOwner);override;
begin
inherited;
FmbText := "";
caption := "提示";
Fbtnval := 0;
Ficonval := 48;
Fbtnvals := array(0,1,2,3,4,5,6,16384);
Ficonvals := array(48,64,32,16);
end
function ChooseDlg();override;
begin
hd := 0;
if Parent is class(TWinControl)then hd := Parent.Handle;
r := _wapi.MessageBoxA(hd,mbText,self.caption,Fbtnval .| Ficonval);
return r;
end
{
判断messagebox按钮是否被按下：根据 ChooseDlg()函数的返回值进行判断
代码 值 描述
IDABORT 3 "中止"按钮被选中
IDCANCEL 2 "取消"按钮已被选中
IDCONTINUE 11 "继续"按钮被选中
IDIGNORE 5 "忽略"按钮已被选中
IDNO 7 在"NO"按钮被选中
IDOK 1 "OK"按钮被选中
IDRETRY 4 "重试"按钮被按下
IDTRYAGAIN 10 "再试一次"按钮被按下
IDYES 6 "yes"按钮被选中
}
property mbText:string read FmbText write setMbtext;
property mbbtnstyle:MBbtnstyle read Fbtnval write setmbbtnstyle;
property mbiconstyle:MBiconstyle read Ficonval write setmbiconstyle;
{**
@param(mbText)(string)字符串%%
@param(mbbtnstyle)(TMBbtnstyle)按钮样式%%
@param(mbiconstyle)(TMBiconstyle)图标样式%%
**}
end
type tcustomcolordlg=class(TCommDlg)
{**
@explan(说明)颜色选择器 %%
**}
private
Fdlgcolor;
function SetCustomColors(cols);
begin
if ifarray(cols)then
begin
Fdlgcolor.lpcustcolors._setvalue_(0,cols);
end
end
function GetCustomColors();
begin
return Fdlgcolor.lpcustcolors._getdata_();
end
function SetResult(c);
begin
Fdlgcolor.rgbresult := c;
end
function GetResult()
begin
r := Fdlgcolor.rgbresult;
return r;
end
public
function create(AOwner);override;
begin
inherited;
Fdlgcolor := new ttagCHOOSECOLORA();
end
function ChooseDlg();override;
begin
Fdlgcolor.flags := CC_RGBINIT .| CC_SOLIDCOLOR; //.| CC_SHOWHELP .| CC_SOLIDCOLOR;
if WndOwner is class(TWinControl)then Fdlgcolor.hwndowner := WndOwner.Handle;
r := _wapi.ChooseColorA(Fdlgcolor._getptr_);
return r;
end
{**
@param(CustomColors)(array of integer) 自定义颜色 %%
@param(RgbResult)(integer) 颜色rgba值 %%
**}
property CustomColors read GetCustomColors write SetCustomColors;
property Result:color read GetResult write SetResult;
end
type tcustomfontdlg=class(TCommDlg)
{**
@explan(说明) 字体选择对话框 %%
**}
private
FFontChoose;
function SetFontInfo(v);
begin
FFontChoose.SetFontInfo(v);
if ifnumber(v["color"])then FFontChoose.rgbcolors := v["color"];
end
function GetFontInfo();
begin
r := GetFont();
if r is class(ttagLOGFONTA)then r := r._getdata_();
if ifarray(r)then
begin
r["color"]:= FFontChoose.rgbcolors;
fh := r["height"];
if fh<0 then r["height"]:= abs(fh);
fw := r["width"];
if fw=0 then r["width"]:= integer(abs(fh/2));
else if fw<0 then r["width"]:= abs(fw);
end
return r;
end
function GetFont();
begin
return FFontChoose.lplogfont;
end
function SetColor(v);
begin
FFontChoose.rgbcolors := V;
end
public
function create(AOwner);override;
begin
inherited;
FFontChoose := new ttagCHOOSEFONTA();
FFontChoose.flags := CF_EFFECTS .| CF_INITTOLOGFONTSTRUCT; //.|CF_BOTH ;
end
function ChooseDlg();override;
begin
if WndOwner is class(TWinControl)then FFontChoose.hwndowner := WndOwner.Handle;
return _wapi.ChooseFontA(FFontChoose._getptr_);
end
property FontInfo:font read GetFontInfo write SetFontInfo;
property color Write SetColor;
{**
@param(LogFont)(ttagLOGFONTA) 逻辑字体对象%%
@param(FontInfo)(array) 字体信息数组 %%
**}
end
type tcustomfolderdlg=class(TCommDlg)
{**
@explan(说明) 文件夹路径选择对话框 %%
**}
private
FBrowse;
FFolder;
FRootFold;
FRootStr;
FEditBox;
FDefaultDirstr;
FDefaultDir;
function SetDefaultDir(d);
begin
if ifstring(d)and d <> FDefaultDirstr then
begin
FDefaultDirstr := d;
FDefaultDir.setv(d);
end
end
function freeil();
begin
if FRootFold then _wapi.ILFree(FRootFold);
FRootFold := nil;
FRootStr := nil;
end
function SetEditBox(v);
begin
nv := v?true:false;
if FEditBox <> nv then
begin
FEditBox := nv;
end
end
function SetRootFold(p);
begin
if ifnil(p)then freeil();
if not(p and ifstring(p))then exit;
if FRootStr=p then exit;
freeil();
FRootFold := _wapi.ILCreateFromPathA(p);
if FRootFold then FRootStr := p;
end
public
function create(AOwner);override;
begin
inherited;
FEditBox := true;
FDefaultDir := new tcstring(1024);
FBrowse := new TBrowseinfoA();
end
function ChooseDlg();override;
begin
if WndOwner is class(TWinControl)then FBrowse.hwndowner := WndOwner.Handle;
if FRootFold then FBrowse.pidlroot := FRootFold;
flg := 0x8;
if FEditBox then flg .|= 0x00000010;
//if FNewFolder then flg .|= 0x00000040 .| 0x00000100 .| 0x00000080;
FBrowse.ulflags := flg;
if FDefaultDirstr then
begin
FBrowse.lparam := FDefaultDir.ptr;
FBrowse.lpfn := getwinprocptr(0x11);
end
ft := _wapi.SHBrowseForFolderA(FBrowse._getptr_);
if not ft then return 0;
s := s1 := "";
setlength(s1,1024);
f := _wapi.SHGetPathFromIDListA(ft,s1);
if not f then return 0;
for i := 1 to length(s1) do
begin
ts := s1[i];
if ts="\0" then break;
s += ts;
end
FFolder := s;
return true;
end
property DefaultDir read FDefaultDirstr write SetDefaultDir;
property RootFolder:directory read FRootStr write SetRootFold;
property Folder read FFolder;
property EditBox:bool read FEditBox write SetEditBox;
{**
@param(Folder)(string) 文件夹路径 %%
**}
end
type tcustomfsdlg = class(TCommDlg)
{**
@explan(说明) 保存文件,获得文件名 %%
@param(FFileTag)(TtagOFNA)openfile 对象 %%
**}
protected FFileTag;
function dlgType();virtual;
begin
//对话框类型：0x1：保存为窗口。0x2：打开窗口。
return 1;
end
function setCaption(s);override;
begin
if ifstring(s)then
begin
inherited;
FFileTag.lpstrtitle := s;
end
end
private
FFilter;
Ffilterindex;
fIsShowHidden;
fIsMultiselected;
fIsOverwritePrompt;
fIsLinkFilePath;
fIsCreatePrompt;
fIsFileMustExist;
finitialdir;
function setFlagsBit(b,m,n);
begin
//b：要设置的位的值，m：要设置的位的值的保存成员，n：要设置的位。
if xor(b,m)then
begin
if b then FFileTag.Flags .|= n;
else FFileTag.Flags :=.!((.!FFileTag.Flags).| n);
m := b;
end
end
function setShowHidden(b);
begin
setFlagsBit(b,fIsShowHidden,0x10000000);
end
function setMultiSelected(b);
begin
tb := fIsMultiselected;
setFlagsBit(b,fIsMultiselected,0x200);
if b and tb <> fIsMultiselected then
begin
s := "";
setlength(s,1024 * 16);
FFileTag.lpstrfile := s;
end
end
function setOverwritePrompt(b);
begin
setFlagsBit(b,fIsOverwritePrompt,0x2);
end
function setLinkFilePath(b);
begin
setFlagsBit(b,fIsLinkFilePath,0x100000);
end
function setCreatePrompt(b);
begin
setFlagsBit(b,fIsCreatePrompt,0x2000);
end
function setFileMustExist(b);
begin
//FFileTag.SetValue();
setFlagsBit(b,fIsFileMustExist,0x1000);
end
function GetResult();
begin
return FFileTag.lpstrfile;
end
function setfilter(f);
begin
{**
@explan(说明)设置筛选条件%%
@param(f)(array)筛选条件采用字符串下标的字符串数组,下标作为显示,值作为筛选条件
array("所有文件":"*.*","tsl流文件":"*.stm")
%%
**}
if FFilter=f then exit;
s := "";
rf := array();
if ifarray(f)then
begin
for i,v in f do
begin
if v and ifstring(v)and ifstring(i)then
begin
s += i+"\0"+v+"\0";
rf[i]:= v;
end
end
end
if length(s)then
begin
s += "\0";
FFileTag.lpstrfilter := s;
FFilter := rf;
end
Ffilterindex := 1;
end
function OpenFileDlg();virtual;
begin
r := _wapi.GetSaveFileNameA(FFileTag._getptr_);
return r;
end
function setDefaultFileExtension(s);
begin
if ifstring(s)then FFileTag.lpstrdefext := s;
end
function getDefaultFileExtension();
begin
return FFileTag.lpstrdefext;
end
function setInitialDir(s);
begin
if ifstring(s)and s <> "" then
begin
finitialdir.setv(s);
FfileTag.lpstrinitialdir := finitialdir.ptr;
end else
FfileTag.lpstrinitialdir := 0;
end
function getInitialDir();
begin
if FFileTag.lpstrinitialdir=finitialdir.ptr then return finitialdir.getv();
else return "";
end
public
function create(AOwner);override;
begin
inherited;
FFileTag := new TtagOFNA();
FFileTag.Flags .|= 0x80000; // .| OFN_ENABLEHOOK;
//FFileTag.hinstance := happ;
//FFileTag.lpfnHook := getwinprocptr(0x10);
finitialdir := new tcstring(512);
//FFileTag.lcustdata := finitialdir._getptr_;// 0x178;
//echo tostn(FFileTag._getdata_);
end
function getSelectedItemName();
begin
{**
@explan(说明)获取所选择文件的文件名%%
@return(string)当选择不止一个文件时，该函数返回首文件名。%%
**}
return FFileTag.lpstrfiletitle;
end
function ChooseDlg();override;
begin
{**
@explan(说明)打开一个对话框以使用户选择将要打开或保存的文件的路径%%
@return(bool)是否选择了有效的文件路径%%
**}
if WndOwner is class(TWinControl)then FFileTag.hwndowner := WndOwner.Handle;
if Ffilterindex>0 and FFilter then FFileTag.nfilterindex := Ffilterindex;
FFileTag.lpstrfile := "\0\0";
FFileTag.lpstrfiletitle := "";
r := OpenFileDlg();
if FFilter then Ffilterindex := FFileTag.nfilterindex;
return r;
end
function getResults();
begin //r2
{**
@explan(说明)获取所选择文件的完整路径%%
@return(array)所选择文件路径的数组%%
**}
s := FFileTag._getvalue_("lpstrfile",FFileTag.nmaxfile);
r := array();
i := 0;
l := length(s);
while i <= l and s[++i]<> '\0' do;
if not i then return r;
t := s[1:i-1];
if not Multiselected or(i<l and s[i+1]='\0')then return array(t);
t += ioFileseparator(); // '\\';
b := i;
while++i <> l do if s[i]='\0' then
begin
r[j++]:= t+s[b+1:i-1];
if s[i+1]='\0' then break;
b := i;
end
return r;
end
property filter:filefilter read FFilter write setfilter;
property filterindex read Ffilterindex write Ffilterindex;
property FileName read GetResult;
// property struct read FFileTag write FFileTag;
property DefaultFileExtension:string read getDefaultFileExtension write setDefaultFileExtension;
property initialDir:filename read getInitialDir write setInitialDir;
property ShowHidden:bool read fIsShowHidden write setShowHidden;
property Multiselected:bool read fIsMultiselected write setMultiselected;
property OverwritePrompt:bool read fIsOverwritePrompt write setOverwritePrompt;
property LinkFilePath:bool read fIsLinkFilePath write setLinkFilePath;
property FileMustExist:bool read fIsFileMustExist write setFileMustExist;
property CreatePrompt:bool read fIsCreatePrompt write setCreatePrompt;
{**
@param(filter)(array) array("所有文件":"*.*","tsl流文件":"*.stm")%%
@param(FileName)(string) 文件名,不成功返回上一次的结果。 %%
@param(DefaultFileExtension)(string) 默认扩展名，当文件名输入框中未指定扩展名且未选择保存类型时将使用该扩展名，用于保存对话框。 %%
@param(initialDir)(string) 默认打开路径 %%
@param(caption)(string) 对话框名称。%%
@param(ShowHidden)(bool) 是否强制显示隐藏文件。 %%
@param(Multiselected)(bool) 可多选，用于打开对话框。 %%
@param(OverwritePrompt)(bool) 开启覆盖保存提醒，用于保存对话框。 %%
@param(LinkFilePath)(bool) 若所选为快捷方式文件则返回该文件本身路径；默认返回其指向文件的路径。 %%
@param(CreatePrompt)(bool) 若在文件名输入框中输入不存在的文件名则提示是否创建；默认则不提示而直接返回路径，用于打开对话框。 %%
@param(FileMustExist)(bool) 若在文件名输入框中输入不存在的文件名则提示文件名不存在；默认则不提示而直接返回路径，用于打开对话框。 %%
**}
end
implementation
function xor(a,b);
begin
{**
@explan(说明) 异或 运算 %%
@return(bool)
**}
return(a and not(b))or(b and not(a));
end
initialization
end.

13
funcext/tvclib/utslvclmenu.tsf
View File

@ -854,11 +854,6 @@ private
property Zorder read GetZorder write SetZorder; property Zorder read GetZorder write SetZorder;
property OnDesignClick read FOnDesignClick write FOnDesignClick; property OnDesignClick read FOnDesignClick write FOnDesignClick;
property ShortCut read getShortCut write SetShortCut; property ShortCut read getShortCut write SetShortCut;
function publishs();override;
begin
return array("action","bitmap","caption","checked","enabled","name","townerdraw","tseparator",
"onclick","onrbuttonup","onselect");
end
{** {**
@param(Parent)(TcustomMenu|nil)添加父节点,如果非tmenu,从父节点移除 %% @param(Parent)(TcustomMenu|nil)添加父节点,如果非tmenu,从父节点移除 %%
@param(OnDrawItem)(function[TcustomMenu,TMDRAWITEM]) 自绘制菜单回调函数 %% @param(OnDrawItem)(function[TcustomMenu,TMDRAWITEM]) 自绘制菜单回调函数 %%
@ -898,10 +893,6 @@ type TcustomPopupmenu=class(TcustomMenu)
begin begin
inherited; inherited;
end end
function publishs();override;
begin
return array("name","caption","enabled","onrbuttonup");
end
end end
type TcustomMainmenu=class(TcustomMenu) type TcustomMainmenu=class(TcustomMenu)
{** {**
@ -961,10 +952,6 @@ type TcustomMainmenu=class(TcustomMenu)
return r; return r;
end end
property Hwnd:pointer read FWndHandle write setwndhandle; property Hwnd:pointer read FWndHandle write setwndhandle;
function publishs();override;
begin
return array("name");
end
{** {**
@param(Hwnd)()窗口句柄 %%; @param(Hwnd)()窗口句柄 %%;
**} **}

698
funcext/tvclib/utslvclpage.tsf Normal file
View File

@ -0,0 +1,698 @@
unit utslvclpage;
interface
uses utslvclauxiliary,utslvclbase,utslvclgdi;
type tcustomtabitem = class() //TTCITEMA
{**
@explan(说明)tab控件标签对象 %%
**}
private
FPageCtrl;
FCaption;
FVisible;
FPageSheet;
function SetVisible(v);
begin
nv := v?true:false;
if nv<>FVisible then
begin
FVisible := v;
end
end
function SetCaption(s);
begin
if ifstring(s) and s<>FCaption then
begin
FCaption := s;
psztext := FCaption;
if PageSheet is class(tcustomtabsheet) then PageSheet.Caption := s;
end
end
public
function Create();
begin
FVisible:= true;
end
property Caption read FCaption write SetCaption;
property PageSheet read FPageSheet Write FPageSheet;
end
type tcustomtabsheet = class(TCustomControl)
{**
@explan(说明)page控件页面 %%
**}
private
FImageIndex;
protected
function RealSetText(s);override;
begin
inherited;
if ifstring(s) and Parent then
begin
id := parent.GetPageID(self(true));
Parent.SetTabText(id,s);
end
end
function SetParent(p);override;
begin
if (P is class(tcustompagecontrol) ) and parent<>p then
begin
oldparent := Parent;
if oldparent then
begin
oldparent.RemovePage(self);
end
inherited;
parent.addtabitem(self);
end else
if not(p is class(TWincontrol)) then
begin
if Parent then
begin
id := Parent.GetPageID(self);
Parent.RemovePageTab(id);
end
inherited;
end
end
public
function paint();override;
begin
drawdesigninggrid();
end
function DesigningMove();override;
begin
return false;
end
function DesigningSizer();override;
begin
return false;
end
function create(AOwner);override;
begin
inherited;
Caption := "tab";
Visible := false;
FTabVisible := True;
end
function CreateParams(p);override;
begin
inherited;
p.exstyle := 0x101;
end
end
type tcustompagecontrol = class(TCustomControl)
private
FirstViewIndex;
FCurrentid;
FPrevid;
FTabItems; //
FOnSelChange;
FOnSelChanging;
//FOnrclick;
FTabPosition;
FTabHeight;
FTabItemswidth;
FScrollBtnRect;
Fprevrect;
fnextrect;
FTabRects;
FClientarea;
function SetTabPosition(v);
begin
if FTabPosition=v then exit;
if not(v in array(alTop,alBottom,alLeft,alRight)) then exit;
FTabPosition := v;
InvalidateRect(nil,false);
DoControlAlign();
end
function GetTabCount();
begin
return FTabItems.length();
end
function CreateTableItem(cp);
begin
r := new tcustomtabitem();
r.caption := cp;
return r;
end
function CalcTabs(); //计算区域
begin
rec := ClientRect; //区域
ft := font;
fw := ft.width;
fh := ft.height;
FTabHeight := fh+7;
FTabItemswidth := array();
for i := 0 to FTabItems.length()-1 do
begin
pg := FTabItems[i];
ta := pg.Caption;
FTabItemswidth[i] := max(20, length(ta)*fw+8 );
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 xbase>(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 xbase>(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 FScrollBtnRect and (not FTabRects[id]) then
begin
if id>FirstViewIndex then
begin
while(not FTabRects[min(id+1,(FTabItems.length()-1))]) do
begin
FirstViewIndex++;
CalcTabs();
end
end else
if id<FirstViewIndex then
begin
while(not FTabRects[id]) do
begin
FirstViewIndex--;
CalcTabs();
end
end
end
end
function setselidx(id); //选择序号
begin
if FCurrentid= id then return ;
if id>=0 and id<FTabItems.length() then
begin
FPrevid := FCurrentid;
FCurrentid := id;
InsureIdxVisible(id);
InvalidateRect(nil,false);
DoControlAlign();
doonSelChanging(self(true),new tuieventbase(0,0,0,0));
doonSelChange(self(true),new tuieventbase(0,0,0,0));
end else
if FTabItems.length()=0 then
begin
FPrevid := FCurrentid;
FCurrentid := -1;
end
end
function PaintTabs();
begin
dc := Canvas;
for i := 0 to FTabItems.length()-1 do
begin
rec := FTabRects[i];
dc.pen.color := rgb(200,200,200);
if rec then
begin
if FCurrentid=i then
begin
dc.brush.color := rgb(200,200,200);
end else dc.brush.color := 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);
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()-1 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
function getsheetrect(); //获得sheet
begin
if not FClientarea then CalcTabs();
return FClientarea;
end
public
function DesigningClick();override;
begin
return true;
end
function create(aowner);
begin
inherited;
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 id is class(tcustomtabsheet) then
begin
return SetCurSel(GetPageID(id));
end
if ifnumber(id) then
begin
iid := integer(id);
setselidx(iid);
end
end
function paint();override; //绘制
begin
PaintTabs();
PaintScroll();
end
function MouseUp(o,e);override;
begin
ps := e.pos();
if FScrollBtnRect and pointinrect(ps,fnextrect) then
begin
if e.Button() = mbLeft then
ScrollNext();
return ;
end else
if 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 e.Button() = mbLeft then
begin
CallMessgeFunction(Onclick,o,e);
end else
if e.Button() = mbRight then
begin
CallMessgeFunction(onrclick,o,e);
end
end
e.skip := true;
end
end
function doonSelChange(o,e);virtual;
begin
CallMessgeFunction(OnSelChange,o,e);
end
function doonSelChanging(o,e);virtual;
begin
CallMessgeFunction(OnSelChanging,o,e);
end
function TabRect(AIndex: Integer);
begin
r := FTabRects[AIndex];
if r then return r;
return array(0,0,0,0);
end
function GetTabText(AIndex);
begin
r := "";
if AIndex<FTabItems.Count and AIndex>0 then return FTabItems[AIndex].Caption;
return r;
end
function IsContainer(cd);override;
begin
if cd is class(tcustomtabsheet) then return true;
return false;
end
function GetPageID(page);
begin
{**
@explan(说明)获取page的序号 %%
**}
r := -1;
if page is class(tcustomtabsheet) then
begin
for it := 0 to FTabItems.length()-1 do
begin
if FTabItems[it].PageSheet = page then
begin
return it;
end
end
end
return r;
end
function DoControlAlign();override;
begin
CalcTabs();
for i := 0 to FTabItems.length()-1 do
begin
it := FTabItems[i];
if it and it.PageSheet then
begin
pg := it.PageSheet;
if i=FCurrentid then
begin
pg.Visible := true;
rc := getsheetrect();
if not rc then return ;
rc[1]+=1;
if csDesigning in ComponentState then
begin
rc[0]+=2;
rc[2]-=2;
rc[3]-=2;
end
pg.SetBoundsrect(rc);
end else
pg.Visible := false;
end
end
end
function RemovePageTab(id);
begin
if not(id>=0) then return ;
FTabItems.splice(id,1);
if id = FCurrentid then
begin
if id = 0 then
begin
if FTabItems.length()=0 then
begin
FCurrentid := -1;
end
end
return setselidx(id-1);
end else
if id<FCurrentid then
begin
FCurrentid--;
end
CalcTabs();
InvalidateRect(nil,false);
end
function RemovePage(i);
begin
{**
@explan(说明)移除page %%
@param(i)(integer) page序号 %%;
**}
ii := -1;
if ifnumber(i) then ii := i;
else
ii := GetPageID(i);
if ii<0 or ii>=FTabItems.length() then return ;
item := FTabItems[ii];
if ifobj(item) then
begin
pg := item.PageSheet;
if pg then pg.parent := nil;
end
//setselidx(0); //移除
end
function addcontrol(page);
begin
{**
@explan(说明) 添加控件 %%
@param(page)(tcustomtabsheet) sheet;
**}
if not(page is class(tcustomtabsheet)) then return -1;
add := true;
for i := 0 to Controls.count-1 do
begin
if Controls[i]=page then add := false;
end
if add then
begin
page.Visible := false;
page.parent := self;
end
end
function addtabitem(page);//添加sheet
begin
if not(page is class(tcustomtabsheet)) then return -1;
add := true;
for i := 0 to FTabItems.length()-1 do
begin
if FTabItems[i].PageSheet = page then add := false;
end
add1 := false;
for i := 0 to Controls.count-1 do
begin
if Controls[i]=page then add1 := true;
end
if add and add1 then
begin
it := CreateTableItem(page.caption);
FTabItems.Push(it);
if FTabItems.length()>1 then page.visible := false;
it.PageSheet := Page;
if {HandleAllocated() and} FCurrentid=-1 then
begin
setselidx(0);
end
end
end
function InitializeWnd();override;
begin
inherited;
end
function AppendPage(page);
begin
{**
@explan(说明)添加pagesheet %%
@param(page)(tcustomtabsheet)sheet %%;
**}
if not(page is class(tcustomtabsheet)) then return -1;
addcontrol(page);
end
function SetTabText(i,Value);
begin
{**
@explan(说明)修改tab标签文字 %%
@param(i)(integer)序号 %%;
@param(Value)(string)文本 %%;
**}
it := FTabItems[i];
if it then
begin
if Value = it.caption then
begin
CalcTabs();
InvalidateRect(nil,false);
end else
begin
it.Caption := Value;
end
end
end
function SetTabIndex(AIndex,AIndexnew);
begin
{**
@explan(说明) 修改标签的次序 %%
@param(AIndex)(integer) 位置 %%
@param(AIndexnew)(integer) 新位置 %%
**}
if (AIndex<>AIndexnew) and (AIndex>=0) and
(AIndex<FTabItems.length()) and (AIndexnew>=0) and (AIndexnew<FTabItems.length()) then
begin
FTabItems(AIndex,AIndexnew);
CalcTabs();
InvalidateRect(nil,false);
end
end
function Recycling();override;
begin
FTabItems.splice(0,FTabItems.length());
inherited;
end
{**
@param(cursel)(integer) 当前选中序号 %%
@param(TabCount)(integer) page数量 %%
@param(OnSelChange)(function[tcustompagecontrol,tuieventbase]) 标签已经切换 %%
@param(OnSelChanging)(function[tcustompagecontrol,tuieventbase]) 标签正在切换 %%
@param(Onrclcik)(function[tcustompagecontrol,tuieventbase]) 右键点击 %%
**}
property cursel:lazyinteger read FCurrentid write SetCurSel;
property OnSelChange:eventhandler read FOnSelChange write FOnSelChange;
property OnSelChanging:eventhandler read FOnSelChanging write FOnSelChanging;
//property onrclick:eventhandler read Fonrclick write Fonrclick;
property TabCount read GetTabCount;
property TabPosition:tabalign read FTabPosition write SetTabPosition;
end
implementation
initialization
end.

1301
funcext/tvclib/utslvclstdctl.tsf
View File

File diff suppressed because it is too large Load Diff