liujianjun
/
tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity
tslediter/funcext/tvclib/utslvclstdctl.tsf

7804 lines
215 KiB
Plaintext
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

unit utslvclstdctl;
interface
{**
@explan(说明) 标准控件库 %%
@date(20220509)
**}
uses utslvclauxiliary,utslvclbase,utslvclgdi,utslvclaction,utslvclmenu;
type TcustomClipBoard=class(tcomponent) //剪切板基类
{**
@explan(说明) 剪切板类 %%
**}
private
FIsopen;
function CloseClipboard(); //关闭
begin
if FIsopen then FIsopen := not _wapi.CloseClipboard();
return not(FIsopen);
end
function OpenClipboard(); //打开
begin
{**
@explan(说明) 打开剪切板 %%
**}
IF not(FIsopen)then FIsopen := _wapi.OpenClipboard(0);
return FIsopen;
end
function EmptyClipboard();//清空
begin
{**
@explan(说明) 清空剪切板 %%
**}
if FIsopen then _wapi.EmptyClipboard();
end
function SetText(s); //设置字符串
begin
{**
@explan(说明) 设置字符串到剪切板 %%
@param(s)(string|nil) 字符串如果为nil则清空 %%
**}
ret :=-1;
if not(ifstring(s)and length(s)>0)then
begin
return -1;
end
OpenClipboard();
try
EmptyClipboard();
_wapi.setclipboardtext(0,s);
finally
CloseClipboard();
end;
return ret;
end
function GetText(); //获得字符串
begin
{**
@explan(说明) 获得剪切板字符串 %%
@return(string) 字符串 %%
**}
OpenClipboard();
try
if _wapi.IsClipboardFormatAvailable(CF_TEXT)then
begin
r := _Wapi.getclipboardtext(0);
end
finally
CloseClipboard();
end;
return r;
end
function SetBitmap(v); //设置图片
begin
if v is class(tcustombitmap)then
begin
if V.HandleAllocated()then
begin
OpenClipboard();
try
EmptyClipboard();
_wapi.setclipboardbmp(v.Handle);
finally
CloseClipboard();
end;
return ret;
end
end
end
function Getbitmap(); //获得图片
begin
OpenClipboard();
try
if _wapi.IsClipboardFormatAvailable(CF_BITMAP)then
begin
sid := _wapi.getclipboardbmp();
if sid then
begin
bmp := new tcustombitmap();
bmp.Handle := sid;
return bmp;
end
return false;
end
finally
CloseClipboard();
end;
return r;
end
public
function create(AOwner);override;
begin
{**
@explan(说明) 构造剪切板类对象 %%
**}
inherited;
end
function Recycling();override;
begin
CloseClipboard();
inherited;
end
function destroy();override;
begin
inherited;
end
published
property Text read GetText write SetText;
property Bmp read GetBitmap write SetBitmap;
{**
@explan(Text)(string) 设置或者获取剪切板文本 %%
**}
end
type TCustomTimer = class(tcomponent)//定时器类
{**
@explan(说明)定时器类,间隔是以毫秒为最小单位 %%
**}
{**
@example(范例--定时器)
//构造计算器,第一个参数为间隔(毫秒),第二个为函数指针
tm := new TCustomTimer(1000,function(o,e)begin echo now(); end );
tm.start();//启动定时器
tm.stop();//停止
**}
private
[weakref] static _STIMERS; //TIMER对象
static FSIDC; //id 构造器
class function Sgettimer(id);
begin
{**
@explan(说明) 通过id获得定时器对象 %%
@param(id)(integer) 定时器id %%
**}
return _STIMERS[id];
end
class function Ssettimer(tm);
begin
{**
@explan(说明)存储定时器 %%
@param(tm)(TCustomTimer) 定时器对象%%
**}
_STIMERS[tm.id]:= tm;
end
class function Sdeltimer(tid);
begin
{**
@explan(说明) 删除定时器 %%
@param(tid)(integer) id%%
**}
if tid and(ifnumber(tid))then reindex(_STIMERS,array(tid:nil));
end
protected
[weakref]FOntimeout;
private
[weakref]FOntimer;
Fid;
FInterval;
FStart;
_kill0; //标记
function SetEnabled(f);
begin
if f then start();
else stop();
end
function SetInterval(intv); //设置间隔
begin
{**
@explan(说明)设置间隔 %%
@param(intv)(integer) 间隔,毫秒 %%
**}
if not(ifnumber(intv))then return FInterval;
if FStart then
begin
ndstart := 1;
stop();
end
if intv <> FInterval and ifnumber(intv)and intv>0 then //时间不等
begin
FInterval := intv;
end
if ndstart then start();
end
public
{**
@param(FSIDC)(tidcreater) id构造器%%
@param(_STIMERS)(array) 全局存储%%
@param(FOntimer)(fpointer) timeout执行对象%%
@param(_kill0)(bool) 标记%%
**}
function create(AOwner);override;
begin
inherited;
FID := FSIDC.createid();
FStart := false;
FInterval := 1000;
end
function timeout(cmd,t); //一次性事件
begin
{**
@explan(说明) 一次性事件 %%
@param(cmd)(fpointer) 执行回调 %%
@param(t)(integer) t毫秒后执行 %%
**}
FOntimeout := cmd;
if ifnumber(t)then SetInterval(t);
FOntimer := function(o,e)
begin
try
stop();
CallMessgeFunction(FOntimeout,o,e);
finally
FOntimeout := nil;
end;
end;
start();
end
function start(); //开始
begin
{**
@explan(说明)启动 %%
**}
if not(iffuncptr(FOntimer) and FInterval>0) then return -1;
if FStart then return FStart;
ret := _wapi.SetTimer(nil,Fid,FInterval,gettimerptr(2));
_kill0 := ret;
Ssettimer(self(true));
FStart := ret <> 0;
return FStart;
end
function stop(); //停止
begin
{**
@explan(说明)停止 %%
**}
if FStart then
begin
if _kill0 then
begin
FStart := not((_wapi.KillTimer(nil,_kill0))<> 0);
if FStart=false then _kill0 := 0;
end
Sdeltimer(FID);
end
return not FStart;
end
function Recycling();override;
begin
{**
@explan(说明)析构预备 %%
**}
stop();
FSIDC.deleteid(FID);
FOntimer := nil;
FOntimeout := nil;
FTimerStrc := nil;
inherited;
end
function destroy();override;
begin
inherited;
end
class function _timeproc_(hwnd,message,wparam,lparam); //消息分发
begin
{**
@explan(说明) 定时回调入接口 %%
@param(hwnd)(integer) 窗口句柄 %%
@param(message)(integer) 消息id %%
@param(lparam)(integer) 消息参数2 %%
@param(wparam)(integer) 消息参数1 %%
**}
e := new tuieventbase(message,wparam,lparam,hwnd);
for i,iv in mrows(_STIMERS,1) do
begin
v := _STIMERS[iv];
if v is class(TCustomTimer)then if v.tproc(e)then return;
end
//return _twinproc_(hwnd,message,wparam,lparam);
end
class function Sinit();override; //初始化
begin
{**
@explan(说明)初始化定时器全局 %%
**}
if not FSIDC then
begin
_STIMERS := array();
FSIDC := new tidcreater();
end
inherited;
end
function tproc(e);virtual; //分发定时器
begin
if e.wparam and(e.wparam=_kill0)then
begin
CallMessgeFunction(FOntimer,self(true),e);
return 1;
end
end
published
property Interval:integer read FInterval write SetInterval; //间隔
property Ontimer:eventhandler read FOntimer write FOntimer; //回调
property Enabled:bool read FStart Write SetEnabled; //启动
property id read FID;
{**
@param(Interval)(integer) 设置运行间隔 %%
@param(Ontimer)(funtion[self,tuieventbase]) 定时调度 %%
@param(Enabled)(bool) 是否已经启动 %%
**}
end
type tcustombtn = class(TCustomControl) //按钮
{**
@explan(说明) 普通按钮 %%
**}
function Create(aowner);
begin
FtextPosition := 0;
inherited;
Parentcolor := false;
//Border := true;
//bordercolor := rgb(200,200,200);
fbtntimer := new TCustomTimer(self);
fbtntimer.Ontimer := thisfunction(judgestate);
end
function AfterConstruction();override;
begin
inherited;
Caption:="button";
Left:=0;
Top:=0;
Width:=94;
Height:=31;
Color := _wapi.GetSysColor(COLOR_MENUBAR);
end
function click();virtual; //点击
begin
{**
@explan(说明)模拟点击按钮一下的操作%%
**}
if handleAllocated() then _send_(BM_CLICK,0,0);
end
function BMCLICK(o,e):BM_CLICK;virtual; //点击消息处理
begin
if csDesigning in ComponentState then return ;
if FdoingClick then return ;
FdoingClick := true;
//try
if Action and Action.Execute() then
begin
end else
CallMessgeFunction(onClick,self(true),e);
// finally
FdoingClick := false;
// end;
end
function WMKEYDOWN(o,e);override; //按键enter处理
begin
inherited;
case e.CharCode of
13 :
begin
click();
end
end ;
end
function MouseDown(o,e);override; //按下
begin
if csDesigning in ComponentState then return ;
if not Fbtnstate then
begin
Fbtnstate := true;
InvalidateRect(nil,false);
{$ifdef linux}
{$else}
fbtntimer.start();
{$endif}
end
inherited;
end
function MouseUp(o,e);override;//处理点击事件
begin
if csDesigning in ComponentState then return ;
click();
if Fbtnstate then
begin
Fbtnstate := 0;
{$ifdef linux}
{$else}
fbtntimer.stop();
{$endif}
InvalidateRect(nil,false);
end
end
{function WMLBUTTONUP(o,e):WM_LBUTTONUP;override;
begin
if csDesigning in ComponentState then return ;
click();
if Fbtnstate then
begin
Fbtnstate := 0;
InvalidateRect(nil,false);
end
end
function WMRBUTTONUP(o,e):WMRBUTTONUP;override;
begin
if csDesigning in ComponentState then return ;
click();
if Fbtnstate then
begin
Fbtnstate := 0;
InvalidateRect(nil,false);
end
end }
function dosetfocus(o,e);override;//获得焦点
begin
{**
@explan(说明) 控件获得焦点 %%
@param(o)(TWinControl) 控件自身 %%
@Param(e)(tuieventbase) 消息对象 %%
**}
inherited;
FBtnfocused := true;
InvalidateRect(nil,false);
end
function dokillfocus(o,e);override;//失掉焦点
begin
{**
@explan(说明) 控件失去焦点 %%
@param(o)(TWinControl) 控件自身 %%
@Param(e)(tuieventbase) 消息对象 %%
**}
inherited;
FBtnfocused := false;
InvalidateRect(nil,false);
end
function paint();override;//绘制
begin
dc := Canvas;
cr := ClientRect;
if true then //绘制边框
begin
C := 0x090909;
bc := Color;
dc.pen.Color := max(0,bc-c);
dc.pen.Width := 1;
rec := cr;
rec[2]-=1;
rec[3]-=1;
dc.moveto(rec[array(0,1)]);
dc.LineTo(rec[array(2,1)]);
dc.LineTo(rec[array(2,3)]);
dc.LineTo(rec[array(0,3)]);
dc.LineTo(rec[array(0,1)]);
end
if Fbtnstate then
begin
PaintMouseDown();
end else
if FBtnfocused then
begin
paintfocus(dc,cr);
end
rec := GetBtntextRect();
if not ifarray(rec) then return ;
if not (rec[2]>rec[0] and rec[3]>rec[1]) then return ;
{
AL9_DEFAULT := 0;//0
AL9_TOPLEFT := 1;//1
AL9_TOPCENTER := 2 ;//2
AL9_TOPRIGHT := 3;//3
AL9_CENTERLEFT := 4 ;//4
AL9_CENTER := 5 ;//5
AL9_CENTERRIGHT := 6;//6
AL9_BOTTOMLEFT := 7 ;//7
AL9_BOTTOMCENTER := 8;//8
AL9_BOTTOMRIGHT := 9;//9
}
df := 0;
case FtextPosition of
1: df := DT_LEFT;
2: df := DT_CENTER;
3: df := DT_RIGHT
4: df := DT_LEFT .| DT_VCENTER;
6: df := DT_RIGHT .| DT_VCENTER;
7: d := DT_BOTTOM .| DT_LEFT;
8: df := DT_BOTTOM .|DT_CENTER;
9: df := DT_BOTTOM .| DT_RIGHT;
else
begin
df := DT_CENTER .| DT_VCENTER .| DT_SINGLELINE;
end
end ;
c := caption;
if ifstring(c) and c then
begin
dc.font := font;
flg := 0;
if not Enabled then
begin
bc := dc.font.color;
dc.font.color := 0xc0c0c0;
flg := 1;
end
dc.drawtext(c,rec,df);
if flg then
begin
dc.font.color := bc;
end
end
end
function GetPreferredSize(w,h);override;
begin
class(tcontrol).GetPreferredSize(w,h);
end
function FontChanged(o);override; //字体改变
begin
inherited;
InvalidateRect(nil,false);
end
function Recycling();override;
begin
inherited;
FonSetFocus := nil;
FonKillFocus := nil;
end
published
property textPos:AlignStyle9 read FtextPosition write setTextPosition; //文字对齐
property pushLike:bool read FpushLike write setPushLike;
property multiLine:bool read FmultiLine write setMultiLine;
{**
@param(textPos)(member of TAlignStyle9) 文本位置%%
@param(pushLike)(bool)是否为普通按钮外观%%
@param(multiLine)(bool)文本是否为多行显示%%
**}
protected
function SetEnabled(v);override;
begin
nv := v?true:false;
if nv<>Enabled then
begin
inherited;
if HandleAllocated() then
InvalidateRect(nil,false);
end
end
function RealSetText(s);override;
begin
bs := caption;
inherited;
if bs = caption then return ;
//if autosize then return set_Preferre_size();
if NoRecycled() then AdjustSize();
//InvalidateRect(nil,false);
end
function PaintMouseDown();virtual; //按下绘制
begin
r := ClientRect;
dc := Canvas;
bps := dc.pen.style;
{dc.pen.color := rgb(150,200,230);
dc.pen.width := 1;
dc.pen.style := PS_SOLID;
drawrc(dc,r,1);}
paintfocus(dc,r);
dc.pen.style := PS_DOT;
dc.pen.color := 16440490;//rgb(170,220,250);
//drawrc(dc,r,4);
dc.pen.style := bps;
end
private
function paintfocus(dc,r); //绘制焦点
begin
dc.pen.color := 15124630;//rgb(150,200,230);
dc.pen.width := 1;
dc.pen.style := PS_SOLID;
drawrc(dc,r,1);
end
function drawrc(dc,r,n);
begin
r[0] += n;
r[2] -= n;
r[1] += n;
r[3] -= n;
dc.moveto(r[array(0,1)]);
dc.LineTo(r[array(2,1)]);
dc.LineTo(r[array(2,3)]);
dc.LineTo(r[array(1,3)]);
dc.LineTo(r[array(0,1)]);
end
function setPushLike();
begin
end
function setMultiLine();
begin
end
function GetBtnTextRect();virtual;
begin
return ClientRect;
end
function setTextPosition(n);
begin
if not ifnumber(n) or n<0 or n>9 then
n:=0;
else
n:=integer(n);
if FtextPosition=n then return ;
FtextPosition:=n;
InvalidateRect(nil,false);
end
function judgestate(o,e);
begin
xy := array(0,0);
_wapi.getcursorPos(xy);
nxy := ScreenToClient(xy[0],xy[1]);
if nxy[0]<0 or nxy[0]>Width or nxy[1]<0 or nxy[1]>Height then
begin
Fbtnstate := 0;
InvalidateRect(nil,false);
o.stop();
end
end
private
fbtntimer;
FBtnfocused;
FdoingClick;
FpushLike;
FmultiLine;
FtextPosition;
Fbtnstate;
end
type tcustomcheckbtn=class(tcustombtn) //checkbtn
{**
@explan(说明) 复选框 %%
**}
//BM_SETCHECK
public
function create(aowner);override;
begin
inherited;
FcheckState:=0;
FleftText:=0;
end
function click();override;
begin
FcheckState := not FcheckState;
_send_(BM_SETCHECK,FcheckState,0 );
inherited;
end
function paint();override;
begin
inherited;
drawchekd(FCheckRect);
end
function BMSETCHECK(o,e):BM_SETCHECK;virtual;
begin
FcheckState := e.wparam;
InvalidateRect(nil,false);
end
function GetPreferredSize(w,h);override;
begin
inherited;
w+=20+1;
end
published
property checked:bool read FcheckState write setChecked;
property leftText:bool read FleftText write setLeftText;
{**
@param(checked)(integer)勾选状态：
0：未选中。
1：选中。
@param(leftText)(bool)文本是否在左%%
**}
protected
function PaintMouseDown();override;
begin
end
private
FleftText;
FcheckState;
FCheckRect;
private
function drawchekd(r);virtual; //绘制选择按钮
begin
if r then
begin
dc := Canvas;
dc.pen.style := PS_SOLID;
dc.brush.color := rgb(200,0,0);
dc.Draw("framecontrol",array(r[0:1],r[2:3]),DFC_BUTTON,(checked)?DFCS_CHECKED:DFCS_BUTTONCHECK);
end
end
function setChecked(v);virtual; //设置选择
begin
nv := v?true:false;
if nv<>FcheckState then
begin
FcheckState := nv;
if handleAllocated() then _send_(BM_SETCHECK,FcheckState,0);
end
end
function setLeftText(v);
begin
nv := v?true:false;
if FleftText<>nv then
begin
FleftText := nv;
InvalidateRect(nil,false);
end
end
function GetBtnTextRect();virtual; //选择框位置计算
begin
r := ClientRect;
h := r[3]-r[1];
dh := integer( (h-16)/2)+1;
if FleftText then
begin
FCheckRect := array(r[2]-18,r[1]+dh,r[2]-2,r[3]-dh);
r[2] -=20;
end else
begin
FCheckRect := array(r[0]+2,r[1]+dh,r[0]+18,r[3]-dh);
r[0] +=20;
end
return r;
end
end
type tcustomradiobtn = class(tcustomcheckbtn) //单选按钮
{**
@explan(说明)radiobtn单选按钮控件
**}
function create(AOwner);
begin
inherited;
end
function InitializeWnd();override;
begin
inherited;
ck := checked;
if ck then
_send_(BM_SETCHECK,ck,0);
end
function click();override;
begin
if checked then
begin
_send_(BM_CLICK,0,0);
end else
inherited;
end
function BMSETCHECK(o,e):BM_SETCHECK;override;
begin
t := e.wparam;
inherited;
if t then
begin
p := parent ;
ctls := p.Controls;
for i := 0 to ctls.count-1 do
begin
ci := ctls[i];
if ci is class(tcustomradiobtn) then
begin
if ci=self(true) then continue;
if ci.checked then
begin
ci.checked := false;
end
end
end
end
end
private
function drawchekd(r);override;
begin
if r then
begin
dc := Canvas;
dc.pen.style := PS_SOLID;
dc.brush.color := rgb(200,0,0);
dc.Draw("framecontrol",array(r[0:1],r[2:3]),DFC_BUTTON,DFCS_BUTTONRADIO);
if checked then
begin
r2 := array(r[0:1]+3,r[2:3]-3);
dc.brush.color := 0;
dc.draw("ellipse",r2);
end
end
end
end
type teditable=class(TSLUIBASE) //编辑控件基类
private
FInsertState;
FReadOnly;
FLineWrap;
FString;
FCaretX;
FLeftCharCount;
Flimitlength;
FSelBegin;
FSelLength;
FCanShowCaret;
FFontWidth;
FFontHeight;
FCaretY;
FMouseLbuttonDown;
FHafChar; //半个中文
FBorder;
//////////////////////
[weakref]FHost; //
FClientRect;
FFont;
FVisible;
function SetVisible(v); //可见
begin
nv := v?true:false;
if nv <> FVisible then
begin
FVisible := nv;
if not(FVisible)and FSetFocused then
begin
KillFocus();
InvalidateRect(nil,false);
end
CalcFontSize();
end
end
function SetFont(f); //字体改变
begin
if f then
begin
FFont := f;
if FCanShowCaret and FHost and FHost.HandleAllocated() and FHost.Handle=_wapi.GetFocus() then
begin
recreateCarete();
return InvalidateRect(nil,false);
end
CalcFontSize();
InvalidateRect(nil,false);
updatecaret();
end
end
function InvalidateRect(rec,flg); //刷新
begin
if FHost and FHost.HandleAllocated()then
begin
FHost.InvalidateRect(rec?rec:FClientRect,flg);
end
end
function SetHost(host); //设置宿主
begin
if FHost=host then return;
ohost := FHost;
FHost := nil;
if host is class(TWinControl)then
begin
SetFont(host.font);
FHost := host;
end else
begin
if ohost then ohost.InvalidateRect(GetEntryRect(),false);
end
end
function SetBorder(v); //边框
begin
n := v?true:false;
if n <> FBorder then
begin
FBorder := n;
InvalidateRect(nil,false);
end
end
Function Setplaceholder(p); //提示
begin
if p and ifstring(p)and Fplaceholder <> p then
begin
Fplaceholder := p;
if FHost and not(FString)and FHost.HandleAllocated()then InvalidateRect(nil,false);
end
end
function recreateCarete();//重构光标
begin
DestroyCaret();
CreateCaret();
end
function CreateCaret(); //构造光标
begin
if not(FReadOnly)and not(FCanShowCaret)and FHost and FHost.HandleAllocated()then
begin
CalcFontSize();
h := FFontHeight+4;
hd := FHost.Handle;
_wapi.CreateCaret(hd,nil,1,h);
_wapi.ShowCaret(hd);
FCanShowCaret := true;
end
FIsCaretShow := true;
end
function DestroyCaret(); //销毁光标
begin
if FCanShowCaret and FHost and FHost.HandleAllocated()then
begin
_wapi.HideCaret(FHost.Handle);
_wapi.DestroyCaret();
FCanShowCaret := false;
end
FIsCaretShow := false;
end
function updatecaret();//更新光标
begin
if FCanShowCaret and FHost and FHost.HandleAllocated()then
begin
rec := GetEntryRect();
cx :=(FCaretX-FLeftCharCount-1) * FFontWidth+rec[0];
_Wapi.SetCaretPos(cx,FCaretY);
end
end
function InitSel();//取消选择
begin
FSelBegin := FCaretX;
FSelLength := 0;
end
function GetCharPosByX(x);
begin
rc := GetEntryRect();
cp := FLeftCharCount+integer((x-rc[0])/FFontWidth+0.4)+1;
if bytetype(FString,cp)=2 then return cp+1;
return cp;
end
function CalcFontSize();
begin
FFontWidth := font.width;
FFontHeight := font.Height;
rec := GetEntryRect();
FCaretY := max(0,integer((rec[1]+(rec[3]-rec[1]-FFontHeight)/2))-2);
end
function setReadOnly(v);
begin
nv := v?true:false;
if nv <> FReadOnly then
begin
FReadOnly := nv;
InvalidateRect(nil,false);
end
end
function setEditText(s); //设置文本
begin
if ifstring(s)and s <> FString then
begin
s1 := filterstring(s);
if s1=fstring then return;
if fcanundo and (fundolist.locked<1) then
begin
fundolist.AddChange("del",1,-1,FString);
fundolist.AddChange("ins",1,-1,s1);
end
FString := s1;
if FCaretX=1 then
begin
InitSel();
InvalidateRect(nil,false);
end else
MoveCaretTo(1,0);
doOnChange();
end
end
function setLimitLength(n);
begin
if n >= 0 and n <> Flimitlength then
begin
Flimitlength := n;
end
end
function MoveCaretTo(x_,ifsel);
begin
if x_<1 then x := 1;
else x := min(x_,length(FString)+1);
if x=FCaretX then return;
rec := GetEntryRect();
x1 := FLeftCharCount+1; //rec[0];
fw := font.width;
x2 := integer((rec[2]-rec[0])/fw);
if x<x1 then
begin
FLeftCharCount -=(x1-x);
end else
if x>(x1+x2)then
begin
FLeftCharCount +=(x-x1-x2);
end
FCaretX := x;
////////////显示光标位置////////////////////
//_wapi.SetCaretPos();
if ifsel then
begin
FSelLength := x-FSelBegin;
end else
InitSel();
InvalidateRect(nil,false);
updatecaret();
end
function selectall();//全选
begin
if FString and(FSelBegin <> 1 or FSelLength <> length(FString))then
begin
FSelBegin := 1;
FSelLength := length(FString);
InvalidateRect(nil,false);
end
end
function getselstring(b,e);//获得选择的
begin
if FSelLength <> 0 then
begin
x1 := FSelBegin-(FSelLength<0);
X2 := FSelBegin+FSelLength-(FSelLength>0);
b := min(x1,x2);
e := max(x1,x2);
return FString[b:e];
end
return "";
end
function DeleteSel();//删除选中
begin
if FSelLength <> 0 then
begin
x1 := FSelBegin-(FSelLength<0);
X2 := FSelBegin+FSelLength-(FSelLength>0);
b := min(x1,x2);
e := min(max(x1,x2),length(FString));
if fcanundo and (fundolist.locked<1) then fundolist.AddChange("del",b,e,FString[b:e]);
FString[b:e]:= "";
cx := max(1,min(x1,x2));
InitSel();
BeginUpDate();
InvalidateRect(nil,false);
MoveCaretTo(cx,0);
DeletePerfect();
EndUpDate();
doOnChange();
end
end
function DeletePerfect();//向前删除
begin
if FLeftCharCount>0 then
begin
sz := FFontWidth * (length(FString)-FLeftCharCount);
rec := GetEntryRect();
syl :=((rec[2]-rec[0]-sz)/FFontWidth);
if syl>1 then
begin
FLeftCharCount := max(0,FLeftCharCount-integer(syl));
updatecaret();
InvalidateRect(nil,false);
end
end
end
function dodelete();//向后删除
begin
if FReadOnly then return;
if FSelLength <> 0 then return deletesel();
len := length(FString);
if FCaretX <= length(FString)then
begin
b := FCaretX;
if bytetype(FString,FCaretX)=1 then
begin
e := FCaretX+1;
//FString[(FCaretX):(FCaretX+1)]:= "";
end else
begin
e := b;
//FString[(FCaretX):(FCaretX)]:= "";
end
if fcanundo and (fundolist.locked<1) then fundolist.AddChange("del",b,e,FString[b:e]);
FString[b:e] := "";
BeginUpDate();
InvalidateRect(nil,false);
DeletePerfect();
EndUpDate();
doOnChange();
end
end
function BeginUpDate(); //锁定
begin
if FHost and FHost.HandleAllocated()then
begin
FHost.BeginUpDate();
end
end
function EndUpDate();
begin
if FHost and FHost.HandleAllocated()then
begin
FHost.EndUpDate();
end
end
function dobackspace();//backsapce处理
begin
if FReadOnly then return;
if FSelLength <> 0 then return deletesel();
len := length(FString);
if FCaretX>1 then
begin
cx := FCaretX;
e := FCaretX-1;
if bytetype(FString,FCaretX-1)=2 then
begin
b := FCaretX-2;//FString[(FCaretX-2):(FCaretX-1)]:= "";
cx -= 2;
end else
begin
b := FCaretX-1;//FString[(FCaretX-1):(FCaretX-1)]:= "";
cx--;
end
if fcanundo and (fundolist.locked<1) then fundolist.AddChange("del",b,e,FString[b:e]);
FString[b:e]:= "";
BeginUpDate();
MoveCaretTo(cx,0);
DeletePerfect();
EndUpDate();
doOnChange();
end
end
function GetCBoard(); //剪切板
begin
if not FCopyer then
begin
FCopyer := new TcustomClipBoard(class(tUIglobalData).uigetdata("tuiapplication"));
end
return FCopyer;
end
function CopyToClipboard(); //复制选择
begin
r := getselstring();
GetCBoard().text := r;
end
function cutetoclipboard();//剪切
begin
r := getselstring();
if r then
begin
GetCBoard().text := r;
DeleteSel();
end
end
function PasteFromClipBoard();//粘贴
begin
if readonly then return;
t := GetCBoard().text;
if t then InsertChar(t);
end
protected
function doOnChange();virtual;
begin
end
function doonmaxtext();virtual;
begin
end
function doonsetfocus();virtual;
begin
end
function doonkillfocus();virtual;
begin
end
function filterstring(c);virtual; //过滤
begin
s1 := "";
if ifstring(c)and c then
begin
s1 := replacetext(c,"\r","");
s1 := replacetext(s1,"\n","");
s1 := replacetext(s1,"\t"," ");
end
return s1;
end
function PaintBorder();virtual;
begin
if FBorder or(FFocusBorder and FSetFocused)then
begin
rbc := ClientRect;
if ifarray(rbc)and rbc[2]>rbc[0]and rbc[3]>rbc[1]then
begin
dc := FHost.Canvas;
dc.pen.width := 1;
if FSetFocused then dc.pen.color := 9869000;//rgb(200,150,150);
else dc.pen.color := 11842740;//rgb(180,180,180);
if fhost.Enabled then
dc.brush.Color := FHost.Color;
else dc.brush.color := cldisabledbk;
dc.draw("RoundRect",array(rbc[0:1],rbc[2:3],array(3,3)));
end
end
end
function PaintPlaceHolder(rec);virtual;
begin
if not(FString)and Fplaceholder and ifstring(Fplaceholder)then
begin
dc := FHost.Canvas;
bc := dc.font.color;
dc.font.color := Fplaceholdercolor;
dc.drawtext(Fplaceholder,rec,DT_VCENTER .| DT_SINGLELINE);
dc.font.color := bc;
return true;
end
end
function PaintText(s,rec);virtual;
begin
if FHost and FHost.HandleAllocated()and ifstring(s)and s then
begin
dc := FHost.Canvas;
if not dc.HandleAllocated()then return;
neb := not(FHost.Enabled);
if neb then
begin
dc.font.Color := 0xc0c0c0;
end
if FMarked then
begin
ns := s;
if ifstring(FPassWordChar)and FPassWordChar then vc := FPassWordChar[1];
else vc := "#";
for i := 1 to length(ns) do
begin
ns[i]:= vc;
end
dc.drawtext(ns,rec,DT_VCENTER .| DT_SINGLELINE);
end else
dc.drawtext(s,rec,DT_VCENTER .| DT_SINGLELINE .| DT_NOPREFIX);
end
end
public
function create();
begin
Fplaceholdercolor := 0xc8c8c8;//rgb(200,200,200);
fselbkcolor := 0xff9933;// rgb(51,153,255);
freadonlyColor :=0xf0f0f0;// rgb(240,240,240);
FVisible := true;
FReadOnly := false;
FFocusBorder := true;
FString := "";
FSelBegin := 1;
FSelLength := 0;
FBorder := true;
FCaretX := 1;
FLeftCharCount := 0; //1;
FFont := new Tcustomfont();
fundolist := new tedolist();
fredolist := new tedolist();
fcanundo := true;
end
function InsertChar(c_); //插入
begin
if FSelLength <> 0 then
begin
dobackspace();
end
len := length(FString);
c := filterstring(c_);
if not(ifstring(c)and c)then return;
if Flimitlength>0 then
begin
if Flimitlength <= len then
begin
doonmaxtext();
return;
end else
begin
clen := length(c);
nct := Flimitlength-len;
if nct<clen then
begin
if bytetype(c,nct)=1 then
begin
ns := c[1:nct+1];
end else
ns := c[1:nct];
return InsertChar(ns);
end
end
end
rc := GetEntryRect();
if LineWrap then
begin
if(FFontWidth * (len+1))>(rc[2]-rc[0])then return;
end
if fcanundo and (fundolist.locked<1) then fundolist.AddChange("ins",FCaretX,-1,c);
if FCaretX=1 then
begin
FString := c+FString;
end else
if FCaretX=length(FString)+1 then
begin
FString += c;
end else
begin
FString[FCaretX:0]:= c;
end
MoveCaretTo(FCaretX+length(c),0);
doOnChange();
end
function ExecuteCommand(cmd,pm);virtual;
begin
case cmd of
"canundo":
begin
fcanundo := pm;
end
"ecundo":
begin
undo();
end
"ecredo":
begin
redo();
end
"echome":
begin
MoveCaretTo(1,pm);
end
"ecend":
begin
MoveCaretTo(length(FString)+1,pm);
end
"ecreadonlycolor":
begin
if pm>0 or pm<0 then freadonlyColor := pm;
return freadonlyColor;
end
"ecselbkcolor":
begin
if pm>=0 or pm<0 then fselbkcolor := pm;
return fselbkcolor;
end
"ecplaceholdercolor":
begin
if pm>0 or pm<0 then Fplaceholdercolor := pm;
return Fplaceholdercolor;
end
"ecinsert":
begin
if ifstring(pm)and pm then InsertChar(pm);
end
"ecleft":
begin
if FCaretX>1 then MoveCaretTo(FCaretX-(1+(bytetype(FString,FCaretX-1)=2)),pm);
end
"ecright":
begin
if FCaretX <= length(FString)then MoveCaretTo(FCaretX+(1+(bytetype(FString,FCaretX)=1)),pm);
end
"ecselall":
begin
selectall();
end
"ecsel":
begin
if ifarray(pm)and pm[0]>0 and pm[1]>0 then
begin
MoveCaretTo(pm[0],0);
MoveCaretTo(Pm[1],1);
end
end
"ecclcsel":
begin
if FSelLength <> 0 then
begin
InitSel();
InvalidateRect(nil,false);
end
end
"ecgetsel":
begin
r := getselstring(b,e);
pm := array(b,e);
return r;
end
"ecdelete":
begin
dodelete();
end
"ecbackspace":
begin
dobackspace();
end
"eccopy":
begin
CopyToClipboard();
end
"ecpaste":
begin
PasteFromClipBoard();
end
"eccut":
begin
CopyToClipboard();
DeleteSel();
end
"ecpasswordchar":
begin
if ifstring(pm)and pm then
begin
tm := trim(pm);
if tm then
begin
FPassWordChar := tm[1];
end
end
else return FPassWordChar;
end
"ecmarked":
begin
if ifnil(pm)then
begin
return FMarked;
end else
begin
nv := pm?true:false;
if FMarked <> nv then
begin
FMarked := nv;
InvalidateRect(nil,false);
end
end
end
"ecgetposbyx":
begin
if x >= 0 or x<0 then return GetCharPosByX(x);
end
"eccaretpos":
begin
return FCaretX;
end
"ecclear":
begin
fundolist.lock();
selectall();
dodelete();
fundolist.clear();
fredolist.clear();
fundolist.lock();
end
end;
end
function GetEntryRect();virtual;
begin
r := ClientRect;
if not ifarray(r)then return array(0,0,0,0);
r[0]+= 1;
r[2]-= 1;
r[1]+= 1;
r[3]-= 1;
return r;
end
function WMKEYUP(o,e);virtual;
begin
if FOnKeyUp then
begin
CallMessgeFunction(FOnKeyUp,o,e);
if e.skip then return ;
end
end
function WMKEYDOWN(o,e);virtual;//按键
begin
if FOnKeyDown then
begin
CallMessgeFunction(FOnKeyDown,o,e);
if e.skip then return ;
end
fsft := ssShift in e.shiftstate;
fctl := ssCtrl in e.shiftstate;
case e.CharCode of
VK_INSERT:
begin
FInsertState := not FInsertState;
end
VK_LEFT:
begin
ExecuteCommand("ecleft",fsft);
end
VK_RIGHT:
begin
ExecuteCommand("ecright",fsft);
end
VK_DELETE:
begin
dodelete();
end
VK_HOME:
begin
ExecuteCommand("echome",fsft);
end
VK_END:
begin
ExecuteCommand("ecend",fsft);
end
ord("Z"):
begin
if fctl then
begin
ExecuteCommand("ecundo",0);
end
end
ord("C"):
begin
if fctl then
begin
ExecuteCommand("eccopy");
end
end
ord("V"):
begin
if fctl then
begin
ExecuteCommand("ecpaste");
end
end
ord("X"):
begin
if fctl then
begin
ExecuteCommand("eccut");
end
end
ord("A"):
begin
if fctl then selectall();
end
end
end
function WMCHAR(o,e);virtual;//字符
begin
if fOnKeyPress then
begin
CallMessgeFunction(fOnKeyPress,o,e);
if e.skip then return ;
end
if fcanundo then fredolist.clear();//清空
c := e.CharCode;
case c of
VK_BACK:
begin
return dobackspace();
end
end
if c<32 then return;
if FReadOnly then return;
//////////////////////////
cc := e.char;
if FHafChar then
begin
cc := FHafChar+cc;
FHafChar := 0;
end else
if c .& 0x80 then
begin
FHafChar := cc;
return ;
end
InsertChar(cc);
return ;
/////////////////////////////////
if c .& 0x80 then
begin
if FHafChar then
begin
InsertChar(FHafChar+e.char);
FHafChar := "";
end else
begin
FHafChar := e.char;
end
end else
begin
InsertChar(e.char);
end
end
function FontChanged(o);override;//字体
begin
if FHost and FHost.HandleAllocated()then
begin
if _wapi.GetFocus()=FHost.Handle then
begin
recreateCarete();
end else
begin
CalcFontSize();
InvalidateRect(nil,false);
end
end
end
function Paint(); //绘制
begin
if not FVisible then return;
if not(FHost and FHost.HandleAllocated()and FHost.Canvas.HandleAllocated())then return;
dc := FHost.Canvas;
dc.font := font;
rec := GetEntryRect();
if FReadOnly then
begin
dc.brush.color := freadonlyColor;
dc.FillRect(rec);
end
PaintBorder();
if PaintPlaceHolder(rec)then return;
fw := FFontWidth;
fh := FFontHeight;
if FSelLength <> 0 then //绘制阴影
begin
x1 := FSelBegin-FLeftCharCount-1;
if FSelLength>0 then
begin
x2 := x1+FSelLength;
end else
begin
x2 := x1;
x1 := x2+FSelLength;
end
x1 := max(0,x1);
x2 := max(0,x2);
if x2>x1 then
begin
bc := dc.brush.color;
dc.brush.color := fselbkcolor; ////rgb(0,220,220);
rcb := rec;
rcb[0]:= x1 * fw+rec[0];
rcb[2]:= x2 * fw+rec[0];
if dh>0 then
begin
rcb[1]+= FCaretY;
rcb[3]-= FCaretY;
end
dc.FillRect(rcb);
dc.brush.color := bc;
end
end
if FLeftCharCount>0 then
begin
if bytetype(FString,FLeftCharCount)=1 then
begin
rec[0]-= fw;
dstr := FString[FLeftCharCount:];
end else
dstr := FString[(FLeftCharCount+1):];
end else
dstr := FString;
PaintText(dstr,rec);
//dc.drawtext(dstr,rec,DT_VCENTER .| DT_SINGLELINE);
end
function MouseUp(o,e);
begin
if not(FHost and FHost.HandleAllocated())then return;
FMouseLbuttonDown := false;
_wapi.ClipCursor(0);
end
function MouseMove(o,e);
begin
if not FVisible then return;
if not(FHost and FHost.HandleAllocated())then return;
//move ;
if not FMouseLbuttonDown then return;
rec := GetEntryRect();
x := e.xpos;
if x<rec[0]+2 then x -= FFontWidth * 3;
IF X>rec[2]-2 then x += FFontWidth * 3;
nx := GetCharPosByX(x);
MoveCaretTo(nx,true);
end
function MouseDown(o,e);
begin
if not FVisible then return;
if not(FHost and FHost.HandleAllocated())then return;
rec := GetEntryRect();
if not(pointinrect(e.pos,FClientRect))then return;
if FIsCaretShow and e.shiftdouble() then
begin
return selectall();
end
x := e.xpos;
if x<rec[2]and x>rec[0]then
begin
if e.button()=mbLeft then
begin
x := GetCharPosByX(e.xpos);
MoveCaretTo(x,0);
FMouseLbuttonDown := true;
crect := rec;
if FHost then //固定区域
begin
ps := array(FHost.clienttoscreen(crect[0],crect[1]),FHost.clienttoscreen(crect[2],crect[3]));
_wapi.ClipCursor(ps);
end
end
if not FIsCaretShow then return SetFocus();
end
end
function SetFocus(); //设置焦点
begin
if not FVisible then return;
FSetFocused := true;
if FHost and FHost.HandleAllocated()then
begin
if _wapi.GetFocus()<> FHost.Handle then return FHost.SetFocus();
end
CreateCaret();
updatecaret();
if FFocusBorder then InvalidateRect(nil,false);
doonsetfocus();
end
function KillFocus();//删除焦点
begin
FMouseLbuttonDown := false;
_wapi.ClipCursor(0); //添加输入焦点处理
FSetFocused := false;
DestroyCaret();
if FFocusBorder then InvalidateRect(nil,false);
doonkillfocus();
end
function Recycling();override;
begin
FKillFocus := 0;
FOnSetFocus := 0;
FPassWordChar := "#";
FMarked := 0;
FOnMaxText := 0;
FOnUpdate := 0;
FOnChange := 0;
FOnKeyUp := nil;
FOnKeyDown := nil;
fOnKeyPress := nil;
Fplaceholder := 0;
FHost := nil;
FFont := nil;
inherited;
end
published
property Visible read FVisible write SetVisible;
property text:string read FString write setEditText;
property onmaxtext:eventhandler read FOnMaxText write FOnMaxText; //eventhandler 修改
property placeholder:string read Fplaceholder write Setplaceholder;
property readonly:bool read FReadOnly write setReadOnly;
property limitlength:integer read Flimitlength write setLimitLength;
property LineWrap:bool read FLineWrap write FLineWrap;
property Border read FBorder write SetBorder;
property Font read FFont write SetFont;
property ClientRect read FClientRect write FClientRect; //区域
property host read FHost write SetHost;
property HasFocus read FSetFocused;
property OnKeyPress read FOnKeyPress write FOnKeyPress;
property OnKeyDown read FOnKeyDown write FOnKeyDown;
property onkeyup read FOnKeyUp write FOnKeyUp;
property Focusedborder read FFocusBorder write FFocusBorder;
private
fcanundo;
fredolist;
fundolist;
FIsCaretShow;
FKillFocus;
FPassWordChar;
FMarked;
weakref
FOnSetFocus;
FOnMaxText;
FOnUpdate;
FOnChange;
FOnKeyPress;
FOnKeyDown;
FOnKeyUp;
autoref
Fplaceholder;
FSetFocused;
FFocusBorder;
Fplaceholdercolor;
fselbkcolor;
freadonlyColor;
static FCopyer;
private
function undo();
begin
if not fcanundo then return ;
it := fundolist.pop();
if not it then return ;
fundolist.lock();
try
doitem(it);
except
end;
case it.freason of
"del":it.freason := "ins";
"ins":it.freason := "del";
end ;
fredolist.AddChange(it);
fundolist.unlock();
//if not canundo then return ;
end
function redo();
begin
if not fcanundo then return ;
it := fredolist.pop();
if not it then return ;
doitem(it);
//if not canundo then return ;
end
function doitem(it);
begin
case it.freason of
"del":
begin
s := it.ftext;
b := it.FStart;
FCaretX := b;
InitSel();
InsertChar(s);
end
"ins":
begin
s := it.ftext;
b := it.FStart;
FSelBegin := b;
FSelLength := length(s);
FCaretX := b+FSelLength;
dodelete();
end
end ;
end
end
type tVirtualCalender=class(TSLUIBASE)
{**
@explan(说明) 月历控件虚拟类
**}
function create();
begin
inherited;
FFont := new Tcustomfont();
FDateRows := 7;
FCalenderState := 3;
FLeft := 0;
FTop := 0;
FCellWidth := 30;
FCellHeight := 16;
FYear := 2021;
FMonth := 3;
FDate := 3;
FHasMonthSel := true;
FHasToday := true;
FTodayHeight := 20;
FMonthselheight := 25;
FDateMatrix := array();
CalcDateMatrx();
end
function InvalidateRect(rec,f);
begin
if FHost and FHost.HandleAllocated()then
begin
FHost.InvalidateRect(rec ?: GetCalenderRect(),f);
end
end
function GetPreferredSize(w,h);override;
begin
calc_size_base();
w := FCellWidth *7;
h := FCellHeight*9;
end
function dodatechanged();virtual;
begin
if FHost and FHost.HandleAllocated()then
begin
FHost.DoDatechanged();
end
end
function ExecuteCommand(cmd,p);
begin
case cmd of
"metodaybutton":
begin
if ifnil(p)then return FHasToday;
else
begin
nv := p?true:false;
if FHasToday <> nv then
begin
FHasToday := nv;
CalcDateMatrx();
InvalidateRect(nil,false);
end
end
end
"mestate":
begin
if(p <> FCalenderState)and(p in array(1,2,3))then
begin
FCalenderState := p;
CalcDateMatrx();
InvalidateRect(nil,false);
end else
return FCalenderState;
end
"meyear":
begin
//设置年
if(p>0 or p <= 0)and p <> FYear then
begin
FYear := p;
CalcDateMatrx();
InvalidateRect(nil,false);
dodatechanged();
end
return FYear;
end
"meminc":
begin
d := incmonth(encodedate(FYear,FMonth,FDate),not(p>0 or p<1)?1:(p));
decodedate(d,y,m,d);
FYear := y;
FMonth := max(m,1);
FDate := max(d,1);
CalcDateMatrx();
InvalidateRect(nil,false);
dodatechanged();
end
"memonth":
begin
//设置月
if FMonth <> p and(p>0 or p<13)then
begin
ModifyDate(FYear,p,FDate);
FMonth := p;
CalcDateMatrx();
InvalidateRect(nil,false);
dodatechanged();
end
return FMonth;
end
"meyearmonth":
begin
//设置年,月
if ifarray(p)and ifnumber(p[0])and ifnumber(p[1])then
begin
if p[0]<> FYear or p[1]<> FMonth then
begin
ExecuteCommand("meymd",encodedate(p[0],p[1],FDate));
end
end
end
"medate":
begin
if p <> FDate and p>0 and p <= getmonthdates(FYear,FMonth)then
begin
FDate := p;
CalcDateMatrx();
InvalidateRect(nil,false);
dodatechanged();
end
return FDate;
end
"meymd":
begin
if p >= 0 or p<0 then
begin
decodedate(p,y,m,d);
if y <> FYear or FMonth <> m or FDate <> d then
begin
FYear := y;
FMonth := m;
FDate := d;
CalcDateMatrx();
InvalidateRect(nil,false);
dodatechanged();
end
end else
return encodedate(FYear,FMonth,FDate);
end
"meselbypos":
begin
r := ExecuteCommand("megetbypos",p);
if not r then return;
if r="today" then
begin
FCalenderState := 3;
ExecuteCommand("meymd",date());
end
case FCalenderState of
3:
begin
ExecuteCommand("medate",r);
end
2:
begin
FCalenderState := 3;
m := FMonth;
d := FDate;
y := FYear;
ExecuteCommand("memonth",r);
if(m=FMonth)and(d=FDate)and(y := FYear)then
begin
CalcDateMatrx();
InvalidateRect(nil,false);
end
end
1:
begin
FCalenderState := 2;
m := FMonth;
d := FDate;
y := FYear;
ExecuteCommand("meyear",r);
if(m=FMonth)and(d=FDate)and(y := FYear)then
begin
CalcDateMatrx();
InvalidateRect(nil,false);
end
end
end;
return r;
end
"mestatebypos": //切换状态
begin
r := ExecuteCommand("megetstatepos",p);
ExecuteCommand("mestate",r);
return r;
end
"megetstatepos": //状态改变区域
begin
if not(FYearRect and FMonthRect)then return;
if(p)then
begin
p0 := p[0];
p1 := p[1];
if not(p0>0 or p0<0)then return;
if not(p1>0 or p1<0)then return;
x := p0-FLeft;
y := p1-FTop;
pp := array(x,y);
if pointinrect(pp,FYearRect)then return 1;
if pointinrect(pp,FMonthRect)then return 2;
return 0;
end
end
"megetincpos": //获得month inc month dec
begin
if not(FIncRect and FDecRect)then return;
if(p)then
begin
p0 := p[0];
p1 := p[1];
if not(p0>0 or p0<0)then return;
if not(p1>0 or p1<0)then return;
x := p0-FLeft;
y := p1-FTop;
pp := array(x,y);
if pointinrect(pp,FIncRect)then return 1;
if pointinrect(pp,FDecRect)then return -1;
end
end
"megetbypos":
begin
if ifarray(p)then
begin
p0 := p[0];
p1 := p[1];
if not(p0>0 or p0<0)then return;
if not(p1>0 or p1<0)then return;
x := p0-FLeft;
y := p1-FTop-(FHasMonthSel * FMonthselheight);
pp := array(x,y);
if pointinrect(pp,FTodyRect)then
begin
return "today";
end
if FCalenderState=3 then
begin
for i := 1 to 6 do
begin
for j := 0 to 6 do
begin
d := FDateMatrix[i,j];
if ifarray(d)then
begin
rec := d["rec"];
if pointinrect(pp,rec)then
begin
return d["value"];
end
end
end
end
end else
if FCalenderState in array(2,1)then
begin
for i,d in FDateMatrix do
begin
if ifarray(d)then
begin
rec := d["rec"];
if pointinrect(pp,rec)then
begin
return d["value"];
end
end
end
end
end
end
end
end
function paint();
begin
if not(host and host.HandleAllocated())then return;
dc := host.Canvas;
if not(dc and dc.HandleAllocated())then return;
//dc.font := array("width":7,"height":14);
CalcDateMatrx();
if FHasMonthSel then
begin
dc.brush.color := clMenuBar;//14474440;//rgb(200,220,220);
dc.fillrect(array(FLeft,FTop,FLeft+FCellWidth * 7,FTop+FMonthselheight));
if FDecRect then dc.draw("framecontrol",array((FDecRect[0]+FLeft,FDecRect[1]+FTop),(FDecRect[2]+FLeft,FDecRect[3]+FTop)),DFC_SCROLL,DFCS_SCROLLLEFT);
if FIncRect then dc.draw("framecontrol",array((FIncRect[0]+FLeft,FIncRect[1]+FTop),(FIncRect[2]+FLeft,FIncRect[3]+FTop)),DFC_SCROLL,DFCS_SCROLLRIGHT);
if FYearRect then
begin
rec := FYearRect;
rec[0]+= FLeft;
rec[2]+= FLeft;
rec[1]+= FTop;
rec[3]+= FTop;
if FCalenderState=1 then
begin
dc.brush.color := clHighlight;//16445680;//rgb(240,240,250);
dc.fillrect(rec);
end
dc.font.weight := 700;
dc.drawtext(inttostr(FYear)+"年",rec,DT_VCENTER.|DT_RIGHT);
end
if FMonthRect then
begin
rec := FMonthRect;
rec[0]+= FLeft;
rec[2]+= FLeft;
rec[1]+= FTop;
rec[3]+= FTop;
if FCalenderState=2 then
begin
dc.brush.color := clHighlight;//16445680;//rgb(240,240,250);
dc.fillrect(rec);
end
dc.font.weight := 700;
dc.drawtext(inttostr(FMonth)+"月",rec,DT_VCENTER.|DT_LEFT);
end
end
t := FTop+(FMonthselheight * FHasMonthSel);
if FCalenderState in array(1,2)then
begin
for i,d in FDateMatrix do
begin
if not ifarray(d)then continue;
rec := d["rec"];
if not rec then continue;
rec[0]+= FLeft;
rec[2]+= FLeft;
rec[1]+= t;
rec[3]+= t;
if d["sel"]then
begin
dc.brush.color := clHotLight ;//6579400;//rgb(200,200,100);
dc.FillRect(rec);
end
dc.drawtext(d["text"],rec,DT_CENTER .| DT_VCENTER .| DT_SINGLELINE);
end
end else
if FCalenderState=3 then
begin
for i := 0 to 6 do
begin
for j := 0 to 6 do
begin
d := FDateMatrix[i,j];
if not ifarray(d)then continue;
rec := d["rec"];
if not rec then continue;
rec[0]+= FLeft;
rec[2]+= FLeft;
rec[1]+= t;
rec[3]+= t;
if d["sel"]then
begin
dc.brush.color := clHotLight;//6579400;//rgb(200,200,100);
dc.FillRect(rec);
end
if i=0 then dc.font.weight := 700;
else dc.font.weight := 400;
dc.drawtext(d["text"],rec,DT_CENTER .| DT_VCENTER .| DT_SINGLELINE);
end
end
dc.pen.width := 1;
dc.pen.color := 0;
dc.moveto(array(FLeft,t+FCellHeight));
dc.LineTo(array(FLeft+FCellWidth * 7,t+FCellHeight));
end
if FTodyRect then
begin
rec := FTodyRect;
rec[0]+= FLeft;
rec[2]+= FLeft;
rec[1]+= t;
rec[3]+= t;
dc.brush.color := clMenuBar;//6579400;//rgb(200,200,200);
dc.fillrect(rec);
dc.drawtext(" today: "+datetimetostr(date()),rec,DT_LEFT);
end
end
function recycling();override;
begin
inherited;
FHost := nil;
FFont := nil;
end
published
property Left read FLeft write SetLeft;
property top read FTop write SetTop;
property host read FHost write sethost;
property ClientRect read GetCalenderRect;
private
function ModifyDate(y,m,d);
begin
ct := getmonthdates(y,m);
if d>ct then d := ct;
end
function sethost(h);
begin
if host <> h then
begin
FHost := h;
end
end
function SetLeft(v);
begin
if FLeft <> v then
begin
FLeft := integer(v);
InvalidateRect(nil,false);
end
end
function settop(v);
begin
if FTop <> v then
begin
FTop := integer(v);
InvalidateRect(nil,false);
end
end
function GetCalenderRect();
begin
calc_size_base();
return array(FLeft,FTop,FLeft+FCellWidth * 7,FTop+FHasMonthSel * FMonthselheight+FCellHeight * FDateRows+FHasToday * FTodayHeight);
end
function calc_size_base();
begin
if FHost then
begin
ft := FHost.Font;
FCellWidth := ft.Width*3;
FCellHeight := ft.Height+4;
FTodayHeight := FCellHeight;
FMonthselheight := FCellHeight;
end
end
function CalcDateMatrx();
begin
calc_size_base();
FDecRect := array();
FIncRect := array();
FTodyRect := array();
if FHasMonthSel then
begin
FDecRect := array(5,2,25,22);
x := 7 * FCellWidth-25;
FIncRect := array(x,2,x+20,22);
FYearRect := array(30,2,30+FCellWidth*3.5-20,FCellHeight);
FMonthRect := array(FYearRect[2]+5,2,x-5,FCellHeight);
end
if FHasToday then
begin
x := 7 * FCellWidth;
y := FDateRows * FCellHeight;
FTodyRect := array(0,y+1,x,y+FTodayHeight);
end
FDateMatrix := array();
if FCalenderState=3 then
begin
for i,v in array("日","一","二","三","四","五","六") do
begin
x0 := i * FCellWidth;
x1 := x0+FCellWidth;
y0 := cidx * FCellHeight;
y1 := y0+FCellHeight;
data := array();
data["rec"]:= array(x0,y0,x1,y1);
data["text"]:= v;
FDateMatrix[0,i]:= data;
end
if FYear>0 and FMonth>0 then
begin
ct := getmonthdates(FYear,FMonth);
cidx := 1;
for i := 1 to ct do
begin
dt := encodedate(FYear,FMonth,i);
dw :=(dayofweek(dt)-1);
if i=1 then //之前的
begin
//上一个月
end
x0 := dw * FCellWidth;
x1 := x0+FCellWidth;
y0 := cidx * FCellHeight;
y1 := y0+FCellHeight;
data := array();
data["rec"]:= array(x0,y0,x1,y1);
data["text"]:= inttostr(i);
data["value"]:= i;
data["sel"]:=(FDate=i);
FDateMatrix[cidx,dw]:= data;
if dw=6 then
begin
cidx++;
end
if i=ct then
begin
//下一个月
end
end
end
end else
if FCalenderState=2 then //月选择
begin
cw := integer(FCellWidth * 1.7);
ch := integer(FCellHeight * 2);
for i := 1 to 12 do
begin
data := array();
divmod(i-1,4,a,b);
x0 := b * cw+5;
x1 := x0+cw;
y0 := a * ch+5;
y1 := y0+ch;
data := array();
data["rec"]:= array(x0,y0,x1,y1);
data["text"]:= inttostr(i)+"月";
data["value"]:= i;
data["sel"]:=(FMonth=i);
FDateMatrix[i]:= data;
end
end else
if FCalenderState=1 then //年选择
begin
cw := integer(FCellWidth * 1.7);
ch :=(FCellHeight);
for i,v in((FYear-13)->(FYear+14)) do
begin
data := array();
divmod(i,4,a,b);
x0 := b * cw+5;
x1 := x0+cw;
y0 := a * ch+5;
y1 := y0+ch;
data := array();
data["rec"]:= array(x0,y0,x1,y1);
data["text"]:= inttostr(v);
data["value"]:= v;
data["sel"]:=(FYear=v);
FDateMatrix[i]:= data;
end
end
end
private
FFont;
FDateRows;
FYearRect;
FMonthRect;
FCalenderState;
FTodyRect;
FHasToday;
FTodayHeight;
FIncRect;
FDecRect;
FMonthselheight;
FHasMonthSel;
FDateMatrix;
FDate;
FMonth;
FYear;
FHost;
FLeft;
FTop;
FCellWidth;
FCellHeight;
end
type tcustombevel = class(TGraphicControl)
{**
@explan(说明)bevel控件 %%
**}
function create(AOwner);
begin
inherited;
Color := clMenu;
transparent := false;
caption := "";
fshape := bsbox;
fstyle := bsLowered;
end
function paint();override;
begin
if iffuncptr(OnPaint) then call(OnPaint,self(true));
cvs := Canvas;
cvs.pen.Width := 1;
aleft := 0;
atop := 0;
AWidth := Width;
AHeight := Height;
if fstyle=bsRaised then
begin
Colora := cl3DHilight;
Colorb := cl3DShadow;
end else
begin
Colora := cl3DShadow;
Colorb := cl3DHilight;
end
case fshape of
bsbox:
begin
cvs.Pen.Color:=Colora;
cvs.MoveTo(array(ALeft, ATop + AHeight - 1));
cvs.LineTo(array(ALeft, ATop));
cvs.LineTo(array(ALeft + AWidth - 1, ATop));
cvs.Pen.Color:=Colorb;
cvs.LineTo(array(ALeft + AWidth - 1, ATop + AHeight - 1));
cvs.LineTo(array(ALeft , ATop + AHeight - 1));
end
bsframe:
begin
cvs.Pen.Color:=Colora;
cvs.MoveTo(array(ALeft, ATop + AHeight - 1));
cvs.LineTo(array(ALeft, ATop));
cvs.LineTo(array(ALeft + AWidth - 1, ATop));
cvs.MoveTo(array(ALeft + AWidth - 2, ATop + 1));
cvs.LineTo(array(ALeft + AWidth - 2, ATop + AHeight - 2));
cvs.LineTo(array(ALeft + 1, ATop + AHeight - 2));
cvs.Pen.Color:=Colorb;
cvs.MoveTo(array(ALeft + 1, ATop + AHeight - 2));
cvs.LineTo(array(ALeft + 1, ATop + 1));
cvs.LineTo(array(ALeft + AWidth - 2, ATop + 1));
cvs.MoveTo(array(ALeft + AWidth - 1, ATop));
cvs.LineTo(array(ALeft + AWidth - 1, ATop + AHeight - 1));
cvs.LineTo(array(ALeft, ATop + AHeight - 1));
end
bsTopLine:
begin
cvs.Pen.Color:=Colora;
cvs.MoveTo(array(ALeft, ATop));
cvs.LineTo(array(ALeft + AWidth - 1, ATop));
cvs.Pen.Color:=Colorb;
cvs.MoveTo(array(ALeft, ATop + 1));
cvs.LineTo(array(ALeft + AWidth - 1, ATop + 1));
end
bsBottomLine:
begin
cvs.Pen.Color:=Colorb;
cvs.MoveTo(array(ALeft, ATop + AHeight - 1));
cvs.LineTo(array(ALeft + AWidth - 1, ATop + AHeight - 1));
cvs.Pen.Color:=Colora;
cvs.MoveTo(array(ALeft, ATop + AHeight - 2));
cvs.LineTo(array(ALeft + AWidth - 1, ATop + AHeight - 2));
end
bsLeftLine:
begin
cvs.Pen.Color:=Colora;
cvs.MoveTo(array(ALeft, ATop));
cvs.LineTo(array(ALeft, ATop + AHeight - 1));
cvs.Pen.Color:=Colorb;
cvs.MoveTo(array(ALeft + 1, ATop));
cvs.LineTo(array(ALeft + 1, ATop + AHeight - 1));
end
bsRightLine:
begin
cvs.Pen.Color:=Colorb;
cvs.MoveTo(array(ALeft + AWidth - 1, ATop));
cvs.LineTo(array(ALeft + AWidth - 1, ATop + AHeight - 1));
cvs.Pen.Color:=Colora;
cvs.MoveTo(array(ALeft + AWidth - 2, ATop));
cvs.LineTo(array(ALeft + AWidth - 2, ATop + AHeight));
end
end
end
published
property shape:tbevelshape read fshape write setshape;
property style:tbevelstyle read fstyle write setstyle;
protected
private
function setshape(v);
begin
if not( v in array(0,1,2,3,4,5,6)) then return ;
if v=fshape then return ;
fshape := v;
InvalidateRect(nil,false);
end
function setstyle(v);
begin
if not( v in array(0,1)) then return ;
if v=fstyle then return ;
fstyle := v;
InvalidateRect(nil,false);
end
fshape;
fstyle;
end
type TcustomLabel = class(TGraphicControl)
{**
@explan(说明)标签控件 %%
**}
private
FTextAlign;
function SetTextAlign(v);
begin
if v <> FTextAlign then
begin
FTextAlign := v;
InvalidateRect(nil,true);
end
end
public
function RealSetText(s);override;
begin
{**
@explan(说明) 修改标题 %%
**}
if ifstring(s)and caption <> s then
begin
inherited;
//if autosize then set_Preferre_size();
if NoRecycled() then AdjustSize();
end
end
function AdjustSize();override;
begin
if autosizing then return ;
if autosize then
set_Preferre_size();
inherited;
end
function FontChanged(o);override;
begin
if autosize then
set_Preferre_size();
else
InvalidateRect(nil,false);
end
function paint();override;
begin
dc := canvas;
rc := ClientRect;
if border then
begin
rc[0]+= 1;
rc[1]+= 1;
rc[2]-= 1;
rc[3]-= 1;
end
c := caption;
if c then
begin
dc.font := font;
CanvasDrawAlignText(dc,rc,c,FTextAlign);
end
if border then
begin
dc.Draw("polyline",array((rc[0],rc[1]),(rc[2],rc[1]),(rc[2],rc[3]),(rc[0],rc[3]),(rc[0],rc[1])));
end
end
function create(AOwner);override;
begin
inherited;
caption := "label";
FTextAlign := 0;
//border := true;
end
class function CanvasDrawAlignText(dc,rect,txt,al);
begin
{**
@explan(说明) 在指定区域内按照对齐方式绘制文本%%
@param(al)(member of TAlignStyle9) 对齐方式 %%
**}
if not(dc is class(TCustomcanvas))then exit;
als := array(36,0,33
,2,36
,37
,38,40
,41
,42);
val := als[al];
if ifnil(val)then val := 36;
return dc.drawtext(txt,rect,val .| DT_NOPREFIX);
end
published
property TextAlign:AlignStyle9 read FTextAlign write SetTextAlign;
{**
@param(TextAlign)(member of TAlignStyle9) 文字对齐 %%
**}
end
type tcustomedit=class(TCustomControl)
{**
@explan(说明) 单行文本编辑框类 %%
**}
private
FEditable;
type TEntryEditable=class(teditable)
function Create();
begin
inherited;
end
function doonmaxtext();override;
begin
if host then host.doonmaxtext();
end
function doOnChange();override;
begin
if host then host.DoChanged();
end
end
public
function Create(AOwner);override;
begin
inherited;
feditpopmenu := new TcustomPopupmenu(self);
fcopym := new TcustomMenu(self);
fpastem := new TcustomMenu(self);
fcutm := new TcustomMenu(self);
fcopym.caption := "复制";
fpastem.caption := "粘贴";
fcutm.caption := "剪切";
fcopym.Parent := feditpopmenu;
fpastem.Parent := feditpopmenu;
fcutm.Parent := feditpopmenu;
PopupMenu := feditpopmenu;
fcopym.OnClick := thisfunction(editcopy);
fpastem.OnClick := thisfunction(editpaste);
fcutm.OnClick := thisfunction(editcute);
end
function AfterConstruction();override;
begin
inherited;
Border := true;
Left := 10;
Top := 10;
//Ftextalign := 0;
Width := 80;
Height := 25;
FEditable := new TEntryEditable();
FEditable.Border := false;
FEditable.host := self(true);
end
function ncpaint(rec);override;
begin
dc := Canvas;
ls := array((0,0),(rec[2]-rec[0]-1,0),(rec[2]-rec[0]-1,rec[3]-rec[1]-1),(0,rec[3]-rec[1]-1),(0,0));
dc.moveto(ls[3]);
dc.pen.color := rgb(236,236,236);
dc.LineTo(ls[0]);
dc.LineTo(ls[1]);
dc.LineTo(ls[2]);
dc.pen.color := rgb(131,131,131);
dc.LineTo(ls[3]);
end
function ExecuteCommand(cmd,pm);override;
begin
if FEditable then return FEditable.ExecuteCommand(cmd,pm);
end
function SetSel(bgid,edid);
begin
{**
@explan(说明)设置选择文本 %%
@param(bgid)(integer) 开始位置 默认为0 %%
@param(edid)(integer) 结束位置 默认为整体长度 %%
**}
return ExecuteCommand("ecsel",array(bgid+1,edid+1));
end
function Paint();override;
begin
if FEditable then FEditable.Paint();
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if FEditable then FEditable.MouseUp(o,e);
inherited;
end
function MouseMove(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if FEditable then FEditable.MouseMove(o,e);
inherited;
end
function MouseDown(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if FEditable then FEditable.MouseDown(o,e);
inherited;
end
function dosetfocus(o,e);override;
begin
if csDesigning in ComponentState then return;
if FEditable then
begin
FEditable.SetFocus();
end
inherited;
end
function dokillfocus(o,e);override;
begin
if csDesigning in ComponentState then return;
if FEditable then
begin
FEditable.killFocus();
end
inherited;
end
function DoWMSIZE(o,e);override;
begin
if FEditable then
begin
rc := geteditrect();//ClientRect;
FEditable.ClientRect := rc;
end
inherited;
end
function GetPreferredSize(w,h);override;
begin
w := Width;
ft := Font;
h := ft.Height+5;
end
function ContextMenu(o,e);override;
begin
if not FEditable then return ;
if PopupMenu<>feditpopmenu then return inherited;
flg := FEditable.ExecuteCommand("ecgetsel",pm)?true:false ;
fcopym.Enabled := flg;
fcutm.Enabled := flg and not(FEditable.readonly);
return inherited;
end
function keypress(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if FEditable then
begin
FEditable.WMCHAR(o,e);
end
inherited;
end
function KeyDown(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if FEditable then FEditable.WMKEYDOWN(o,e);
inherited;
end
function doonmaxtext();
begin
if FOnMaxText then
CallMessgeFunction(FOnMaxText,self(true),new tuieventbase(0,0,0,0));
end
function DoChanged();
begin
if FOnChange then
CallMessgeFunction(FOnChange,self(true),new tuieventbase(0,0,0,0));
if FOnUpdate then
CallMessgeFunction(FOnUpdate,self(true),new tuieventbase(0,0,0,0));
end
function FontChanged(sender);override;
begin
FEditable.font := Font;
inherited;
end
function Recycling();override;
begin
inherited;
FOnUpdate := nil;
FOnChange := nil;
fonmaxtext := nil;
if FEditable then FEditable.Recycling();
FEditable := nil;
end
published
property text:string read getentrytext write setentrytext;
property onmaxtext:eventhandler read Fonmaxtext write fonmaxtext;
property onupdate read FOnUpdate write FOnUpdate;
property onchange read FOnChange write FOnChange;
property onchanged:eventhandler read FOnChange write FOnChange;
property readonly:bool read getReadOnly write setReadOnly;
property limitlength:integer read getlimitlength write setLimitLength;
property LineWrap read getLineWrap write setLineWrap;
property placeholder:string read getplaceholder write Setplaceholder;
//property Border:bool read getBorder write SetBorder;
{**
@param(LineWrap)(bool)自动换行,默认为false不自动换行%%
@param(onmaxtext)(fpointer)达到文本最大回调%%
@param(onupdate)(fpointer)文本更新回调%%
@param(onchange)(fpointer)文本改变回调%%
@param(readonly)(bool)只读%%
@param(onlimitlength)(integer)设置输入字符的长度%%
**}
private
function geteditrect();virtual;
begin
r := ClientRect;
r[2]-=1;
r[3]-=1;
return r;
end
{function getBorder();
begin
if FEditable then return FEditable.Border;
end
function setBorder(s);override;
begin
if FEditable then return FEditable.Border := s;
end}
function getentrytext();
begin
if FEditable then return FEditable.text;
return "";
end
function setentrytext(s);
begin
if FEditable then return FEditable.text := s;
end
function getplaceholder();
begin
if FEditable then return FEditable.placeholder;
end
function setplaceholder(v);
begin
if FEditable then return FEditable.placeholder := v;
end
function getReadOnly();
begin
if FEditable then return FEditable.readonly;
end
function setReadOnly(v);
begin
nv := v?true:false;
fcutm.Enabled := nv;
fpastem.Enabled := nv;
if FEditable then return FEditable.readonly := v;
end
function getlimitlength();
begin
if FEditable then return FEditable.limitlength;
end
function setLimitLength(n);
begin
if FEditable then return FEditable.limitlength := n;
end
function getLineWrap();
begin
if FEditable then return FEditable.LineWrap;
end
function setLineWrap(v);
begin
if FEditable then return FEditable.LineWrap := v;
end
function editpaste();
begin
if FEditable then FEditable.ExecuteCommand("ecpaste");
end
function editcopy();
begin
if FEditable then FEditable.ExecuteCommand("eccopy");
end
function editcute();
begin
if FEditable then FEditable.ExecuteCommand("eccut");
end
feditpopmenu;
fcopym;
fpastem;
fcutm;
weakref
FOnUpdate;
FOnChange;
fonmaxtext;
autoref
end
type tcustompassword = class(tcustomedit)
{**
@explan(说明) 密码编辑框类 %%
**}
private
function SetPassWordChar(v);
begin
return ExecuteCommand("ecpasswordchar",v);
end
function getPassWordChar();
begin
return ExecuteCommand("ecpasswordchar");
end
public
function create(owner);override;
begin
inherited;
ExecuteCommand("ecmarked",true);
Left := 10;
Top := 10;
Width := 80;
Height := 25;
caption := "tpassword";
end
function KeyDown(o,e);override;
begin
if ( ssCtrl in e.shiftstate) and (ord("C")=e.CharCode) then
begin
return ;
end
inherited;
end
published
property PassWordChar:string read getPassWordChar write SetPassWordChar;
end
type tthreeEntry=class(TCustomControl)
private
type tpickerEditer=class(teditable)
function Create();
begin
inherited;
border := false;
end
function valuemodify();
begin
//修改日期
if host then Host.ExecuteCommand("dtchanged",self);
end
fprev;
fnext;
protected
function doonsetfocus();override;
begin
ExecuteCommand("ecselall");
end
function doonkillfocus();override;
begin
valuemodify();
ExecuteCommand("ecclcsel");
end
public
function GetEntryRect();override;
begin
r := ClientRect;
if not ifarray(r)then return array(0,0,0,0);
return r;
end
function WMCHAR(o,e);override;
begin
case e.char of
"0" to "9":return inherited;
end;
case e.CharCode of
VK_DELETE,VK_BACK:inherited;
end;
end
function WMKEYDOWN(o,e);override;
begin
case e.CharCode of
13:
begin
return valuemodify();
end
VK_LEFT:
begin
return GoToPrev();
end
VK_RIGHT:
begin
return gotonext();
end
VK_UP:
begin
return inc();
end
VK_DOWN:
begin
return dec();
end
end
inherited;
end
function inc();
begin
s := text;
text := inttostr(strtointdef(s,0)+1);
valuemodify();
end
function dec();
begin
s := text;
text := inttostr(strtointdef(s,0)-1);
valuemodify();
end
private
function gotonext();
begin
valuemodify();
if fnext then
begin
KillFocus();
fnext.SetFocus();
end
end
function GoToPrev();
begin
valuemodify();
if fprev then
begin
KillFocus();
fprev.SetFocus();
end
end
end
public
function create(aowner);
begin
inherited;
end
function AfterConstruction();override;
begin
inherited;
border := true;
left := 0;
top := 0;
height := 24;
width := 105;
FFontWidth := font.width;
//color := rgb(100,100,100);
FEntrys := array();
for i := 0 to 2 do
begin
o := new tpickerEditer();
FEntrys[i]:= o;
o.limitlength := getEntryWidth(i);
end
for i := 0 to 2 do
begin
FEntrys[i].fnext := FEntrys[(i+1)mod 3];
FEntrys[(i+1)mod 3].Fprev := FEntrys[i];
end
calcCtls();
FEntrys :: mcell.host := self(true);
end
function GetPreferredSize(w,h);override;
begin
ft := font;
if ft then
begin
fth := ft.Height;
ftw := ft.Width;
w := ftw*11+fth;
h := fth+4;
end
end
function paint();override;
begin
for i,v in FEntrys do
begin
v.paint();
end
dc := Canvas;
for i,v in FSymInfo do
begin
if not ifarray(v)then continue;
dc.drawtext(v["sym"],v["rec"],DT_CENTER .| DT_VCENTER .| DT_SINGLELINE);
end
PaintBtn();
end
function PaintBtn();virtual;
begin
if FBtnRect then
begin
dc := Canvas;
dc.Draw("framecontrol",array(FBtnRect[0:1],FBtnRect[2:3]),DFC_SCROLL,DFCS_SCROLLDOWN);
end
end
function AdjustSize();override;
begin
if autosizing then return ;
if not HandleAllocated() then return ;
calcCtls();
class(TWinControl).AdjustSize();
end
{function WMSize(o,e):LM_SIZE;virtual;
begin
end
function DoWMSIZE(o,e);override;
begin
calcCtls();
InvalidateRect(nil,false);
inherited;
end}
function dosetfocus(o,e);override;
begin
if csDesigning in ComponentState then return;
for i,v in FEntrys do
begin
if v.HasFocus then return v.SetFocus();
end
for i,v in FEntrys do
begin
return v.SetFocus();
end
inherited;
end
function dokillfocus(o,e);override;
begin
if csDesigning in ComponentState then return;
for i,v in FEntrys do
begin
if v.HasFocus then return v.killFocus();
end
inherited;
end
function keypress(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
for i,v in FEntrys do
begin
if v.HasFocus then return v.WMCHAR(o,e);
end
inherited;
end
function KeyDown(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
for i,v in FEntrys do
begin
if v.HasFocus then return v.WMKEYDOWN(o,e);
end
inherited;
end
function btnClicked(p);virtual;
begin
if pointinrect(p,FBtnRect)then
begin
return 1;
end
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if e.button()=mbLeft then
begin
p := e.pos;
if btnClicked(p)then return;
for i,v in FEntrys do
begin
if v.HasFocus then return v.MouseUp(o,e);
end
end
inherited;
end
function MouseMove(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
for i,v in FEntrys do
begin
if v.HasFocus then
begin
return v.MouseMove(o,e);
end
end
inherited;
end
function MouseDown(o,e);override;
begin
if csDesigning in ComponentState then return;
if e.skip then return;
if e.button()=mbLeft then
begin
p := e.pos;
if pointinrect(p,FBtnRect)then return;
idx :=-1;
for i,v in FEntrys do
begin
if pointinrect(p,v.GetEntryRect())then
begin
idx := i;
end else
v.KillFocus();
end
if idx >= 0 then return FEntrys[idx].MouseDown(o,e);
end
inherited;
end
function recycling();override;
begin
inherited;
For i,v in FEntrys do
begin
v.recycling();
end
FEntrys := array();
FSymInfo := array();
end
function FontChanged(o);override;
begin
//改变
ft := font;
if ft then
begin
FFontWidth := ft.width;
for i,v in FEntrys do v.Font := ft;
//calcCtls();
inherited;
end
end
protected
function calcCtls();virtual;
begin
rec := ClientRect;
h := rec[3]-rec[1];
wd := rec[2]-rec[0];
FBtnRect := array(max(0,integer(rec[2]-min(25,h))),rec[1],rec[2]-1,rec[3]-1);
x := rec[0]+1;
FSymInfo := array();
for i,v in FEntrys do
begin
nx := x+integer(FFontWidth * (getEntryWidth(i))+2);
rc := array(x,rec[1],nx,rec[3]);
v.ClientRect := rc;
x := nx;
if i=2 then return;
nx := x+FFontWidth+1;
rc := array(x,rec[1],nx,rec[3]);
FSymInfo[i,"sym"]:= getSym(i);
FSymInfo[i,"rec"]:= rc;
x := nx;
end
end
property BtnRect Read FBtnRect;
property entrys read FEntrys;
private
function getEntryWidth(i);virtual;
begin
case i of
0:return 4;
else return 2;
end
end
function getSym(i);virtual;
begin
return "/";
end
FSymInfo;
FBtnRect;
FFontWidth;
FEntrys;
end
type TCustomListBoxbase=class(TCustomScrollControl)
{**
@explan(说明) listbox基类
**}
private
FItemCount;
FMaxItemWidth;
protected /////////////////滚动条相关//////////////////////////////////////////
function GetClientXCapacity();virtual; //宽度容量
begin
c := ClientRect;
r := integer(c[2]/GetXScrollDelta());
return r;
end
function GetClientYCapacity();virtual; //高度容量
begin
c := ClientRect;
return integer(c[3]/GetYScrollDelta());
end
function GetClientXCount();virtual; //宽度间隔
begin
return FMaxItemWidth;
end
function GetClientYCount();virtual; //高度项
begin
return FItemCount-1;
end
function GetXScrollDelta();override;
begin
return FFontWidth;
end
function GetYScrollDelta();override;
begin
return FFontHeight+4;
end
function PositionChanged();virtual;
begin
InvalidateRect(nil,false);
end
private
function PaintLines(FirstLine,LastLine);
begin
cvs := Canvas;
for i := FirstLine to LastLine do
begin
rc := GetIdxRect(i);
PaintIdx(i,rc,cvs);
end
end
public
function Create(AOwner);override;
begin
inherited;
FMaxItemWidth := 1;
FItemCount := 0;
FFontHeight := font.Height;
FFontWidth := font.Width;
left := 0;
top := 0;
height := 100;
width := 125;
autoscroll := 1;
ThumbTrack := true;
FScroolChanged := false;
Border := true;
//bordercolor := rgb(130,135,144);
end
function ncpaint(rec);override;
begin
dc := Canvas;
ls := array((0,0),(rec[2]-rec[0]-1,0),(rec[2]-rec[0]-1,rec[3]-rec[1]-1),(0,rec[3]-rec[1]-1),(0,0));
dc.pen.color := rgb(130,135,144);
dc.draw("polyline",ls);
end
function UpDateScrollBar(); //滚动条改变
begin
DoControlAlign();
end
function IncPaintLock(); //锁定刷新
begin
BeginUpdate();
end
function DecPaintLock(); //释放刷新
begin
EndUpdate();
end
function DoEndUpDate();override; //锁定刷新释放
begin
if not(IsUpDating())then
begin
if FScroolChanged then
begin
FScroolChanged := false;
return UpDateScrollBar();
end
end
inherited;
end
function paint();override;
begin
xpos := GetXpos();
ypos := GetYPos();
// 计算需要重绘的区域
ps := PAINTSTRUCT().rcPaint;
c := ClientRect;
tp := max(ps[1],c[1]);
bo := min(ps[3],c[3]);
FirstLine := integer(max(0,yPos+(tp)/GetYScrollDelta()));
LastLine := integer(min(FItemCount-1,yPos+(bo)/GetYScrollDelta()));
cvs := Canvas;
cvs.Font := font;
PaintLines(FirstLine,LastLine);
end
function MouseUp(o,e);override;
begin
if e.Button()=mbLeft then
begin
CallMessgeFunction(onclick,o,e);
e.skip := true;
end
end
function MouseDown(o,e);override;
begin
if e.Button()=mbLeft and e.shiftdouble()then
begin
CallMessgeFunction(ondblclick,o,e);
e.skip := true;
end
end
function PaintIdx(idx,rc,cvs);virtual;
begin
{**
@explan(说明)绘制项 %%
@param(idx)(integer) 序号%%
@param(rc)(array) 绘制区域%%
@param(cvs)(tcustomcanvas) 画布 %%
**}
end
function InvalidateIdxRect(idx,cnt);virtual;
begin
if idx >= 0 and idx<FItemCount then
begin
if not(cnt >= 1)then cnt := 1;
rc := ClientRect;
y := GetYPos();
dy := GetYScrollDelta();
idxtop :=(idx-y) * dy;
if idxtop >= rc[3]then
begin
return;
end
if(idxtop+cnt * dy)<= 0 then
begin
return;
end
rc[1]:= idxtop;
rc[3]:= min(rc[3],idxtop+cnt * dy);
InvalidateRect(rc,false);
end
end
function GetIdxByYpos(y);virtual;
begin
py := GetYPos();
r := integer(y/GetYScrollDelta())+py;
if r >= FItemCount then return -1;
return r;
end
function GetIdxRect(idx);virtual;
begin
{**
@explan(说明)通过序号获得项绘制区域 %%
@param(idx)(integer) 项序号 %%
@return(array) array(左上右下) %%
**}
if idx >= 0 then
begin
rc := ClientRect;
yp := GetYPos();
xp := GetXpos();
DY := GetYScrollDelta();
rc[1]:=(idx-yp) * DY;
rc[0]:=(0-xp) * GetXScrollDelta()+rc[0];
rc[3]:= rc[1]+DY;
return rc;
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
{**
@explan(说明)确保指定项在区域中 %%
@param(idx)(integer) 项序号 %%
**}
rc := GetIdxRect(idx);
c := ClientRect;
if rc[1]<c[1]then
begin
SetYpos(-1+GetYPos()+(rc[1]-c[1])/GetYScrollDelta());
end else
if rc[3]>c[3]then
begin
SetYpos(1+GetYPos()+(rc[3]-c[3]+1)/GetYScrollDelta());
end
end
function GetClientIdxs();virtual;
begin
{**
@explan(说明)获得客户区项的序号 %%
@return(array) 序号数组 %%
**}
rc := ClientRect;
r := GetRectIdxs(rc);
return r[0]-> r[1];
end
function doControlALign();override;
begin
if(IsUpDating())then
begin
FScroolChanged := true;
end else
begin
FMaxItemWidth := GetMaxItemWidth();
InitialScroll();
end
end
function EnsureIdxVisible(idx);
begin
if idx >= FItemCount then idx := FItemCount-1;
if not(idx >= 0)then return;
rc := ClientRect;
idxs := GetRectIdxs(rc);
if idx <= idxs[0]then
begin
SetYpos(idx);
end else
if idx >= idxs[1]then
begin
ndx := integer((rc[3]-rc[1])/GetYScrollDelta());
SetYpos(idx-ndx);
end
end
function AdjustSize();override;
begin
if not HandleAllocated() then return ;
UpDateScrollBar();
class(TWinControl).AdjustSize();
end
function FontChanged(o);override;
begin
ft := Font;
if not ft then return ;
wd := ft.width;
h := ft.Height;
if h <> FFontHeight or wd <> FFontWidth then
begin
FFontHeight := h;
FFontWidth := wd;
end
inherited;
end
function GetItemCount();virtual;
begin
return FItemCount;
end
published
property ItemCount read GetItemCount write SetItemCount;
property ItemHeight read GetYScrollDelta;
{**
@param(ItemCount)(integer) 项数量 %%
**}
protected
function SetItemCount(n);
begin
if not(n >= 0)then return;
nn := integer(n);
if nn <> FItemCount then
begin
FItemCount := nn;
UpDateScrollBar();
end
end
private
FFontHeight;
FFontWidth;
FScroolChanged; //滚动条修改
function GetRectIdxs(rc);
begin
yp := GetYPos();
tp := rc[1];
bo := rc[3];
FirstLine := integer(tp/GetYScrollDelta())+yp;
LastLine := integer((bo)/GetYScrollDelta())+yp;
return array(FirstLine,LastLine);
end
function GetMaxItemWidth();virtual;
begin
return 1;
end
end
type tlistdrawevent = class(tuieventbase)
{**
@explan(说明)列表绘制消息对象 %%
@param(id)(integer) 序号 %%
@param(rec)(array(左上右下)) 区域 %%
@param(sel)(bool) 选择状态 %%
@param(canvas)(TCanvas) 画布 %%
**}
function create(i,s,r,c);
begin
inherited create(0,0,0,0);
idx := i;
sel := s;
rec := r;
Canvas := c;
end
rec;
idx;
sel;
canvas;
end
type TcustomListBox=class(TCustomListBoxbase)
{**
@explan(说明) listbox控件 %%
**}
private
FListitemheigt;
protected
function GetYScrollDelta();override;
begin
if ownerdraw and FListitemheigt>0 then
begin
return FListitemheigt;
end else return inherited;
end
public
function Create(AOwner);override;
begin
inherited;
FOwnerDraw := false;
FListitemheigt := font.Height+4;
border := true;
FitemData := new tnumindexarray();
FSelBegin :=-1;
FSelEnd :=-1;
FMultisel := false;
fcheckbox := false;
fselbkcolor := 0xFFE7CB;
end
function FontChanged(o);override;
begin
ft := font;
if ft then
begin
if not fownerdraw then setItemHeight( font.Height+4);
return inherited;
end
end
function MouseUp(o,e);override;
begin
if FIsMouseDown then //已经按下过
begin
_wapi.clipcursor(ps); //解锁光标
FIsMouseDown := false;
selchange := 0;
case FMultisel of
0:
begin
selchange := FFormerSelBegin <> FSelBegin;
end
1:
begin
selchange :=((FFormerSelBegin <> FSelBegin)or(FFormerSelEnd <> FSelEnd))and((FFormerSelBegin <> FSelEnd)or(FFormerSelEnd <> FSelBegin));
end
2:
begin
selchange := 1;
end
end;
if selchange then calllistselchengd();
end
inherited;
end
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;
FFormerSelEnd := FSelEnd;
idx := GetIdxByYpos(e.ypos);
IncPaintLock();
if FMultisel=2 then
begin
if FMultisel3Data[idx]then Reindex(FMultisel3Data,array(idx:nil));
else FMultisel3Data[idx]:= not FMultisel3Data[idx];
InvalidateIdxRect(idx);
end else
if idx <> FSelBegin and idx <> FSelEnd then
begin
SelRange(false);
FSelBegin := FSelEnd := idx;
SelRange(true);
end
DecPaintLock();
FIsMouseDown := true;
crect := ClientRect;
ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3]));
_wapi.clipcursor(ps);
end else
FIsMouseDown := false;
inherited;
end
function MouseMove(o,e);override;
begin
if FIsMouseDown then
begin
rc := ClientRect;
y := e.ypos;
dy := GetYScrollDelta();
if y>rc[3]-4 then
begin
y += dy;
end else
if y<4 then
begin
y -= dy;
end
idx := GetIdxByYpos(y);
if idx<0 then return;
if FMultisel=2 then
begin
end else
if idx <> FSelEnd then
begin
IncPaintLock();
SelRange(false);
if FMultisel=1 then FSelEnd := idx;
else
begin
FSelBegin := FSelEnd := idx;
end
SelRange(true);
DecPaintLock();
end
EnsureIdxVisible(idx);
end
end
function PaintIdx(idx,rc,cvs);virtual;
begin
{**
@explan(说明)绘制项 %%
@param(item)(TCustomListItem) 项 %%
@param(rc)(array) 绘制区域%%
@param(cvs)(tcustomcanvas) 画布 %%
**}
r := PaintIdxBkg(idx,rc,cvs);
rc1 := rc;
rc1[4]:=r;
if fcheckbox then
begin
h := rc[3]-rc[1];
nh := min(h,16);
nnh := integer((h-nh)/2);
rc2 := array(rc[0]+2,rc[1]+nnh,rc[0]+nh+2,rc[3]-nnh);
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);
end
function PaintIdexText(idx,rc,cvs);virtual;
begin
if fownerdraw and Fondrawlist then
begin
e := new tlistdrawevent(idx,rc[4],rc,cvs);
CallMessgeFunction(Fondrawlist,self(true),e);
return ;
end
cvs.DrawText(getItemText(idx),rc,DT_NOPREFIX);
end
function getCurrentSelection();virtual;
begin
{**
@explan(说明)获取当前选中项的索引，仅用于单选的列表框%%
**}
case FMultisel of
0: //单选
begin
return FSelBegin;
end
1: //连续选择
begin
return array(FSelBegin,FSelEnd);
end
2: //间断选择
begin
r := array();
rl := 0;
for i,v in FMultisel3Data do
begin
if v then
begin
r[rl] := i;
rl++;
end
end
return r;
end
end
return -1;
end
function setCurrentSelection(n);virtual;
begin
{**
@explan(说明)设置当前选中项的索引，仅用于单选的列表框%%
@param(n)(integer)%%
**}
if FMultisel=1 then
begin
flg := false;
if isValidIndex(n)then
begin
if FSelBegin=n then return ;
FSelBegin := FSelEnd := n;
flg := true;
end else
if ifarray(n) and isValidIndex(n[1])and isValidIndex(n[0])then
begin
n1 := MinValue(n);
n2 := MaxValue(n);
if n1<>FSelBegin or n2<>FSelEnd then
begin
FSelBegin := n1;
FSelEnd := n2;
flg := true;
end
end
if flg then
begin
InvalidateRect(nil,false);
calllistselchengd();
end
return;
end else
if FMultisel=2 then
begin
FMultisel3Data2 := array();
if isValidIndex(n)then
begin
FMultisel3Data2[n]:= true;
end else
if ifarray(n)then
begin
for i,v in n do
begin
if isValidIndex(v)then
begin
FMultisel3Data2[v]:= true;
end
end
end
if FMultisel3Data2<>FMultisel3Data then
begin
FMultisel3Data := FMultisel3Data2;
InvalidateRect(nil,false);
calllistselchengd();
end
return;
end
if not(isValidIndex2(n)) or n=FSelBegin then return;
SelRange(false);
FSelBegin := FSelEnd := n;
SelRange(true);
//SetYpos(n);
InsureIdxInClient(n);
calllistselchengd();
end
function getItemSelectedState(n);
begin
{**
@explan(说明)获取指定项的选中状态%%
@param(n)(integer)指定项下标%%
@return(bool)是否被选中%%
**}
if not isValidIndex(n)then return nil;
case FMultisel of
0:
begin
return n=FSelBegin;
end
1:
begin
if FSelBegin <= FSelEnd then return n >= FSelBegin and n <= FSelEnd;
return n >= FSelEnd and n <= FSelBegin;
end
2:
begin
return FMultisel3Data[n]=1;
end
end
return nil;
end
function setItemSelectedState(n,state);
begin
{**
@explan(说明)设置指定项选中状态，仅用于非连续多选的列表框%%
@param(n)(integer)指定项索引%%
@param(state)(bool)状态%%
**}
b := state?1:0;
if (FMultisel <> 2) or not(isValidIndex(n)) or (b=getItemSelectedState(n)) then return;
if b then FMultisel3Data[n]:= b;
else
begin
reindex(FMultisel3Data,array(n:nil));
end
calllistselchengd();
InvalidateIdxRect(n);
end
function appendItem(item);virtual;
begin
{**
@explan(说明)在列表框最后添加一个项%%
@param(item)(string)要添加的字符串%%
@return(integer)所添加项在列表框中的索引%%
**}
if CheckListItem(item)then
begin
FitemData.Push(item);
class(TCustomListBoxbase).ItemCount := FitemData.length();
return ItemCount-1;
end
return -1;
end
function appendItems(ari);virtual;
begin
{**
@explan(说明)在列表框最后添加多个项%%
@param(ari)(array)要添加的字符串组成的数组%%
@return(integer)所添加的最后一项在列表框中的索引%%
**}
if CheckListItems(ari)then
begin
FitemData.Pushs(ari);
inherited SetItemCount(FitemData.length());
//class(TCustomListBoxbase).ItemCount := ;
return ItemCount-1;
end
return -1;
end
function insertItem(item,n);virtual;
begin
{**
@explan(说明)在指定索引处插入一项%%
@param(item)(string)插入的字符串%%
@param(n)(integer)指定下标索引%%
@return(integer)返回插入的字符串的下标，出错则返回-1%%
**}
if ifnil(n)then return appendItem(item);
if FitemData.Length()<1 then return appendItem(item);
if isValidIndex(n)and CheckListItem(item)then
begin
SelectedChangeSwitch(n,1,1);
FitemData.splice(n,0,item);
class(TCustomListBoxbase).ItemCount := FitemData.length();
return n;
end
return -1;
end
function insertItems(ari,n);virtual;
begin
{**
@explan(说明)在指定索引处插入多个项，将该函数用于多选列表框将会导致所有选择项丢失%%
@param(ari)(array of string)插入项组成的数组%%
@param(n)(integer)指定下标索引，缺省则插至末尾%%
@return(integer)返回插入的最后的字符串的下标，出错则返回-1%%
**}
if ifnil(n)then return appendItems(ari);
if FitemData.Length()<1 then return appendItems(item);
if CheckListItems(ari)and isValidIndex(n)then
begin
SelectedChangeSwitch(n,length(ari),1);
FitemData.splices(n,0,ari);
class(TCustomListBoxbase).ItemCount := FitemData.length();
return n+length(ari)-1;
end else
return -1;
end
function deleteItem(n);override;
begin
{**
@explan(说明)删除指定的合法下标索引的项%%
@param(n)(integer)指定项下标索引%%
@return(integer)剩余的项的数量，出错则返回-1%%
**}
if not isValidIndex(n)then return-1;
SelectedChangeSwitch(n,1,0);
FitemData.splice(n,1);
class(TCustomListBoxbase).ItemCount := FitemData.length();
return FitemData.Length();
end
function deleteItems(n,cnt);
begin
{**
@explan(说明)删除指定的合法下标处开始多个项%%
@param(n)(integer)指定项下标索引%%
@param(cnt)(integer)删除项数，当删除的项超过尾项时，删至尾项%%
@return(integer)剩余的项的数量，出错则返回-1%%
**}
if not isValidIndex(n)or cnt <= 0 then return-1;
SelectedChangeSwitch(n,cnt,0);
FitemData.splice(n,cnt);
class(TCustomListBoxbase).ItemCount := FitemData.length();
return FitemData.Length();
end
function DeleteSelectedItems();
begin
{**
@explan(说明) 删除选中的项目 %%
**}
if FMultisel=2 then
begin
if FMultisel3Data then
begin
r := array();
ri := 0;
for i := 0 to FitemData.length()-1 do if not FMultisel3Data[i]then r[ri++]:= FitemData[i];
setdata(r);
end
end else
begin
if FSelBegin >= 0 and FSelEnd >= FSelBegin then deleteItems(const FSelBegin,FSelEnd-FSelBegin+1);
end
end
function setData(ari);virtual;
begin
IncPaintLock();
Clean();
AppendItems(ari);
DecPaintLock();
end
function getSelectedIndexes();virtual;
begin
{**
@explan(说明)获取列表框内当前选中项的索引组成的数组%%
@return(array)当未选中任何项时，返回空数组%%
**}
r := array();
case FMultisel of
0:
begin
return FSelBegin=-1?r:array(FSelBegin);
end
1:
begin
if FSelBegin<0 then return r;
if FSelBegin <= FSelEnd then return FSelBegin -> FSelEnd;
else return FSelEnd -> FSelBegin;
end
2:
begin
ri := 0;
for i,v in FMultisel3Data do r[ri++]:= i;
return r;
end
end
end
function getItem(n);
begin
{**
@explan(说明)获取指定项%%
@param(n)(integer)指定项下标%%
@return()指定项%%
**}
return FitemData[n];
end
function getItemText(i);virtual;
begin
{**
@explan(说明) 获得item的文本 %%
@param(i)(integer) 序号 %%
@return(string) 项显示字符串 %%
**}
r := FitemData[i];
if ifstring(r)then return r;
return "";
end
function clean();virtual;
begin
//FitemData.splice(0,FitemData.Length());
FitemData := new tnumindexarray();
cleanAllSelectedState();
class(TCustomListBoxbase).ItemCount := 0;
end
function Recycling();override;
begin
FselectionChange := nil;
Fondrawlist := nil;
return inherited;
end
published
property ItemHeight:integer read GetYScrollDelta write setItemHeight;
property ItemCount:integer read GetItemCount write SetItemCount;
property Multisel:listseltype read FMultisel write SetMultisel;
property checkbox:bool read fcheckbox write setcheckbox;
property onSelectionChange read FselectionChange write FselectionChange;
property selbkcolor:color read fselbkcolor write setselbkcolor;
property onSelchanged:eventhandler read FselectionChange write FselectionChange;
property ondrawlist:eventhandler read Fondrawlist write Fondrawlist;
property Items:strings read GetData write setData;
property itemindex:tsl read getCurrentSelection write setCurrentSelection;
property ownerdraw:bool read fownerdraw write setownerdraw;
protected
function CheckListItems(s);
begin
if ifarray(s) then
begin
if ((thisfunction(class(TcustomListBox).checklistitem))<>(thisfunction(self.checklistitem))) then
begin
for i,v in s do if not CheckListItem(v) then return 0;
end
return 1;
end
return 0;
end
function CheckListItem(s);virtual;
begin
{**
@explan(说明) 项检查,重写该方法可以控制项的类型 %%
**}
return true;
//return ifstring(s);
end
function isValidIndex(n);
begin
return(n >= 0)and n<FitemData.length();
end
function isValidIndex2(n);
begin
return(n >= -1)and n<FitemData.length();
end
FitemData;
{**
@explan(说明)(TMyarrayB) list数据数据,不要试图修改该变量
**}
private
function setItemHeight(h);
begin
if h>0 and h<>FListitemheigt then
begin
FListitemheigt := integer(h);
if FOwnerDraw then
begin
doControlALign();
InvalidateRect(nil,false);
end
end
end
function setselbkcolor(v);
begin
if (v>=0 or v<0) and v<>fselbkcolor then
begin
fselbkcolor := v;
end
end
function SetItemCount(n);
begin
if fownerdraw and (n>=0) and ItemCount<>n then
begin
d := nils(n);
setData(d);
end
end
function setownerdraw(v);
begin
nv := v?true:false;
if FOwnerDraw<>nv then
begin
FOwnerDraw := nv;
if not(FListitemheigt>0) then
begin
FListitemheigt := font.Height+4;
end
end
end
function PaintIdxBkg(idx,rc,cvs);
begin
if(idx >= min(FSelBegin,FSelEnd)and idx <= max(FSelBegin,FSelEnd))or(FMultisel=2 and FMultisel3Data[idx])then
begin
r := true;
if fselbkcolor<>Color then
begin
cvs.brush.Color := fselbkcolor;//0xFFE7CB;//rgb(204,231,255);
cvs.FillRect(rc);
end
end
return r;
end
function setcheckbox(c);
begin
if c<>fcheckbox and (c in array(0,1,2)) then
begin
fcheckbox := c;
InvalidateRect(nil,false);
end
end
function SetMultisel(n);
begin
if n <> FMultisel and(n in array(0,1,2))then
begin
SelRange(false);
FSelBegin := FSelEnd :=-1;
if n=2 then
begin
FMultisel3Data := array();
end
FMultisel := n;
end
end
function GetData();
begin
return FitemData.Data;
end
function SelRange(sel);
begin
if FSelBegin >= 0 and FSelEnd >= 0 then
begin
InvalidateIdxRect(min(FSelBegin,FSelEnd),abs(FSelBegin-FSelEnd)+1);
end
end
function SelectedChangeSwitch(idx,cnt,isAdd);
begin
case FMultisel of
0:
begin
SelectedChange(idx,cnt,isAdd);
end
1:
begin
cleanAllSelectedState();
end
2:
begin
MultiSelectedChange(idx,cnt,isAdd);
end
end;
end
function SelectedChange(idx,cnt,isAdd);
begin
//单选列表框在列表框项数增加或者删除时处理选中项的变动
//idx 增删开始处索引
//cnt 元素数量
//isAdd 1：添加，0：删除
if FSelBegin<idx then return;
selchange := 0;
if isAdd then
begin
t := FSelBegin+cnt;
end else
begin
if FSelBegin >= idx+cnt then t := FSelBegin-cnt;
else
begin
t :=-1;
selchange := 1;
end
end
FSelBegin := FSelEnd := t;
if selchange then calllistselchengd();
end
function MultiSelectedChange(idx,cnt,isAdd);
begin
//非连续的多选类型在列表框项数增加或者删除时处理选中项的变动
//idx 增删开始处索引
//cnt 元素数量
//isAdd 1：添加，0：删除
d := array();
if isAdd then
begin
for i,v in FMultisel3Data do if v then d[i >= idx?i+cnt:i]:= 1;
end else
begin
selchange := 0;
back := idx+cnt;
for i,v in FMultisel3Data do if v then
begin
if i<idx then d[i]:= 1;
else if i >= back then d[i-cnt]:= 1;
else selchange := 1;
end
end
FMultisel3Data := d;
if selchange then calllistselchengd();
end
function cleanAllSelectedState();
begin
selchange := 0;
if FMultisel=2 then
begin
for i,v in FMultisel3Data do if v then selchange := 1;
FMultisel3Data := array();
end else
begin
if FSelBegin <>-1 then selchange := 1;
FSelBegin := FSelEnd :=-1;
FFormerSelBegin := FFormerSelEnd :=-1;
end
if selchange then calllistselchengd();
end
function calllistselchengd();
begin
if FselectionChange then CallMessgeFunction(FselectionChange,self(true),new tuieventbase(0,0,0,0));
end
private
fselbkcolor;
FOwnerDraw;
// FselectionCancel;
[weakref]FselectionChange;
[weakref]Fondrawlist;
FSelBegin;
FSelEnd;
FIsMouseDown;
FMultisel;
fcheckbox;
FMultisel3Data;
FFormerSelBegin;
FFormerSelEnd;
end
type TCustomComboBoxbase=class(TCustomControl)
{**
@explan(说明) combox 基类 %%
**}
function Create(AOwner);override;
begin
inherited;
end
function AfterConstruction();override;
begin
inherited;
FBtnWidth := 20;
FmaxListItemShow := 10;
//FScreenRect := _wapi.GetScreenRect();
FListBox := CreateAlist();
if FListBox is class(TWinControl)then
begin
FListBox.OnClose := function(o,e)
begin
e.skip := true;
o.Visible := false;
end
end
SetBoundsRect(array(0,0,100,23));
end
function CreateAlist();virtual;
begin
{**
@expaln(说明) 构造一个弹出框 %%
@return(twincontrol) 弹出窗口 %%
**}
return "";
end
function GetPreferredSize(w,h);override;
begin
class(tcontrol).GetPreferredSize(w,h);
w := Width;
end
function Paint();override;
begin
rc := ClientRect;
FBtnRect := rc;
dc := canvas;
FBtnRect[0]:= FBtnRect[2]-FBtnWidth;
dc.Draw("framecontrol",array(FBtnRect[0:1],FBtnRect[2:3]),DFC_SCROLL,1);
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return;
x := e.xpos;
y := e.ypos;
//if x>1 and y>1 then return ShowDropDown(true);
if x>FBtnRect[0]and x<FBtnRect[2]and y>FBtnRect[1]and y<FBtnRect[3]then
begin
return ShowDropDown(true);
end
return ;
end
function ShowDropDown(flg);
begin
{**
@explan(说明)展开或者关闭下拉框%%
@param(f)(bool)true 展开 false 关闭%%
**}
if not((FListBox is class(TWincontrol))and FListBox.WsPopUp)then return;
if flg and not(FListBox.Visible)then
begin
if Fondropdown then
begin
e := new tuieventbase(0,0,0,0);
CallMessgeFunction(Fondropdown,self(true),e);
end
SetListBoxRect();
FListBox.OnActivate := thisfunction(ListActivate);
FListBox.show(5);
end else
if not(flg) and FListBox.Visible then
begin
if Foncloseup then
begin
e := new tuieventbase(0,0,0,0);
CallMessgeFunction(Foncloseup,self(true),e);
end
FListBox.Visible := false;
end
end
function Recycling();override;
begin
FListBox := nil;
FOnSelchanged := nil;
Foncloseup := nil;
Fondropdown := nil;
inherited;
end
published
property itemcount read GetItemCount ;
property ItemIndex:lazytsl read GetItemIndex write SetItemIndex;
property OnSelchanged:eventhandler read FOnSelchanged write FOnSelchanged;
property ondropdown:eventhandler read Fondropdown write Fondropdown;
property oncloseup:eventhandler read Foncloseup write Foncloseup;
property BtnWidth read FBtnWidth write SetBtnWidth;
property dropdowncount:integer read FmaxListItemShow write SetmaxListItemShow;
{**
@param(ItemIndex)(integer)设置当前项序号%%
@param(dropdowncount)(integer)下拉列表项数%%
@param(ondropdown)(function[tcomboBox,tuieventbase])下拉框展开回调%%
@param(oncloseup)(function[tcomboBox,tuieventbase])下拉框关闭回调%%
@param(onselchanged)(function[tcomboBox,tuieventbase])当前选项改变回调%%
@param(FListBox)(twinControl) 弹出框 %%
**}
function ListActivate(o,e);
begin
if o.visible and e.wparam=0 then
begin
ShowDropDown(false);
end
end
protected
function SetListBoxRect();virtual;
begin
{**
@explan(说明) 设置弹出框的显示区域 %%
**}
if not(FListBox is class(TWinControl))then return;
rc := ClientRect;
h := getlistitemheight()* (min(max(0,getlistitemcount()),FmaxListItemShow))+10;
FListbox.height := h;
nrc := ClientToScreen(rc[0],rc[3]);
src := _wapi.GetScreenRect(nrc);
p2 := clienttoscreen(rc[0],rc[1]+h);
if src[3]<p2[1] then
begin
nrc := ClientToScreen(rc[0],rc[1]-h);
end
FListBox.Width := Width;
FListBox.left := nrc[0];
FListBox.top := nrc[1];
end
FListBox;
private
FmaxListItemShow;
//FScreenRect; //桌面区域
FBtnRect; //按钮区域
weakref
FOnSelchanged; //选择改变
Fondropdown; //下拉
Foncloseup; //收起
autoref
FBtnWidth;
function GetItemCount();
begin
if not FListBox then return 0;
return FListBox.ItemCount;
end
function SetmaxListItemShow(v);//显示项目数量
begin
if v>0 then
begin
nv := integer(v);
if nv <> FmaxListItemShow then
begin
FmaxListItemShow := nv;
end
end
end
function SetBtnWidth(n);//按钮宽度
begin
if not(n>10 and n<100)then return;
nn := int(n);
if nn <> FBtnWidth then
begin
SetBtnWidth := nn;
InValidateRect(nil,false);
DoControlAlign();
end
end
function getlistitemcount();virtual; //获得项目
begin
return 5;
end
function getlistitemheight();virtual; //获得项目高
begin
return 20;
end
function GetItemIndex();virtual;//获得选中的序号
begin
return -1;
end
function SetItemIndex();virtual;//设置选中的序号
begin
end
end
type TcustomComboBox=class(TCustomComboBoxbase)
{**
@explan(说明) comboBox下拉框 %%
**}
private
type TComboListBox=class(TcustomListBox)
function Create(AOwner);
begin
inherited;
caption := "combox list box";
end
function MouseUp(o,e);override;
begin
inherited;
visible := false;
end
end
protected
function SetEnabled(v);override;
begin
inherited;
if FEdit then FEdit.Enabled := v;
end
public
function create(AOwner);override;
begin
inherited;
fmultisel := false;
fcheckbox := false;
FEdit := new TcustomEdit(self);
FEdit.OnKeyDown := function(o,e)
begin
if FMultisel then return ;
case e.charcode of
VK_UP:
begin
ItemIndex -= 1;
e.skip := true;
end
VK_DOWN:
begin
ItemIndex += 1;
e.skip := true;
end
end;
end
FEdit.onchange := function(o,e);
begin
if feditischanging then return feditischanging := false;
if not(o.Readonly) then
begin
feditischanging := true;
if Foneditchanged then
CallMessgeFunction(Foneditchanged,o,e);
if FMultisel then return feditischanging:=false;
t := o.Text;
if t = getCurrentItemText() then return feditischanging:=false;
for i,v in items do
begin
if t = v then
begin
ItemIndex := i;
feditischanging := false;
return ;
end
end
ItemIndex := -1;
feditischanging := false;
end
end
FEdit.onupdate := function(o,e);
begin
if not(o.Readonly) then
begin
CallMessgeFunction(FoneditUpdate,o,e);
end
end
Freadonly := true;
FListBox.Border := true;
FListBox.Visible := false;
FListBox.WsPopUp := true;
FListBox.onselchanged := function(o,e);
begin
if feditischanging then return ;
r := getCurrentItemText();
feditischanging := true;
FEdit.Text := r;
feditischanging := false;
ShowDropDown(false);
CallMessgeFunction(OnSelchanged,self(true),e);
end
FEdit.onmousedown := function(o,e)begin
if Freadonly then
begin
e.skip := true;
ShowDropDown(true);
end
end
FEdit.Readonly := Freadonly;
FListBox.parent := self;
FEdit.parent := self;
FEdit.ParentFont := true;
end
function CreateAlist();override;
begin
r := new TComboListBox(self);
r.ParentFont := true;
return r;
end
function SetDesigning(Value,SetChildren);override;
begin
inherited;
if FEdit then FEdit.Enabled := not Value;
end
function DoControlAlign();override;
begin
rc := ClientRect;
rc[2]-= 20;
FEdit.SetBoundsRect(rc);
end
function appendItem(str);virtual;
begin
{**
@explan(说明)添加子项数据%%
@param(str)(string) 子项字符串%%
**}
FListBox.appendItem(str);
end
function AppendItems(arr);virtual;
begin
{**
@explan(说明)添加子项数据%%
@param(arr)(array of string) 子项字符串数组%%
**}
FListBox.appendItems(arr);
end
function insertItem(str,i);virtual;
begin
{**
@explan(说明)插入子项 %%
@param(str)(string) 显示标题 %%
@param(i)(integer) 在i前插入子项 %%
**}
FListBox.insertItem(str,i);
end
function deleteItem(i);virtual;
begin
{**
@explan(说明)删除子项 %%
@param(i)(integer) 删除子项的位置 %%
**}
FListBox.deleteItem(i);
end
function clean()
begin
{**
@explan(说明)清空数据 %%
**}
FListBox.Clean();
end
function getitems();
begin
{**
@explan(说明)获得所有数据 %%
@return(array of string) 字符串项 %%
**}
return FListBox.items();
end
function GetItem(n);
begin
return FListBox.GetItem(n);
end
function getItemCount();
begin
{**
@explan(说明)统计子项个数 %%
@return(integer)子项个数 %%
**}
//return _send_(CB_GETCOUNT,0,0);
return FListBox.ItemCount;
end
function getItemText(i);
begin
{**
@explan(说明)获取第i个子项的内容 %%
@param(i)(integer) 子项的位置 %%
@return(string) 子项标题 %%
**}
return FListBox.getItemText(i);
end
function getCurrentItemText();
begin
{**
@explan(说明)获取选中的子项字符串 %%
@return(string) 子项字符串 %%
**}
idx := FListBox.GetCurrentSelection();
if FMultisel then
begin
r := "";
for i,v in idx do
begin
r+=getItemText(v)+";";
end
if r then r[length(r):]:="";
return r;
end
return getItemText(idx);
end
published
property readonly:bool read Freadonly write setReadOnly;
property Multisel:bool read fmultisel write setMultisel;
property checkbox:bool read fcheckbox write setcheckbox;
property textheight read FTextHeight Write FTextHeight;
property itemheight read FItemHeight write FItemHeight;
property items:strings read Getitems write setItems;
property oneditchanged:eventhandler read Foneditchanged write Foneditchanged;
property onEditUpdate:eventhandler read FoneditUpdate write FoneditUpdate;
property onkillfocus read Fonkillfocus write Fonkillfocus;
property onsetfocus read Fonsetfocus write Fonsetfocus;
property Editer read FEdit;
{**
@param(oneditchanged)(function[tcomboBox,tuieventbase])文本被改变回调,文本显示后调用%%
**}
private
function setMultisel(v);
begin
nv := v?true:false;
if nv<>FMultisel then
begin
FMultisel := nv;
if not FListBox then return ;
if FMultisel then
begin
FListBox.Multisel := 2;
end else
begin
FListBox.Multisel := 0;
end
end
end
function setcheckbox(v);
begin
nv := v?true:false;
if nv<>fcheckbox then
begin
fcheckbox := nv;
if FListBox then
FListBox.checkbox := nv;
end
end
function setReadOnly(v);
begin
nv := v?true:false;
if nv <> Freadonly then
begin
Freadonly := nv;
FEdit.Readonly := nv;
end
end
function getlistitemcount();override; //获得项目
begin
if FListBox then
return FListBox.ItemCount;
end
function getlistitemheight();override; //获得项目高
begin
if FListBox then
return FListBox.ItemHeight;
end
function GetItemIndex();override;
begin
//if FMultisel and (csDesigning in ComponentState) then return -1;
if FListBox then
return FListBox.GetCurrentSelection();
return -1;
end
function SetItemIndex(idx);override;
begin
//if FMultisel and (csDesigning in ComponentState) then return -1;
if FListBox then
return FListBox.SetCurrentSelection(idx);
end
feditischanging;//改变正在回调
fmultisel;
fcheckbox;
FTextHeight;
FItemHeight;
Freadonly;
weakref
Foneditchanged;
FoneditUpdate;
Fonkillfocus;
Fonsetfocus;
autoref
FEdit;
function setItems(d);
begin
if FListBox then
return FListBox.SetData(d);
end
end
type tcustommenubutton = class()//菜单按钮
function create(mu,tb);
begin
fmenu := mu;
fParent := tb;
end
function DoOnClick(o,e); //点击
begin
if fParent.HandleAllocated() and (fmenu is class(TcustomMenu)) then
begin
if fmenu.ItemCount>0 then //弹出菜单处理
begin
fParent.PopupMenu := fmenu;
rec := GetRect();
xy := fParent.clienttoscreen(rec[0],rec[3]);
uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON;
fParent._wapi.TrackPopupMenu(fmenu.Handle,uf,xy[0],xy[1],0,fParent.Handle,nil);
return ;
end //图片点击处理
CallMessgeFunction(fmenu.OnClick,fmenu,e);
end
end
function GetRect();
begin
return fParent.GetItemRect(self);
end
property menu read fmenu;
property Enabled read GetEnabled;
property visible read getvisible;
property caption read getcaption;
private
function GetEnabled();
begin
return fmenu.Enabled;
end
function getcaption();
begin
return fmenu.Caption;
end
function getvisible(); //可见
begin
return true;
end
fmenu;
[weakref]fParent;
end
type TcustomToolButton=class(tcomponent)
{**
@explan(说明) 工具栏项 %%
**}
function Create(AOwner);override;
begin
inherited;
FCaption := "toolbtn"; //标题
FImageId :=-1; //imageid
FEnabled := true; //有效 可以点击
FVisible := true; //可见
end
function ExecuteCommand(cmd,d);override;
begin
if cmd="doshortcut" then //shortcut
begin
if fstyle=2 then return ;
if csDesigning in ComponentState then return;
if Enabled and Visible then
begin
if d=ShortCut then
begin
DoOnClick(self(true),new tuieventbase(0,0,0,0));
return "havedoshortcut";
end
end
end
end
function DoOnClick(o,e);virtual;
begin
if fStyle=2 then return ;
if Parent then
begin
if FPopupMenu is class({TcustomPopupmenu}TcustomMenu) then
begin
Parent.PopupMenu := FPopupMenu;
rec := GetRect();
xy := Parent.clienttoscreen(rec[0],rec[3]);
uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON;
_wapi.TrackPopupMenu(FPopupMenu.Handle,uf,xy[0],xy[1],0,Parent.Handle,nil);
return ;
end
end
if action and action.Execute()then
begin
end else
CallMessgeFunction(OnClick,o,e);
end
function GetRect();
begin
{**
@explan(说明) 获得区域%%
@return(array) 区域 %%
**}
if parent and parent.HandleAllocated()then return parent.GetItemRect(self);
end
function Recycling();override;
begin
if FToolbar then
begin
FToolbar.DeleteButton(self(true));
end
if FActionLink is class(TControlActionLink)then
begin
FActionLink.Recycling();
FActionLink := nil;
end
FToolbar := nil;
inherited;
FPopupMenu := nil;
FCaption := ""; //标题
FOnClick := nil; //点击
FImageId :=-1; //imageid
FEnabled := true; //有效 可以点击
FVisible := true; //可见
end
published
property OnClick:eventhandler read FOnClick write FOnClick;
property Caption:string read FCaption write SetCaption;
property ImageId:integer read FImageId write SetImageId;
property Enabled:bool read FEnabled write SetEnabled;
property Visible:bool read FVisible write SetVisible;
property ToolBar read FToolbar write SetParent;
property Parent read FToolbar write SetParent;
property willaddBar read FWillAddbar;
property Action:taction read GetAction write SetAction;
property ShortCut read getShortCut write SetShortCut;
property PopupMenu:tpopupmenu read FPopupMenu write FPopupMenu;
property stylesep:bool read getStylesep write setstylesep;
property style read fstyle write setstyle;
{**
@param(OnClick)(function[o:TToolButton;e:tuieventbase]) 点击消息 %%
@param(Caption)(string) 标题 %%
@param(ImageId)(integer) 图标id %%
@param(Enabled)(bool) 是否有效 %%
@param(Visible)(bool) 是否可见 %%
**}
private
FShortCut;
fStyle;
function setstyle(v);
begin
if not(v in array(0,1,2)) then return ;
if fStyle<>v then
begin
fStyle := v;
if FToolbar then
begin
FToolbar.ExecuteCommand("btnchanged",0);
end
end
end
function getStylesep();
begin
return fstyle=2;
end
function setstylesep(v);
begin
nv := v?true:false;
setstyle(v?2:0);
end
function getShortCut();
begin
return formatshortcut(FShortCut);
end
function SetShortCut(v);
begin
if v and ifstring(v)then
begin
nst := parsershortcutstr(v);
end else
nst := nil;
if nst <> FShortCut then
begin
FShortCut := nst;
end
end
function SetParent(tb);
begin
if FToolbar=tb then return; //相同
if FWillAddbar=tb and tb then
begin
FToolbar := tb;
FWillAddbar := nil;
return;
end
if FToolbar <> tb then
begin
if FToolbar is class(TcustomToolBar)then //删除
begin
FWillAddbar :=-1986;
FToolbar.DeleteButton(self(true));
FWillAddbar := nil;
FToolbar := nil;
end
end
if tb is class(TcustomToolBar)then
begin
FWillAddbar := tb;
tb.AddButton(self(true));
SetParent(tb);
end
FWillAddbar := nil;
end
function SetCaption(s);
begin
if ifstring(s)and s <> FCaption then
begin
FCaption := s;
if fStyle=1 and FToolbar then
begin
FToolbar.ExecuteCommand("btnchanged",0);
end
end
end
function SetEnabled(v);
begin
nv := v?true:false;
if nv <> FEnabled then
begin
FEnabled := nv;
if FToolbar then
begin
FToolbar.ExecuteCommand("btnchanged",0);
end
end
end
function SetVisible(v);
begin
nv := v?true:false;
if nv <> FVisible then
begin
FVisible := nv;
if FToolbar then
begin
FToolbar.ExecuteCommand("btnchanged",0);
end
end
end
protected //action
function SetAction(Value);virtual;
begin
if ifnil(Value)then
begin
if FActionLink then
begin
FActionLink.SetAction(nil);
end
excludestate(FControlStyle,csActionClient);
end else
if Value is class(TBasicAction)then
begin
includestate(FControlStyle,csActionClient);
if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self);
FActionLink.Action := Value;
FActionLink.Onchange := thisfunction(DoActionChange);
ActionChange(Value,csLoading in Value.ComponentState);
Value.FreeNotification(Self);
end
end
procedure DoActionChange(Sender:TObject);
begin
if Sender=Action then ActionChange(Sender,False);
end
function GetAction();virtual;
begin
if FActionLink then
begin
return FActionLink.Action;
end
end
function GetActionLinkClass();virtual;
begin
{**
@explan(说明) 返回actionlinkclass %%
@return(TMenuActionLink class)
**}
return class(TtoolbuttonActionLink);
end
procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual;
begin
if Sender is class(TCustomAction)then
begin
NewAction := Sender;
if(not CheckDefaults)or(Caption='')or(Caption=Name)then Caption := NewAction.Caption;
if(not CheckDefaults)then ShortCut := NewAction.ShortCut;
if(not CheckDefaults)or Enabled then Enabled := NewAction.Enabled;
//if not CheckDefaults or FChecked then Checked := NewAction.Checked;
end;
end
protected
function SetImageId(id);virtual;
begin
if ifnumber(id)and id <> FImageId then
begin
FImageId := id; //刷新一下
if FToolbar then
begin
FToolbar.ExecuteCommand("btnchanged",0);
end
end
end
private
FPopupMenu;//弹出菜单
[weakref]FOnClick; //点击
[weakref]FToolbar; //工具栏
FCaption; //标题
FCommandId; //command id 可以不要
FImageId; //imageid
FEnabled; //有效 可以点击
FVisible; //可见
FWillAddbar;
FActionLink;
end
type TcustomToolBar=class(TCustomControl)
{**
@explan(说明) 工具栏控件 %%
**}
function Create(AOwner);override;
begin
inherited;
end
function AfterConstruction();override;
begin
inherited;
height := 28;
Width := 300;
Align := alTop;
FButtons := new tnumindexarray();
caption := "ToolBar";
FBtnRects := array();
FTipWnd := new TTipWnd(self);
FTipWnd.Parent := self;
FTimer := new TCustomTimer(self);
FTimer.Interval := 200;
FTimer.Ontimer := thisfunction(DoTimerShowTip);
end
function FontChanged(o);override;
begin
if fmainmenu then CalcButtonsRect();
inherited;
end
function GetPreferredSize(w,h);override;
begin
ft := Font;
if not ft then return ;
ftw := ft.Width;
fth := ft.Height;
brec := BoundsRect;
crec := ClientRect;
dw := (brec[2]-brec[0])-(crec[2]-crec[0]);
dh := (brec[3]-brec[1])-(crec[3]-crec[1]);
if fmainmenu then
begin
w := 0;
for i:= 0 to fmenubtns.length()-1 do
begin
mu := getbtnitem(i);
if mu.Visible then
begin
s := mu.Caption;
w +=length(s)*ftw+15;
end
end
w +=dw+2;
w := max(100,w);
h := fth+2+dh;
return ;
end else
begin
imglst := ImageList; //图标
imgw := 28;
imgh := 28;
if imglst is class(TCustomImageList)then
begin
imgw := imglst.Width+4;
imgh := imglst.height+4;
end
ct := 0;
for i := 0 to FButtons.Length()-1 do //调整大小
begin
bi := FButtons[i];
ct +=bi.Visible;
end
w := max(ct,1)*(imgw+1);
h := imgh;
w+=dw;
h+=dh;
return ;
end
end
function MouseDown(o,e);override;
begin
if csDesigning in ComponentState then return;
FShowLoked := true;
if e.Button()=mbLeft then
begin
FMouseDownIdx := PosInBtn(e.pos);
EndShowWnd();
if FMouseDownIdx >= 0 then
begin
if not(getbtnitem(FMouseDownIdx).Enabled)then
begin
FMouseDownIdx :=-1;
return;
end
InvalidateRect(nil,false);
end
end
end
function ContextMenu(o,e);override;
begin
if csDesigning in ComponentState then
begin
return inherited;
end
e.skip := true;
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return;
FShowLoked := false;
if e.Button()=mbLeft then
begin
idx := PosInBtn(e.pos);
if idx >= 0 then
begin
if FMouseDownIdx=idx then
begin
bi := getbtnitem(idx);
bi.DoOnClick(bi,e);
end;
end
end
if FMouseDownIdx >= 0 then
begin
FMouseDownIdx :=-1;
InvalidateRect(nil,false);
end
end
function MouseMove(o,e);override;
begin
if csDesigning in ComponentState then return;
if FTimer.Enabled then return;
idx := PosInBtn(e.pos);
if idx<0 then return;
FShowtimeIndexA := idx;
if fmainmenu then return ;
FTimer.Start();
end
function DoCNALIGN(o,e);override;
begin
case Align of
alTop,alBottom:
begin
bs := UnAlignBounds;
nh := CalcHeightFixWidth(e.width);
dh := nh-(bs[3]-bs[1]);
bs[3]+= dh;
FUnAlignBounds := bs;
end
alLeft,alRight:
begin
bs := UnAlignBounds;
nh := CalcWidthFixHeight(e.height);
dh := nh-(bs[2]-bs[0]);
bs[2]+= dh;
FUnAlignBounds := bs;
end
end
inherited;
end
function DoTimerShowTip(); //定时器
begin
FCurrentPos := array(0,0);
_wapi.getcursorPos(FCurrentPos);
FCurrentPos := ScreenToClient(FCurrentPos[0],FCurrentPos[1]);
idx := PosInBtn(FCurrentPos);
if idx<0 then
begin
EndShowWnd();
FShowLoked := false;
FMouseDownIdx :=-1;
InvalidateRect(nil,false);
return;
end
if FShowLoked then return;
if FShowTimeIndexA=idx then //依然存在
begin
if not FTipWnd.Visible then
begin
bt := FButtons[idx];
st := bt.ShortCut;
if bt.PopupMenu is class({TcustomPopupmenu}TcustomMenu) then s1 := bt.PopupMenu.Caption;
else s1 := bt.Caption;
FTipWnd.Tip := s1+(st?(" ("+st+")"):"");
FTipWnd.ShowTIp();
end
end else
begin
EndShowWnd();
end
end
function AddButton(btn);
begin
{**
@explan(说明) 添加工具栏项%%
**}
InsertButton(btn);
end
function getbtnbyindex(idx);
begin
return FButtons[idx];
end
function SetBtnIndex(btn,idx);
begin
{**
@explan(说明) 修改按钮的位置 %%;
@param(btn)(TToolButton) 工具栏项 %%
@param(idx)(TToolButton | integer) 位置 %%
**}
if not(idx >= 0)then return -1;
cidx := IndexOfBtn(btn);
if cidx<0 then return -1;
if cidx=idx then return idx;
btnlength := FButtons.Length();
if idx>cidx then
begin
for i := cidx to min(btnlength-1,idx)-1 do
begin
FButtons.swap(i,i+1);
end
end else
begin
for i := idx to cidx-1 do
begin
FButtons.swap(i,i+1);
end
end
if Btn.Visible then InvalidateRect(nil,false);
return cidx;
end
function InsertButton(btn,idx);
begin
{**
@explan(说明) 在指定位置插入按钮 %%
@param(btn)(TToolButton) 工具栏项 %%
@param(idx)(TToolButton | integer) 位置 %%
**}
if not(btn is class(TcustomToolButton))then return;
cidx := IndexOfBtn(btn);
//位置计算
if cidx >= 0 then return;
if btn.willaddBar <> self then
begin
return btn.parent := self(true);
end
FButtons.push(btn);
nidx := nil;
if idx >= 0 then nidx := idx;
else if ifobj(idx)then nidx := IndexOfBtn(idx);
if nidx >= 0 then SetBtnIndex(btn,nidx);
if btn.Visible then
begin
IncPaintLock();
InvalidateRect(nil,false);
FWillModifyToolbar := true;
DecPaintLock();
end
end
function DeleteButton(btn); //删除按钮
begin
{**
@explan(说明) 在删除按钮 %%
@explan(说明) 删除button %%
@param(btn)(TToolButton) 工具栏项%%
**}
idx := IndexOfBtn(btn);
if idx=-1 then return -1;
if btn.willaddBar <>-1986 then
begin
return btn.Parent := nil;
end
FButtons.splice(idx,1);
if btn.Visible then
begin
IncPaintLock();
InvalidateRect(nil,false);
FWillModifyToolbar := true;
DecPaintLock();
end
end
function GetItemRect(btn); //获得按钮区域
begin
{**
@explan(说明) 获得按钮的区域 %%
@param(btn)(TToolButton) 工具栏项%%
@return(array) 区域 %%
**}
for i,v in FButtons.data do
begin
if v=btn then return FBtnRects[i];
end
for i,v in fmenubtns.data do
begin
if v=btn then return fmenubtnrects[i];
end
return array(0,0,0,0);
end
function IncPaintLock(); //锁定刷新
begin
{**
@explan(说明) 锁定绘制,和 DecPaintLock() 成对使用 %%
**}
BeginUpdate();
end
function DecPaintLock(); //释放刷新
begin
{**
@explan(说明) 取消绘制锁定,和 IncPaintLock() 成对使用 %%
**}
EndUpdate();
end
function Paint();override;
begin
c := canvas;
c.font := font;
for i := 0 to getbtncount()-1 do
begin
bi := getbtnitem(i);
if not(bi.Visible)then continue;
ci := getbtnrect(i);
if not ifarray(ci)then return;
if FMouseDownIdx=i then
begin
if fmainmenu then
begin
c.brush.Color := 0xffffbb;
c.FillRect(ci);
end
else
c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONCHECK);
end else
begin
if fmainmenu then
begin
c.brush.Color := Color;////;
c.FillRect(ci);
end
else
begin
if bi.enabled then
begin
c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH);
end else
begin
c.brush.Color := 0x8c8c8c;////0xc0c0cc;
c.FillRect(ci);
end
end
end
if fmainmenu then
begin
eab := not bi.Enabled;
if eab then
begin
bc := c.font.color;
c.font.color := 0xc0c0c0;
end
c.drawtext(bi.Caption,ci,DT_VCENTER.|DT_CENTER .|DT_SINGLELINE);
if eab then c.font.color := bc;
continue;
end
igslist := ImageList;
if igslist is class(TCustomImageList)then
begin
igid := bi.ImageId;
if igid >= 0 and igid<igslist.ImageCount then
begin
if bi.Enabled then igslist.draw(igid,c,ci[0]+2,ci[1]+2,nil);
else igslist.draw(igid,c,ci[0]+2,ci[1]+2,ILC_COLOR4);
end
end
end
end
function DoEndUpDate();override; //锁定刷新释放
begin
if not(IsUpDating())then
begin
if FWillModifyToolbar then
begin
FWillModifyToolbar := false;
//DoControlAlign();
//if Parent then Parent.DoControlAlign();
if NoRecycled() then AdjustSize();
end
end
inherited;
end
function DoControlAlign();override;
begin
CalcButtonsRect();
end
function CalcHeightFixWidth(w);
begin
{**
@explan(说明) 固定宽度计算工具栏高度 %%
@param(w)(integer) 给定宽度 %%
@return(intger) 计算的高度 %%
**}
bw := 0;
//16 6 2 简化边框处理
if WSSizebox or WsDlgModalFrame or Border then bw := 2;
if fmainmenu then
begin
return font.Height+bw+4;
end
imglst := ImageList; //图标
imgw := 28;
imgh := 28;
if imglst is class(TCustomImageList)then
begin
imgw := imglst.Width+4;
imgh := imglst.height+4;
end
nh := w-bw;
bct := 0;
for i := 0 to FButtons.Length()-1 do //调整大小
begin
bi := FButtons[i];
if not(bi.Visible)then
begin
continue;
end
bct++;
end
if bct=0 then return imgh+bw;
rct := integer((nh+2)/(imgw+1));
if rct<1 then rct := 1;
//echo "总共:",bct,"每行:",rct,"===行数",(integer( bct/rct)+1),"\r\n";
nt := bct/rct;
return((frac(nt)>0)?(integer(nt)+1):(nt)) * (imgh+1)+bw;
return(integer(bct/rct)+1) * (imgh+1)+bw;
end
function CalcWidthFixHeight(h);
begin
{**
@explan(说明) 固定高度计算工具栏宽度 %%
@param(w)(integer) 给定高度 %%
@return(intger) 宽度 %%
**}
bw := 0;
if WSSizebox or WsDlgModalFrame or Border then bw := 2;
if fmainmenu then
begin
ft := Font;
if ft then
begin
return ft.Height+2+bw;
end
return 40;
end
imglst := ImageList; //图标
imgw := 28;
imgh := 28;
if imglst is class(TCustomImageList)then
begin
imgw := imglst.Width+4;
imgh := imglst.height+4;
end
nh := h-bw;
bct := 0;
for i := 0 to FButtons.Length()-1 do
begin
bi := FButtons[i];
if not(bi.Visible)then
begin
continue;
end
bct++;
end
if bct=0 then return imgw+bw;
rct := integer((nh+2)/(imgh+1));
if rct<1 then rct := 1;
nt := bct/rct;
return((frac(nt)>0)?(integer(nt)+1):(nt)) * (imgw+1)+bw;
return(integer(bct/rct)+1) * (imgw+1)+bw;
end
function IndexOfBtn(btn);
begin
{**
@explan(说明) 获得按钮序号 %%
@param(btn)(TToolButton) 按钮 %%
@return(integer) >=0表示正确序号 %%
**}
for i := 0 to FButtons.length()-1 do
begin
if btn = FButtons[i] then return i;
end
return -1;
end
function Notification(a,op);override;
begin
if a=fmainmenu and op=opRecycling then
begin
setmainmenu(nil);
end
inherited;
end
function Recycling();override;
begin
while FButtons.Length()>0 do
begin
DeleteButton(FButtons[0]);
end
inherited;
FShowLoked := true;
FBtnRects := nil;
FButtons := nil;
FTipWnd := nil;
FShowtimeIndexA := nil;
FTimer := nil;
FCurrentPos := nil;
FMouseDownIdx :=-1;
fmainmenu := nil;
fmenubtns := nil;
end
function ExecuteCommand(cmd,pm);override;
begin
case cmd of
"btnchanged":
begin
if fmainmenu then return ;
if not HandleAllocated() then return ;
if autosize then return AdjustSize();
CalcButtonsRect();
InvalidateRect(nil,false);
return 0;
end
end ;
return inherited;
end
published
property MainMenu:tmainmenu read fmainmenu write setmainmenu;
protected
procedure SetAlign(Value:TAlign);override;
begin
if Align=Value then exit;
if Value in array(alClient)then
begin
return;
end
inherited;
end
function ImageChanged();override;
begin
if IsUpDating()then return;
if fmainmenu then return ;
if not NoRecycled() then return ;
CalcButtonsRect();
AdjustSize();
return ;
if Parent then
begin
Parent.DoControlAlign();
CalcButtonsRect();
InvalidateRect(nil,false);
end
end
private
function mainmenuchanged();
begin
fmenubtns := new tnumindexarray();
for i:= 0 to fmainmenu.ItemCount-1 do
begin
fmenubtns.push(new tcustommenubutton( fmainmenu.GetItemByIndex(i),self(true)));
end
if not NoRecycled() then return ;
CalcButtonsRect();
AdjustSize();
end
function setmainmenu(v); //设置主菜单
begin
if v<>fmainmenu then
begin
if v is class(TcustomMainmenu) then
begin
fmainmenu := v;
fmainmenu.onchanged := thisfunction(mainmenuchanged);
mainmenuchanged();
end else
begin
fmainmenu := nil;
fmenubtns := new tnumindexarray();
end
doControlALign();
InvalidateRect(nil,false);
end
end
function EndShowWnd();//提示框
begin
FShowTimeIndexA :=-1;
FTimer.Stop();
FTipWnd.Visible := false;
end
function CalcButtonsRect(); //计算按钮区域
begin
if(IsUpDating())then
begin
FWillModifyToolbar := true;
return;
end
ft := Font;
if not ft then return ;
ftwd := ft.Width;
fth := ft.Height;
rc := ClientRect;
if fmainmenu then
begin
y := rc[1];
x := rc[0]+1;
fmenubtnrects := array();
rct := 0;
cct := 0;
for i:= 0 to fmenubtns.length()-1 do
begin
mu := getbtnitem(i);
if mu.Visible then
begin
s := mu.Caption;
//wh := GetTextWidthAndHeightWidthFont(s,self.font,0);// wh
//nwh := x+wh[0]+15;
nwh := x+length(s)*ftwd+15;
if nwh>rc[2] and cct>0 then
begin
x := rc[0]+1;
nwh := x+length(s)*ftwd+15;
cct := 0;
y :=y+fth+3;
end
fmenubtnrects[i]:= array(x,y,nwh,y+fth+2);
cct++;
x:=nwh;
//if x>rc[2] then break; //只有一行
end else
begin
fmenubtnrects[i] := array(0,0,0,0);
end
end
return ;
end
imglst := ImageList; //图标
imgw := 28;
imgh := 28;
if imglst is class(TCustomImageList)then
begin
imgw := imglst.Width+4;
imgh := imglst.height+4;
end
FBtnRects := array();
x := y := 0;
rct := 0;
case Align of
alLeft,alRight:
begin
for i := 0 to FButtons.Length()-1 do //调整大小
begin
bi := FButtons[i];
if not(bi.Visible)then
begin
FBtnRects[i]:= array(0,0,0,0);
continue;
end
if y+imgh>rc[3]then
begin
if rct=0 then
begin
if bi.stylesep then
begin
FBtnRects[i]:= array(0,0,0,0);
end else
begin
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
end
y := 0;
x += imgw+1;
end else
begin
y := 0;
x += imgw+1;
if bi.stylesep then FBtnRects[i]:= array(0,0,0,0);
else
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
y += imgh+1;
rct := 1;
end
end else
begin
if bi.stylesep then FBtnRects[i]:= array(0,0,0,0);
else
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
y += imgh+1;
rct++;
end
end
end else
begin
for i := 0 to FButtons.Length()-1 do //调整大小
begin
bi := FButtons[i];
if not(bi.Visible)then
begin
FBtnRects[i]:= array(0,0,0,0);
continue;
end
if x+imgw>rc[2]then
begin
if rct=0 then
begin
if bi.stylesep then FBtnRects[i]:= array(0,0,0,0);
else
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
x := 0;
y += imgh+1;
end else
begin
x := 0;
y += imgh+1;
if bi.stylesep then FBtnRects[i]:= array(0,0,0,0);
else
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
x += imgw+1;
rct := 1;
end
end else
begin
if bi.stylesep then FBtnRects[i]:= array(0,0,0,0);
else
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
x += imgw+1;
rct++;
end
end
end
end;
end
function PosInBtn(p);
begin
for i := 0 to getbtncount()-1 do
begin
ri := getbtnrect(i);
if ri and pointinrect(p,ri)then
begin
return i;
end
end
return -1;
end
function getbtnitem(idx);
begin
if fmainmenu then return fmenubtns[idx];
return FButtons[idx];
end
function getbtncount();
begin
if fmainmenu then return fmenubtns.length();
return FButtons.length();
end
function getbtnrect(idx);
begin
if fmainmenu then return fmenubtnrects[idx];
return FBtnRects[idx];
end
FShowLoked;
FBtnRects;
FButtons;
fmenubtns;
fmenubtnrects;
FTipWnd;
FShowtimeIndexA;
FTimer;
FCurrentPos;
FMouseDownIdx;
FWillModifyToolbar;
fmainmenu;
end
type TcustomStatusBar=class(TCustomControl)
{**
@explan(说明) 状态栏 %%
**}
protected
procedure SetAlign(Value:TAlign);override;
begin
if Align=Value then exit;
if Value in array(alBottom,alNone,alTop)then
begin
inherited;
end
end
public
function create(AOwner);override;
begin
FItemOder := 0;
inherited;
height := 25;
Align := alBottom;
Fitems := array();
end
function Paint();override;
begin
c := clientRect;
FCwid := c[2];
FCHei := c[3];
if FItemOder then return paintb();
painta();
end
function additem(str,wd);
begin
{**
@explan(说明)添加项目 %%
@param(str)(string) 文本 %%
@param(wd)(number) 宽度 ,大于1 表示绝对宽阔 ,小于1 表示相对宽度 %%
**}
if not ifstring(str)then return -1;
if not(wd>0)then wd := 100;
Fitems[Length(Fitems)]:= array("text":str,"width":wd);
if faddlock then return 0;
if HandleAllocated()then
begin
InvalidateRect(nil,false);
end
end
function deleteitem(idx);
begin
{**
@explan(说明) 删除项目 %%
@param(idx)(integer) 序号 %%
**}
if not(itemidok(idx))then return -1;
deleteindex(Fitems,idx,true);
if HandleAllocated()then
begin
InValidateRect(nil,false);
end
end
function setitemtext(str,idx);
begin
{**
@explan(说明) 修改字段 %%
@param(str)(string) 文本%%
@param(id)(integer) 序号 %%
**}
if not ifstring(str)then return -1;
if not(itemidok(idx))then return -1;
Fitems[idx,"text"]:= str;
if HandleAllocated()then
begin
InvalidateRect(nil,false);
end
end
function GetPreferredSize(w,h);override;
begin
class(tcontrol).GetPreferredSize(w,h);
w := Width;
end
published
property Items:statusitems read Fitems Write SetItems;
property itemtext:string read gettexti write settexti;
property itemwidth:integer read getwidthi write setwidthi;
property itemorder:bool read FItemOder write setitemorder;
{**
@param(Items)(array)设置项 ,二维数组包括 text ,width 两个字段 array(("text":"abc","width":200),("text":"part2","width":0.4))%%
@param(itemtext)(string) 通过索引获取设置文本%%
@param(itemwidth)(integer) 通过索引设置获取宽度%%
@param(itemorder)(bool) item展示排序,默认false从左到右,true为从右到左%%
**}
private
faddlock;//添加锁定刷新
Fitems;//项目
FCwid;//宽度
FCHei;//高度
FItemOder;//排序
private
function itemidok(id);
begin
ct := length(Fitems);
return id >= 0 and id<ct;
end
function setitems(its);
begin
{**
@explan(说明) 设置多个项目 %%
**}
Fitems := array();
for i,v in its do
begin
faddlock := true;
if ifarray(v)then additem(v["text"],v["width"]);
faddlock := false;
end
end
function DrawStatItem(cvs,v,rec);
begin
cvs.Draw("FrameControl",array(rec[0:1],rec[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH); //DFCS_CHECKED DFCS_FLAT
hstr := v["text"];
if hstr and ifstring(hstr)then
begin
cvs.Font := font;
cvs.drawtext(hstr,rec,DT_VCENTER .| DT_SINGLELINE .| DT_NOPREFIX);
end
end
function getwidthi(idx); //获得宽度
begin
if itemidok(idx) then
begin
return Fitems[idx,"width"];
end
end
function setwidthi(idx,w); //设置宽度
begin
if not(w>=0) then return ;
if itemidok(idx) then
begin
w1 := Fitems[idx,"width"];
if w<>w1 then
begin
Fitems[idx,"width"] := integer(w);
InvalidateRect(nil,false);
end
end
end
function gettexti(idx); //获得文本
begin
if itemidok(idx) then
begin
return Fitems[id,"text"];
end
end
function settexti(idx,s);//设置文本
begin
setitemtext(s,idx);
end
function setitemorder(v);
begin
nv := v?true:false;
if nv<>FItemOder then
begin
FItemOder := nv;
if FItems then
InvalidateRect(nil,false);
end
end
function paintb();//从左到右
begin
p := FCwid;
cvs := canvas;
for i,v in FItems do
begin
wd := v["width"];
if wd>0 and wd<1.0001 then
begin
wd *= FCwid;
end
DrawStatItem(cvs,v,array(max(0,p-wd),0,p,FCHei));
p -= wd;
if p<=0 then return;
end
if p>0 then
begin
DrawStatItem(cvs,array(),array(0,0,p,FCHei));
end
end
function painta();//从又到左
begin
p := 0;
cvs := canvas;
for i,v in FItems do
begin
wd := v["width"];
if wd>0 and wd<1.0001 then
begin
wd *= FCwid;
end
DrawStatItem(cvs,v,array(p,0,p+wd,FCHei));
p += wd;
if p>FCwid then return;
end
if p<FCwid then
begin
DrawStatItem(cvs,array(),array(p,0,FCwid,FCHei));
end
end
end
type TCustomSpinEdit = class(TCustomControl)
{**
@explan(说明)spinedit控件
**}
private
FEdit;
FUDwidth;
FUPrect;
FDownrect;
FCI;
CI_UP;
CI_DOWN;
CIS_NONE;
CIS_MOUSEDOWN;
CIS_MOUSEUP;
CIS_MOUSEON;
FIncrement: Double;
FDecimals: Integer;
FMaxValue: Double;
FMinValue: Double;
FValue: Double;
[weakref]FOnIncrease;
[weakref]FOnDecrease;
FLeveTimer;
function DrawItem(id,f);
begin
ys := 0;
case id of
CI_UP:
begin
rec := FUPrect;
ys := DFCS_SCROLLup;
end
CI_DOWN:
begin
rec := FDownrect;
ys := DFCS_SCROLLDOWN;
end else
return;
end
case f of
CIS_MOUSEDOWN:
begin
//_wapi.DrawFrameControl(Canvas.Handle,rec,DFC_BUTTON,DFCS_BUTTONPUSH);
Canvas.Draw("framecontrol",array(rec[0:1],rec[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH)
end
CIS_NONE:
begin
Canvas.Draw("framecontrol",array(rec[0:1],rec[2:3]),DFC_SCROLL,ys);
end
CIS_MOUSEON:
begin
//canvas.pen.color := rgb(100,200,100);
//canvas.draw("Rectangle",array(rec[0:1],rec[2:3]));
end
end;
end
FChar;
protected
function UpdateControl();virtual;
begin
FEdit.Text := inttostr(FValue);
end
function GetValue();virtual;
begin
r := FEdit.text;
r := StrToIntDef(r,FValue);
if r <> FValue then
begin
FValue := r;
end
return FValue;
end
procedure SetValue(const AValue:Double);virtual;
begin
if AValue <> FValue then
begin
if AValue >= FMinValue and AValue <= FMaxValue then
begin
FValue := AValue;
UpdateControl();
end
end
end
procedure SetMaxValue(const AValue:Double);virtual;
begin
if AValue <> FMaxValue then
begin
FMaxValue := AValue;
end
end
procedure SetMinValue(const AValue:Double);virtual;
begin
if AValue <> FMinValue then
begin
FMinValue := AValue;
end
end
procedure SetIncrement(const AIncrement:Double);virtual;
begin
nv := integer(AIncrement);
if FIncrement <> nv and nv>0 then
begin
FIncrement := nv;
end
end
function doIncrease(o,e);virtual;
begin
nv := GetValue()+FIncrement;
if nv <= FMaxValue and nv >= FMinValue then
begin
CallMessgeFunction(FOnIncrease,o,e);
if not e.skip then
begin
FValue := nv;
UpdateControl();
end
end else
begin
if nv>FMaxValue then SetValue(FMaxValue);
else if nv<FMinValue then SetValue(FMinValue);
end
end
function doDcrease(o,e);virtual;
begin
nv := GetValue()-FIncrement;
if nv <= FMaxValue and nv >= FMinValue then
begin
CallMessgeFunction(FOnDecrease,o,e);
if not e.skip then
begin
FValue := nv;
UpdateControl();
end
end else
begin
if nv>FMaxValue then SetValue(FMaxValue);
else if nv<FMinValue then SetValue(FMinValue);
end
end
public
function dosetfocus(o,e);override;
begin
FEdit.setFocus();
end
function dokillfocus(o,e);override;
begin
FEdit.killFocus();
end
function editkeypress(o,e);virtual;
begin
c := e.wparam;
if not(FChar.IsNumber(c)or(c=VK_BACK))then
begin
e.skip := true;
end
end
function Create(AOwner);override;
begin
inherited;
FChar := new TCharDiscrimi();
//FLeveTimer := new TCustomTimer(self);
//FChar.sinit();
FMaxValue := 100;
FMinValue := 0;
//FValue := 0;
FIncrement := 1;
FDecimals := 2;
Border := false;
height := 25;
Width := 60;
FUDwidth := 20;
FEdit := new teditable(self);
FEdit.Visible := true;
FEdit.border := true;
FEdit.OnKeyPress := thisfunction(editkeypress);
FEdit.host := self(true);
FUPrect := array();
FDownrect := array();
CI_UP := 1;
CI_DOWN := 2;
CIS_NONE := 1;
CIS_MOUSEDOWN := 2;
CIS_MOUSEUP := 3;
CIS_MOUSEON := 4;
Value := 0;
end
function Recycling();override;
begin
FEdit.Recycling();
fedit := nil;
inherited;
end
function DoControlAlign(rect);override;
begin
rect := ClientRect;
FEdit.ClientRect := array(rect[0],rect[1],rect[2]-FUDwidth,rect[3]);
cl := rect; //ClientRect();
cl[0]:= cl[2]-FUDwidth;
cl2 := cl;
h :=(cl[3]-cl[1])/2-1;
cl[3]:= h;
cl2[1]:= h+2;
FUPrect := cl;
FDownrect := CL2;
end
function WMKEYDOWN(o,e);override;
begin
if csDesigning in ComponentState then return ;
fedit.WMKEYDOWN(o,e);
if e.CharCode=VK_UP then
begin
doIncrease(o,e);
end else
if e.CharCode = VK_DOWN then
begin
doDcrease(o,e);
end
end
function WMCHAR(o,e);override;
begin
if csDesigning in ComponentState then return ;
FEdit.WMCHAR(o,e);
end
function MouseDown(o,e);override;
begin
if csDesigning in ComponentState then return ;
p := e.pos;
if pointinrect(p,FEdit.ClientRect)then
begin
return FEdit.MouseDown(o,e);
end
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return ;
FEdit.MouseUp(o,e);
if FCI=CI_DOWN then
begin
doDcrease(o,e);
return ;
end else
if FCI=CI_UP then
begin
doIncrease(o,e);
return ;
end
end
function MouseMove(o,e);override;
begin
if csDesigning in ComponentState then return ;
p := e.pos;
if pointinrect(p,FUPrect)then
begin
FCI := CI_UP;
end else
if pointinrect(p,FDownrect)then
begin
FCI := CI_DOWN;
end else
begin
FCI := 0;
FEdit.MouseMove(o,e);
end
end
function GetPreferredSize(w,h);override;
begin
class(tcontrol).GetPreferredSize(w,h);
w := Width;
end
function paint();override;
begin
FEdit.paint();
DrawItem(CI_UP,CIS_NONE);
DrawItem(CI_DOWN,CIS_NONE);
end
function FontChanged(o);override;
begin
inherited;
if FEdit then FEdit.Font := Font;
end
published
property OnIncrease:eventhandler read FOnIncrease write FOnIncrease;
property OnDecrease:eventhandler read FOnDecrease write FOnDecrease;
property Increment:integer read FIncrement write SetIncrement;
property MinValue:integer read FMinValue write SetMinValue;
property MaxValue:integer read FMaxValue write SetMaxValue;
property Value:integer read GetValue write SetValue;
{**
@param(Increment)(integer) 增长间隔 %%
@param(MinValue)(integer) 下界 %%
@param(MaxValue)(integer) 上界 %%
@param(Value)(integer) 值 %%
@param(OnIncrease)(function[TCustomSpinEdit,tuieventbase]) 增加时的回调 %%
@param(OnDecrease)(function[TCustomSpinEdit,tuieventbase]) 减少时的回调 %%
**}
end
type tcustomgroupbox=class(TCustomControl)
function create(owner);override;
begin
ftwidth := 7;
ftheight := 15;
inherited;
Parentcolor := false;
Left := 10;
Top := 10;
Width := 185;
Height := 105;
caption := "group";
Color := 15790320;//rgb(240,240,240);
FtextPosition := 0;
end
function Paint();override;
begin
c := caption;
wf := ftwidth;
hf := ftheight+2;
cvs := Canvas;
cvs.font := Font;
cvs.pen.color := rgb(210,210,210);//rgb(170,170,170);
cvs.pen.width := 1;
cwd := 0;
if c then
begin
cwd := wf * length(c)+1;
end
rc := class(TWinControl).GetClientRect();
hf2 := integer(hf/2);
///////////////////////////////////////
cvs.moveto(array(3,hf2));
cvs.LineTo(array(3,rc[3]-3));
cvs.LineTo(array(rc[2]-3,rc[3]-3));
cvs.LineTo(array(rc[2]-3,hf2));
cvs.LineTo(array(3,hf2));
///////////////////////////////////////
/////////////////////////////////////////
txpos := 10;
if c then
begin
if cwd<(rc[2]-rc[0]-20)then
begin
case FtextPosition of
2:
begin
txpos := 10+integer((rc[2]-rc[0]-20-cwd)/2);
end
3:
begin
txpos := rc[2]-rc[0]-10-cwd;
end
end;
end
cvs.pen.color := Color;
cvs.moveto(array(txpos-1,hf2));
cvs.LineTo(array(txpos+cwd+1,hf2));
cvs.textout(c,array(txpos,0));
end
drawdesigninggrid();
/////////////////////////////////
end
function FontChanged(o);override;
begin
ft := Font;
if ft then
begin
ftwidth := ft.Width;
ftheight := ft.Height;
inherited;
end
//doControlALign();
end
function AdjustSize();override;
begin
if autosizing then return ;
inherited;
doControlALign();
end
function GetClientRect();override;
begin
r := getwndclientrect();
r[0]+=4;
r[1]+=ftheight+4;
r[2]-=4;
r[3]-=4;
if r[2]<r[0] then r[2] := r[0];
if r[3]<r[1] then r[3] := r[1];
return r;
end
function GetPreferredSize(w,h);override;
begin
inherited;
br := BoundsRect;
cr := ClientRect;
dh := (br[3]-br[1])-(cr[3]-cr[1])-8;
h-=dh;
end
published
property textPos:AlignStyle9 read FtextPosition write setTextPosition;
private
function setTextPosition(n);
begin
if(n in array(0,1,2,3))and n <> FtextPosition then
begin
FtextPosition := n;
InvalidateRect(nil,false);
end
end
private
function calc_rec();
begin
end
ftwidth;
ftheight;
frecplus ;
fspacewidth;
FtextPosition;
end
type tcustomprogressbar=class(TCustomControl)
{**
@explan(说明) 进度栏
进度栏是显示任务进行完成度的控件。进度栏的上下限是进度条位置可移动的
范围，可以通过range属性获取、修改，其默认值是array(0,100)。进度条的位置可以通过
position属性获取、修改。进度栏的步增量是其每次调用increaseByStep函数进度条
位置移动的量，可以通过step属性获取、修改，其默认值是10.
进度条默认是分段离散的，可通过修改smooth成员设置其为平滑连续的。默认是
水平从左到右移动，可通过修改vertical成员来设置其为垂直从底部到顶部移动。
**}
public
function create(AOwner);override;
begin
inherited;
Caption:="prograssbar";
FLeft := 10;
FTop := 10;
Width := 150;
Height :=20;
Fsmooth:=0;
Fvertical:=0;
Frange:=array(0,100);
Fposition:=0;
Fstep:=10;
FbarColor:=0xD77800;
color:=0xf0f0f0;
end
function GetPreferredSize(w;h);override;
begin
ft := Font;
if ft then
begin
if Fvertical then
begin
h := Height;
w := ft.Height+2;
end else
begin
w := Width;
h := ft.Height+2;
end
end
end
function paint();override;
begin
inherited;
dc := Canvas;
r := ClientRect;
h := r[3]-r[1];
w := r[2]-r[0];
br := r;
rt := (Fposition/(Frange[1]-Frange[0]));
if Fvertical then
begin
d := rt *h;
br[1] +=(h-d);
end else
begin
d := floor(rt*w);
br[2] := br[0]+d;
end
dc.brush.color := FbarColor;
dc.FillRect(br);
if not Fsmooth then
begin
pc := dc.pen.Color;
pw := dc.pen.Width;
dc.pen.Color := color;
dc.pen.Width := 2;
sp := 18;
if Fvertical then
begin
p := br[3]-sp;
while p>br[1] do
begin
dc.moveto(array(r[0],p));
dc.LineTo(array(r[2],p));
p-=sp;
end
end else
begin
p := sp ;
while p<br[2] do
begin
dc.moveto(array(p,r[1]));
dc.LineTo(array(p,r[3]));
p+=sp;
end
end
dc.pen.Color := pc;
dc.pen.Width := pw;
end
end
function increaseByStep();
begin
{**
@explan(说明)按照步增量移动进度条当前的位置，当其超过限度则设置位置至下限以便于从头重新开始%%
@return(integer)先前的位置，出错返回-1%%
**}
r:=Fposition;
Fposition+= Fstep;
if Fposition>Frange[1] then
Fposition := Frange[0];
else if Fposition<Frange[0] then
Fposition := FRange[1];
InvalidateRect(nil,false);
return r;
end
function increaseBySpecifiedIncrement(n);
begin
{**
@explan(说明)进度条移动指定长度，当其超过限度则设置位置至该限度%%
@param(n)(integer)增长的数量%%
@return(integer)先前的位置，出错则返回-1%%
**}
r := Fposition;
if n<>0 then
begin
setPosition(n*Fstep);
end
return r;
end
published
property smooth:bool read Fsmooth write setSmooth;
property vertical:bool read Fvertical write setVertical;
{**
@param(smooth)(bool)进度条平滑移动%%
@param(vertical)(bool)进度条垂直移动%%
**}
property range:pairint read Frange write setRangeA;
property position:integer read Fposition write setPosition;
property stepincrement:integer read Fstep write setStep;
property barColor:color read FbarColor write setIndicatorBarColor;
{**
@param(range)(array of integer)进度栏的上下限%%
@param(position)(integer)进度条的位置%%
@param(stepincrement)(integer)进度栏的步增量%%
**}
private //属性
Fsmooth;
Fvertical;
Frange;
Fposition;
Fstep;
FbarColor;
private //属性处理函数
function setSmooth(n);
begin
nv := n?true:false;
if nv=Fsmooth then return ;
Fsmooth := nv;
InvalidateRect(nil,false);
end
function setVertical(n);
begin
nv := n?true:false;
if nv = Fvertical then return ;
Fvertical := nv;
InvalidateRect(nil,false);
end
function isValidPosition(n);
begin
return n>=Frange[0] and n<=Frange[1];
end
function isValidColorValue(n);
begin
if ifint(n) then
return not (n.&0xFF000000);
else
if ifint64(n) then
return not (n.&0xFFFFFFFFFF000000);
else return 0;
end
function setRange(l,h);
begin
{**
@explan(说明)设置进度栏的上下限，要求上限高于下限且皆非负%%
@param(l)(integer)下限%%
@param(h)(integer)上限%%
@return(integer)1:成功;0:失败;-1:出错%%
**}
if Frange=array(l,h) then return ;
if ifnumber(l) and ifnumber(h) and l>=0 and h>=l+1 then
begin
l:=integer(l);
h:=integer(h);
Frange:=array(l,h);
Fposition:=Fposition<l?l:(Fposition>h?h:Fposition);
return 1;
end
end
function setRangeA(arr);
begin
r := setRange(arr[0],arr[1]);
if r then
begin
InvalidateRect(nil,false);
end
end
function setPosition(n);
begin
{**
@explan(说明)设置进度条位置，当其超过限度则设置位置至该限度%%
@param(n)(integer)要设置的位置%%
@return(integer)先前位置，出错则返回-1%%
**}
r := Fposition;
if ifnumber(n) and isValidPosition(n) then
begin
Fposition:=n;
InvalidateRect(nil,false);
end
return r;
end
function setStep(n);
begin
{**
@explan(说明)设置进度栏步增量%%
@param(n)(integer)要设置的值%%
@return(integer)1:成功;0:失败;-1:出错%%
**}
if Fstep=n then return ;
d := Frange[1]-Frange[0];
if ifnumber(n) and n<=d then
begin
Fstep:=integer(n);
InvalidateRect(nil,false);
return 1;
end
end
function setIndicatorBarColor(clr);
begin
{**
@explan(说明)设置进度条颜色%%
@param(clr)(integer)要设置的颜色的rgb值%%
@return(integer)1:成功;0:失败;-1:出错%%
**}
if ifnumber(clr) and FbarColor<>clr and isValidColorValue(clr) then
begin
FbarColor:=integer(clr);
InvalidateRect(nil,false);
return 1;
end
end
end
type tcustomipaddr = class(TCustomControl)
{**
@explan(说明) ip控件 %%
**}
private
type tipeditor = class(teditable)
function create();
begin
inherited;
border := false;
FRange := array(0,1);
UnLocked := true;
end
function doonmaxtext();override;
begin
if FNext and Fnext.Visible then
begin
KillFocus();
ExecuteCommand("ecclcsel");
FNext.SetFocus();
FNext.ExecuteCommand("ecsel",array(1,10));
end
end
function doOnChange();override;
begin
if host and UnLocked then
begin
host.DoIpChanged();
end
end
function GoToPrev();
begin
if FPrev then
begin
KillFocus();
ExecuteCommand("ecclcsel");
FPrev.SetFocus();
FPrev.ExecuteCommand("ecsel",array(10,1));
end
end
function WMCHAR(o,e);override;
begin
case e.char of
"0" to "9" :
begin
inherited;
end
" ","\t",".":
begin
doonmaxtext();
end
chr(VK_BACK):
begin
inherited;
idx := ExecuteCommand("eccaretpos");
if idx=1 then return GoToPrev();
end
end
end
function WMKEYDOWN(o,e);override;
begin
case e.CharCode of
VK_LEFT:
begin
idx := ExecuteCommand("eccaretpos");
if idx=1 then return GoToPrev();
end
VK_RIGHT:
begin
idx := ExecuteCommand("eccaretpos");
if idx>length(self.Text) then
begin
return doonmaxtext();
end
end
end ;
inherited;
end
function GetNumValue();
begin
t := Text;
r := StrToIntDef(t,FRange[0]);
return r;
end
function GetTureText();
begin
return Inttostr(GetNumValue());
end
function SetNumValue(v);
begin
if v<=FRange[0] then return text := inttostr(FRange[0]);
if v>=FRange[1] then return text := inttostr(FRange[1]);
if v<FRange[1] and v>FRange[0] then text := inttostr(v);
end
function SetRange(a,b);
begin
if a>=0 and b>a then
begin
if a <> FRange[0] or b<>FRange[1] then
begin
FRange := array(a,b);
L := 1;
while 10^L<b do L++;
limitlength := L;
end
end
end
FRange;
FPrev;
FNext;
static UnLocked;
{protected
function filterstring(c);override;
begin
s := text;
if s="0" and c="0" then return "";
s+=c;
if s then
begin
r := StrToIntDef(s,0);
if r<=FRange[1] then return c;
end
return "";
end }
end
public
function Create(AOwner);override;
begin
inherited;
//for i,v in FEditors do v.FIPValueChanged := thisfunction(DoIpChanged);
end
function AfterConstruction();override;
begin
inherited;
minheight:=15;
FFontwidth := 7;
//FHasPort := 1;
width := 180;
height := 25;
border := true;
FIpe1 := new Tipeditor(self);
FIpe2 := new Tipeditor(self);
FIpe3 := new Tipeditor(self);
FIpe4 := new Tipeditor(self);
FPort := new Tipeditor(self);
FEditors := array(FIpe1,FIpe2,FIpe3,FIpe4,FPort);
for i := 0 to 3 do FEditors[i].SetRange(0,255);
FPort.SetRange( 0,65535);
FPort.Visible := false;
FIpe1.FNext := FIpe2;
FIpe2.FNext := FIpe3;
FIpe3.FNext := FIpe4;
FIpe4.FNext := FPort;
FIpe2.Fprev := FIPe1;
FIpe3.Fprev := FIPe2;
FIpe4.Fprev := FIPe3;
FPort.Fprev := FIPe4;
calcportsize();
for i,v in Feditors do V.host := self(true);
setAddress("127.0.0.1:443");
end
function FontChanged(sender);override;
begin
ft := Font;
if ft then
begin
for i,v in FEditors do v.font := ft;
FFontwidth := ft.Width;
inherited;
//calcportsize();
//InvalidateRect(nil,false);
end
end
function Paint();override;
begin
if not( FIpe1 and FIpe2 and FIpe3 and FIpe4 and FPort) then return ;
for i,v in FEditors do v.Paint();
dc := Canvas;
dc.font := font;
for i:=0 to 2+FHasPort do
begin
dc.DrawText(Fsynrects[i,0],Fsynrects[i,1]);
end
end
function DoIpChanged();
begin
return CallMessgeFunction(onAddrChange,self(true),new tuieventbase(0,0,0,0));
end
function cleanAddr();
begin
{**
@explan(说明)清除地址%%
**}
for i,v in FEditors do v.text := "";
end
function setRange(i,low,high);
begin
{**
@explan(说明)设置地址段范围 %%
@param(low)(integer) 下限 %%
@param(high)(integer) 上限 %%
@param(i)(integer) ip段序号 0,1,2,3 %%
**}
if i>=0 and i<=4 then
FEditors[integer(i)].SetRange(low,high);
end
function DoControlAlign();override;
begin
calcportsize();
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return ;
for i,v in FEditors do
begin
if v.HasFocus then
return v.MouseUp(o,e);
end
return inherited;
end
function MouseMove(o,e);override;
begin
if csDesigning in ComponentState then return ;
for i,v in FEditors do
begin
if v.HasFocus then
return v.MouseMove(o,e);
end
return inherited;
end
function MouseDown(o,e);override;
begin
if csDesigning in ComponentState then return ;
idx := -1;
for i,v in FEditors do
begin
if pointinrect(e.pos,v.GetEntryRect()) then
begin
idx := i;
//v.MouseDown(o,e);
end else v.KillFocus();
end
if idx>=0 then return FEditors[idx].MouseDown(o,e);
return inherited;
end
function dosetfocus(o,e);override;
begin
if csDesigning in ComponentState then return ;
for i,v in FEditors do
begin
if v.HasFocus then return v.SetFocus();
end
for i,v in FEditors do
begin
return v.SetFocus();
end
inherited;
end
function dokillfocus(o,e);override;
begin
if csDesigning in ComponentState then return ;
for i,v in FEditors do
begin
if v.HasFocus then return v.killFocus();
end
inherited;
end
function keypress(o,e);override;
begin
if csDesigning in ComponentState then return ;
for i,v in FEditors do
begin
if v.HasFocus then return v.WMCHAR(o,e);
end
inherited;
end
function KeyDown(o,e);override;
begin
if csDesigning in ComponentState then return ;
for i,v in FEditors do
begin
if v.HasFocus then return v.WMKEYDOWN(o,e);
end
inherited;
end
function GetPreferredSize(w,h);override;
begin
ft := Font;
ftw := ft.Width;
fth := ft.Height;
w := 21*ftw+2;
h := fth+5;
end
function Recycling();override;
begin
FaddrChange := nil;
FIpe1 := nil;
FIpe2 := nil;
FIpe3 := nil;
FIpe4 := nil;
FPort := nil;
for i,v in FEditors do v.Recycling();
FEditors := array();
inherited;
end
published
property HasPort:bool read FHasPort write SetHasPort;
property ipaddr:string read getAddress write setAddress;
property onaddrchanged:eventhandler read FaddrChange write FaddrChange;
{**
@param(ipaddr)(string)ip地址%%
@param(onaddrchanged)(function[tIPAddr,tuieventbase])id地址变化回调%%
**}
private
FEditors;
FHasPort;
FIpe1;
FIpe2;
FIpe3;
FIpe4;
FPort;
FFontwidth;
[weakref]FaddrChange;
Fsynrects;
function getAddress();
begin
r := "";
for i:= 0 to 3 do
begin
r+=FEditors[i].GetTureText();
if i<3 then r+=".";
end
if FHasPort then
begin
r += ":"+ FPort.GetTureText();
end
return r;
end
function setAddress(v);
begin
if not ifstring(v) then return ;
r := getAddress();
v1 := str2array(v,":");
vs := str2array(v1[0],".");
fipe1.UnLocked := false;
for i:=0 to min(length(vs)-1,3) do
FEditors[i].SetNumValue(StrToIntDef(vs[i],0));
if v1[1] then
begin
FPort.SetNumValue(StrToIntDef(v1[1],0)) ;
end
fipe1.UnLocked := true;
r1 := getAddress();
if r<>r1 then
begin
DoIpChanged();
end
end
function SetHasPort(v);
begin
nv := v?true:false;
if FHasPort <>nv then
begin
FHasPort := nv;
calcportsize();
FPort.Visible := nv;
InvalidateRect(nil,false);
end
end
function calcportsize();
begin
if not( FIpe1 and FIpe2 and FIpe3 and FIpe4 and FPort) then return ;
rc := ClientRect;
wd := rc[2]-rc[0]-2;
h := rc[3]-rc[1]-2;
if wd<56 then return ;
ewd := integer((wd-FFontwidth*(3+FHasPort)-10)/(4+FHasPort));
rc1 := array(1,1,ewd,h);
FIpe1.ClientRect := rc1;
rc1 := array(rc1[2]+FFontwidth+1,1,rc1[2]+FFontwidth+ewd,h);
FIpe2.ClientRect := (rc1);
rc1 := array(rc1[2]+FFontwidth+1,1,rc1[2]+FFontwidth+ewd,h);
FIpe3.ClientRect := (rc1);
if FHasPort then rc1 := array(rc1[2]+FFontwidth+1,1,rc1[2]+FFontwidth+ewd,h);
else
rc1 := array(rc1[2]+FFontwidth+1,1,rc[2],h);
FIpe4.ClientRect := (rc1);
if FHasPort then
begin
rc1 := array(rc1[2]+FFontwidth+1,1,rc[2],h);
FPort.ClientRect := (rc1);
FPort.visible := true;
end
Fsynrects := array();
wd+=2;
ewd := integer((wd-FFontwidth*(3+FHasPort)-10)/(4+FHasPort));
rc1 := rc;
//rc1[1] := integer(rc1[3]/5);
rc1[0]:= (FIpe1.ClientRect)[2];;
rc1[2] := rc1[0]+FFontwidth;
Fsynrects[0][0] := ".";
Fsynrects[0][1] := rc1;
rc1[0]:= (FIpe2.ClientRect)[2];
rc1[2] := rc1[0]+FFontwidth;
Fsynrects[1,0] := ".";
Fsynrects[1,1] := rc1;
rc1[0]:= (FIpe3.ClientRect)[2];;
rc1[2] := rc1[0]+FFontwidth;
Fsynrects[2,0] := ".";
Fsynrects[2,1] := rc1;
rc1[0]:= (FIpe4.ClientRect)[2];;
rc1[2] := rc1[0]+FFontwidth;
Fsynrects[3,0] := ":";
Fsynrects[3,1] := rc1;
end
end
type tcustomprocess = class(tcomponent) //进程对象
{**
@explan(说明)带管道的进程对象 %%
**}
public
function create(AOwner);
begin
inherited;
fprocesshandle := 0;
if not ifarray(fproces) then fproces := array();
if not ifarray(fpends) then fpends := array();
if not ftm then
begin
ftm := new tcustomtimer(nil);
ftm.Interval := 500;
ftm.Ontimer := thisfunction(dispatchproc);
end
end
function executeblock(exe,cmd); //阻塞执行
begin
if fprocesshandle then return 0;
if fexecstr then
begin
e := exe;
if not(ifstring(e) and e) then return 0;
arg := cmd;
end else
begin
if not parserasexeclevparam(exe,cmd,e,arg,envp) then return 0;
end
//////////////处理linux启动路径/////////////////////
{$ifdef linux}
for i := length(e) downto 2 do
begin
if e[i]="/" then
begin
ph := e[1:i];
break;
end
end
envp := array();
if ph then
begin
envp[length(envp)] := "LD_LIBRARY_PATH="+ph;
end
Sysexecsetenvs(envp,1);
{$endif}
///////////////////////////处理管道////////////////////////
Sysexecnewpipe(0);
ferrinfo := nil;
sdir :=nil;
if ifstring(fStartupDirectory) and fStartupDirectory then
begin
if fStartupDirectory[length(fStartupDirectory)]=iofileseparator() then
begin
if filelist("",fStartupDirectory+"*") then
begin
sdir := fStartupDirectory;
end
end else
begin
if filelist("",fStartupDirectory) then
begin
sdir := fStartupDirectory+iofileseparator();
end
end
end
hd := sysexec(e,arg,sdir,true,code);
if ifarray(code) then
begin
doprocecho(self(true),code["out"]);
ferrinfo:=code["code"];
end
Sysexecdeletepipe(0);
return hd;
end
function CreateProcess(exe,cmd,exitWithParent);
begin
{**
@explan(说明) 执行代码,非阻塞当前线程 %%
@param(exe)(string) 程序 %%
@param(cmd)(string|array) 命令行 %%
@param(exitWithParent)(bool) 是否跟随父进程退出 %%
@return(pointer) 句柄 %%
**}
if fprocesshandle then return 0;
if fexecstr then
begin
e := exe;
if not(ifstring(e) and e) then return 0;
arg := cmd;
end else
begin
if not parserasexeclevparam(exe,cmd,e,arg,envp) then return 0;
end
//////////////处理linux启动路径/////////////////////
{$ifdef linux}
for i := length(e) downto 2 do
begin
if e[i]="/" then
begin
ph := e[1:i];
break;
end
end
envp := array();
if ph then
begin
//envp[length(envp)] := "LD_LIBRARY_PATH=LD_LIBRARY_PATH:"+ph;
envp[length(envp)] := "LD_LIBRARY_PATH="+ph;
end
//envp[length(envp)] := getgtkdisplay();
Sysexecsetenvs(envp,1);
{$endif}
///////////////////////////处理管道////////////////////////
Sysexecnewpipe(0);
ferrinfo := nil;
sdir :=nil;
if ifstring(fStartupDirectory) and fStartupDirectory then
begin
if fStartupDirectory[length(fStartupDirectory)]=iofileseparator() then
begin
if filelist("",fStartupDirectory+"*") then
begin
sdir := fStartupDirectory;
end
end else
begin
if filelist("",fStartupDirectory) then
begin
sdir := fStartupDirectory+iofileseparator();
end
end
end
hd := sysexec(e,arg,sdir,false,code);
if hd=0 then
begin
return 0;
end
dh := (((exitWithParent or ifnil(exitWithParent))));
fprocesshandle := hd;
fexestring := e;
fparams := arg;
addto(self(true),dh);
return hd;
end
function writepipe(s);//写管道
begin
{**
@explan(说明) 写管道%%
@param(s)(string) 写入的字符 %%
@return(integer) 写的信息 %%
**}
if fprocesshandle<>0 and ifstring(s) and s then
begin
return SysExecWritePipe(fprocesshandle,s);
end
return 0;
end
function terminate(code);
begin
{**
@explan(说明) 停止当前进程 %%
@param(code)(integer) 退出码 %%
**}
if not(code>0 or code<0) then code := 1;
if fprocesshandle<>0 then
begin
SysTerminate(code,fprocesshandle);
end
end
function Recycling();override;
begin
inherited;
id := fprocesshandle;
if (id<>0) and fpends[id] then SysTerminate(1,id);
FOnEcho := nil;
fonprcstart := nil;
fonprocended := nil;
end
published
property StartupDirectory read fStartupDirectory write fStartupDirectory;
property handle read fprocesshandle;
property errinfo read ferrinfo;
property exename read fexestring;
property paramarray read fparams;
property OnEcho read FOnEcho write FOnEcho;
property onstarted read fonprcstart write fonprcstart;
property onended read fonprocended write fonprocended;
property execstr read fexecstr write fexecstr;
{**
@param(OnEcho)(function[tcustomprocess,str]) 打印信息回调 %%
@param(onstarted)(function[tcustomprocess,nil]) 启动回调 %%
@param(onended)(function[tcustomprocess,str]) 停止回调 %%
@param(handle)(pointer) 进程句柄 %%
**}
private //成员变量
fStartupDirectory;
fexecstr;
ferrinfo;
fprocesshandle;
weakref
fonprcstart;
FOnEcho;
fonprocended;
autoref
fexestring;
fparams;
private //处理函数
function doprocecho(o,s); //打印
begin
if not(CallMessgeFunction(FOnEcho,o,s))then
begin
echo s;
end
end
function doonprocend(o,e);
begin
CallMessgeFunction(fonprocended,o,e) ;
fexestring := nil;
fparams := nil;
end
function doonprocstart(o,e);
begin
CallMessgeFunction(fonprcstart,o,e) ;
end
function parserasexeclevparam(exe,cmd,e,arg,envp);
begin
envp := nil;
if ifstring(cmd) then
begin
arg := ParserCommandLine(cmd);
end else
begin
arg := cmd;
end
if not arg then return 0;
if ifstring(exe) and exe then
begin
e := exe;
end
else
begin
e := arg[0];
end
if not(ifstring(e) and e) then return 0;
//////////////将linux启动目录移入到上层,避免复杂的命令行参数////////////////
return 1;
end
{function getgtkdisplay();
begin
dsp := sysgetenv("DISPLAY");
if dsp="" then dsp := ":0";
if not ifstring(dsp) then dsp := ":0";
return "DISPLAY="+dsp;
end }
private //静态处理函数
class function dispatchproc(); //循环处理打印
begin
for i,v in mrows(fproces,1) do
begin
doecho(v);
end
end
class function doecho(pid);//打印处理
begin
obj := fproces[pid];
if not(obj) then return ;
sg := SysWaitForSingleObject(pid,10);
if sg<>258 then //如果退出
begin
obj.ferrinfo := sg;
while true do //读完pip
begin
try
s := Sysexecreadpipe(pid);
except
s := 0;
end
if s then
begin
obj.doprocecho(obj,s);
end else //读完后删除对象
begin
del(pid);
break;
end
end
end else //没有退出
begin
s := Sysexecreadpipe(pid); //读一次
if s then
begin
obj.doprocecho(obj,s);
end
end
end
class function addto(obj,f);//添加
begin
id := obj.handle;
fproces[id] := obj;
fpends[id] := f;
obj.doonprocstart(obj,nil);
if length(fproces)=1 then
begin
ftm.start();
end
end
class function del(pid); //删除
begin
Sysexecdeletepipe(pid);
obj := fproces[pid];
//obj.ExecuteCommand("clearhandle",0);
obj.fprocesshandle := 0;
reindex(fproces,array(pid:nil));
reindex(fpends,array(pid:nil));
obj.doonprocend(obj,nil);
if length(fproces)<1 then ftm.stop();
end
private //静态存储变量
static ftm;
static fproces;
static fpends;
end
implementation
type TtoolbuttonActionLink=class(TControlActionLink)
{**
@explan(说明) 工具条按钮actionlink %%
**}
protected
procedure AssignClient(AClient);override;
begin
{**
@explan(说明)赋值control %%
@param(AClient)(TToolButton) %%
**}
if AClient is class(TcustomToolButton)then FClient := AClient;
end
function IsshortcutLinked();override;
begin
return FClient and(Action is CLASS(TCustomAction));
end
function IsCheckedLinked():Boolean;override;
begin
return false;
end
public
procedure SetShortCut(const Value:String);override;
begin
if IsshortcutLinked() then return FClient.ShortCut := Value;
end
function create(AOwner);override;
begin
inherited;
end
end
type TTipWnd=class(TCustomControl) //tip窗口
{**
@ignore(忽略) %%
**}
function Create(AOwner);override;
begin
inherited;
Visible := false;
WsPopUp := true;
Enabled := false;
color := 14743284;//rgb(244,246,224);
border := false;
FTip := "";
end
function ShowTip();
begin
if FTip then
begin
if Visible then return;
xy := array(0,0);
_wapi.GetCursorPos(xy);
//left := xy[0]+10;
//top := xy[1]+10;
show(SW_SHOWNOACTIVATE); //
SetBounds(xy[0]+10,xy[1]+10,FSize[0],FSize[1]);
end else
Visible := false;
end
Function Paint();override;
begin
dc := Canvas;
dc.DrawText(FTip,self.ClientRect,DT_LEFT .| DT_NOPREFIX);
end
property Tip read FTip write SetTip;
private
FTip;
function SetTip(s);
begin
if ifstring(s)and s <> FTip then
begin
FTip := s;
wh := GetTextWidthAndHeightWidthFont(s,seLF.font,1);
//width := wh[0]+5;
//height := wh[1]+5;
FSize := array(wh[0]+5,wh[1]+5);
end
end
private
FSize;
end
type tedoitem = class
function create(r,s,e,t);
begin
freason := r;
fstart := s;
fend := e;
ftext := t;
end
function clone();
begin
return new tedoitem(freason,FStart,fend,ftext);
end
freason; //操作
fstart; //开始位置
fend; //截止位置
ftext; //文本
end
type tedolist = class()
public
function create();
begin
flist := new tnumindexarray();
flockct := 0;
end
function citem(r,s,e,t);
begin
return new tedoitem(r,s,e,t);
end
function lock();
begin
flockct++;
end
function unlock();
begin
if flockct>0 then
begin
flockct--;
end
return flockct;
end
function push(it); //弹出
begin
if flockct then return 0;
if ifobj(it) then
begin
flist.push(it);
return 1;
end
end
function peak(); //获取
begin
len := flist.length();
if len>0 then
begin
return flist[len-1];
end
return nil;
end
function pop();
begin
if flockct=0 then
return flist.pop();
return 0;
end
function clear();
begin
if flockct then return ;
flist.splice(nil,nil,array());
flockct := 0;
end
function AddChange(r,s,e,t);
begin
if ifobj(r) then push(r.clone());
push(citem(r,s,e,t));
end
property locked read flockct;
private
flockct; //计数
flist; //链表
end
{$ifdef linux}
type _timerstruct = class(tslcstructureobj)
uses cstructurelib;
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(
array(
("id","intptr",0),
("flg","intptr",0)
),nil,nil,4);
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
end
function uitimerproc( p:pointer):integer;
begin
op := new _timerstruct(p);
unit(ugtkinterface)._gtk_add_time_msg_(0,op._getvalue_("flg"),op._getvalue_("id"),0x113);
return true;
end
{$else}
function uitimerproc(hwnd:pointer;message:integer;wparam:pointer;lparam:pointer):pointer;stdcall;
begin
return class(TCustomTimer)._timeproc_(hwnd,message,wparam,lparam);
end
{$endif}
function gettimerptr();
begin
global g_timer_proc;
if not g_timer_proc then
begin
g_timer_proc := makeinstance(thisfunction(uitimerproc));
end
return g_timer_proc;
end
function uinit();
begin
{$ifdef linux}
//class(tUIglobalData).uisetdata("G_T_TTIMER_",class(TCustomTimer));
{$endif}
class(tUIglobalData).uisetdata("G_T_TOOLBAR_",class(tcustomtoolbar));
end
function unuinit();
begin
global g_timer_proc;
if g_timer_proc then
begin
deleteinstance(g_timer_proc);
g_timer_proc := nil;
end
end
initialization
uinit();
finalization
unuinit();
end.
Reference in New Issue View Git Blame Copy Permalink