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

4657 lines
129 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
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
property Text read GetText write SetText;
property Bmp read GetBitmap write SetBitmap;
function publishs();override;
begin
return array("name","text","bmp");
end
{**
@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
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 FOntimeout;
private
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((datatype(FOntimer) = 7 )and FInterval)>0 then return-1;
if FStart then return FStart;
ret := _wapi.SetTimer(nil,Fid,FInterval,getwinprocptr(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
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;
function publishs();override;
begin
return array("name","interval","ontimer");
end
{**
@param(Interval)(integer) 设置运行间隔 %%
@param(Ontimer)(funtion[self,tuieventbase]) 定时调度 %%
@param(Enabled)(bool) 是否已经启动 %%
**}
end
type teditable=class(TSLUIBASE)
private
FInsertState;
FReadOnly;
FLineWrap;
FString;
FCaretX;
FLeftCharCount;
Flimitlength;
FSelBegin;
FSelLength;
FCanShowCaret;
FFontWidth;
FFontHeight;
FCaretY;
FMouseLbuttonDown;
FHafChar; //半个中文
FBorder;
//////////////////////
FHost; //
FHostDc;
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;
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));
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
if bytetype(FString,FCaretX)=1 then
begin
FString[(FCaretX):(FCaretX+1)]:= "";
end else
begin
FString[(FCaretX):(FCaretX)]:= "";
end
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();
begin
if FReadOnly then return;
if FSelLength <> 0 then return deletesel();
len := length(FString);
if FCaretX>1 then
begin
cx := FCaretX;
if bytetype(FString,FCaretX-1)=2 then
begin
FString[(FCaretX-2):(FCaretX-1)]:= "";
cx -= 2;
end else
begin
FString[(FCaretX-1):(FCaretX-1)]:= "";
cx--;
end
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 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 := rgb(200,150,150);
else dc.pen.color := rgb(180,180,180);
dc.brush.Color := FHost.Color;
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);
end
end
public
function create();
begin
Fplaceholdercolor := rgb(200,200,200);
fselbkcolor := rgb(51,153,255);
freadonlyColor := 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();
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 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
"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 FPassWordChar := pm[1];
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
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 WMKEYDOWN(o,e);virtual;
begin
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("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
c := e.CharCode;
case c of
VK_BACK:
begin
return dobackspace();
end
end
if c<32 then return;
if FReadOnly then return;
if c .& 0x80 then
begin
if FHafChar then
begin
InsertChar(FHafChar+e.char);
FHafChar := "";
end else
begin
FHafChar := e.char;
end
end else
InsertChar(e.char);
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;
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;
Fplaceholder := 0;
FHost := nil;
FFont := nil;
inherited;
end
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 Focusedborder read FFocusBorder write FFocusBorder;
private
FIsCaretShow;
FKillFocus;
FOnSetFocus;
FPassWordChar;
FMarked;
FOnMaxText;
FOnUpdate;
FOnChange;
Fplaceholder;
FSetFocused;
FFocusBorder;
Fplaceholdercolor;
fselbkcolor;
freadonlyColor;
static FCopyer;
end
type tVirtualCalender=class(TSLUIBASE)
{**
@explan(说明) 月历控件虚拟类
**}
function create();
begin
inherited;
FFont := new Tcustomfont();
FDateRows := 8;
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 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 := font;
if FHasMonthSel then
begin
dc.brush.color := 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 := rgb(240,240,250);
dc.fillrect(rec);
end
dc.font.weight := 700;
dc.drawtext(inttostr(FYear)+"年",rec,DT_CENTER);
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 := rgb(240,240,250);
dc.fillrect(rec);
end
dc.font.weight := 700;
dc.drawtext(inttostr(FMonth)+"月",rec,DT_CENTER);
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 := 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 := 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 := 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
public
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
return array(FLeft,FTop,FLeft+FCellWidth * 7,FTop+FHasMonthSel * FMonthselheight+FCellHeight * FDateRows+FHasToday * FTodayHeight);
end
function CalcDateMatrx();
begin
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(60,2,110,22);
FMonthRect := array(115,2,165,22);
end
if FHasToday then
begin
x := 7 * FCellWidth;
y := FDateRows * FCellHeight;
FTodyRect := array(0,y,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.5);
ch := integer(FCellHeight * 2);
for i := 1 to 12 do
begin
data := array();
divmod(i-1,4,a,b);
x0 := b * cw+10;
x1 := x0+cw;
y0 := a * ch+10;
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.5);
ch :=(FCellHeight);
for i,v in((FYear-13)->(FYear+14)) do
begin
data := array();
divmod(i,4,a,b);
x0 := b * cw+10;
x1 := x0+cw;
y0 := a * ch+10;
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 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;
Left := 10;
Top := 10;
//Ftextalign := 0;
Width := 80;
Height := 25;
FEditable := new TEntryEditable();
FEditable.host := self(true);
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 := ClientRect;
FEditable.ClientRect := rc;
end
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
CallMessgeFunction(FOnMaxText,self(true),new tuieventbase(0,0,0,0));
end
function DoChanged();
begin
CallMessgeFunction(FOnChange,self(true),new tuieventbase(0,0,0,0));
CallMessgeFunction(FOnUpdate,self(true),new tuieventbase(0,0,0,0));
end
function FontChanged(sender);override;
begin
inherited;
FEditable.font := Font;
end
function Recycling();override;
begin
inherited;
FOnUpdate := nil;
FOnChange := nil;
fonmaxtext := nil;
if FEditable then FEditable.Recycling();
FEditable := nil;
end
function publishs();override;
begin
return array("name","align","anchors","font","enabled","popupmenu","visible","height","width","left","top","text","placeholder"
,"readonly","limitlength","linewrap","tabstop","onmousemove","onpopupmenu","onmousedown","onmouseup","onkeyup"
,"onkeydown","onkeypress","onmaxtext","onkillfocus","onsetfocus","onchange");
end
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 readonly:bool read getReadOnly write setReadOnly;
property limitlength:integer read getlimitlength write setLimitLength;
property LineWrap:bool read getLineWrap write setLineWrap;
property placeholder:string read getplaceholder write Setplaceholder;
property Border 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 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
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
FOnUpdate;
FOnChange;
fonmaxtext;
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;
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 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 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 FEditable 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
//改变
FFontWidth := font.width;
for i,v in FEntrys do v.Font := font;
calcCtls();
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
r := integer(ClientRect[2]/GetXScrollDelta());
return r;
end
function GetClientYCapacity();virtual; //高度容量
begin
return integer(ClientRect[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;
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;
tp := ps[1];
bo := ps[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[3]:= rc[1]+DY;
return rc;
end
return array();
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 FontChanged(o);override;
begin
wd := font.width;
h := font.Height;
if h <> FFontHeight or wd <> FFontWidth then
begin
FFontHeight := h;
FFontWidth := wd;
UpDateScrollBar();
end
end
function GetItemCount();virtual;
begin
return FItemCount;
end
property ItemCount read GetItemCount write SetItemCount;
property ItemHeight read GetYScrollDelta;
{**
@param(ItemCount)(integer) 项数量 %%
**}
protected
function SetItemCount(n);override;
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 TcustomListBox=class(TCustomListBoxbase)
{**
@explan(说明) listbox控件 %%
**}
function Create(AOwner);override;
begin
inherited;
border := true;
FitemData := new tnumindexarray();
FSelBegin :=-1;
FSelEnd :=-1;
FMultisel := false;
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 CallMessgeFunction(FselectionChange,o,e);
end
inherited;
end
function MouseDown(o,e);override;
begin
if csDesigning in ComponentState 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) 画布 %%
**}
PaintIdxBkg(idx,rc,cvs);
PaintIdexText(idx,rc,cvs);
end
function PaintIdexText(idx,rc,cvs);virtual;
begin
cvs.DrawText(getItemText(idx),rc,DT_NOPREFIX);
end
function getCurrentSelection();virtual;
begin
{**
@explan(说明)获取当前选中项的索引，仅用于单选的列表框%%
**}
if FMultisel=0 then
begin
return FSelBegin;
end
return-1;
end
function setCurrentSelection(n);virtual;
begin
{**
@explan(说明)设置当前选中项的索引，仅用于单选的列表框%%
@param(n)(integer)%%
**}
if FMultisel=1 then
begin
if isValidIndex(n)then
begin
FSelBegin := FSelEnd := n;
InvalidateRect(nil,false);
end else
if ifarray(n)and isValidIndex(n[1])and isValidIndex(n[0])then
begin
FSelBegin := MinValue(n);
FSelEnd := MaxValue(n);
end
return;
end else
if FMultisel=2 then
begin
FMultisel3Data := array();
if isValidIndex(n)then
begin
FMultisel3Data[n]:= true;
end else
if ifarray(n)then
begin
for i,v in n do
begin
if isValidIndex(v)then
begin
FMultisel3Data[v]:= true;
end
end
end
return;
end
if not isValidIndex(n)or n=FSelBegin then return;
SelRange(false);
FSelBegin := FSelEnd := n;
SelRange(true);
CallMessgeFunction(FselectionChange,self(true),new tuieventbase(0,0,0,0));
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 reindex(FMultisel3Data,array(n:nil));
CallMessgeFunction(FselectionChange,self(true),new tuieventbase(0,0,0,0));
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);
class(TCustomListBoxbase).ItemCount := FitemData.length();
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 findStrBeginwith(str,b,n);virtual;
begin
{**
@explan(说明)在列表框中指定项之后查找以字符串开头的项，到达末尾即从头开始%%
@param(str)(string)给定字符串%%
@param(b)(bool)1:不区分大小写，0:区分大小写%%
@param(n)(integer)指定项下标，默认为-1%%
@return(integer)返回找到的项的下标，未找到则返回-1%%
**}
if ifnil(b)then b := 0;
if ifnil(n)then n :=-1;
if CheckListItem(str)and ifnumber(n)then
begin
if not isValidIndex(n)then n :=-1;
if b then
begin
return findBeginwithCaseIndepent(str,n);
end else
return findBeginwith(str,n);
end
ShowErrorMessage("function findStrBeginwith:ErrorParameter(s)");
return-1;
end
function findStrExact(str,b,n);virtual;
begin
{**
@explan(说明)在列表框中指定项之后查找与字符串相同的项，到达末尾即从头开始%%
@param(str)(string)给定字符串%%
@param(b)(bool)1:不区分大小写，0:区分大小写，默认为0%%
@param(n)(integer)指定项下标，默认为-1%%
@return(integer)匹配项的索引，查找失败则返回-1%%
**}
if ifnil(b)then b := 0;
if ifnil(n)then n :=-1;
if CheckListItem(str)and ifnumber(n)then
begin
if not isValidIndex(n)then n :=-1;
if b then return findExactCaseIndepent(str,n);
else return findExact(str,n);
end
ShowErrorMessage("function findStrExact:ErrorParameter(s)");
return-1;
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());
cleanAllSelectedState();
class(TCustomListBoxbase).ItemCount := 0;
end
function Recycling();override;
begin
FselectionChange := nil;
return inherited;
end
property ItemCount read GetItemCount;
property Multisel:bool read FMultisel write SetMultisel;
property onSelectionChange:eventhandler read FselectionChange write FselectionChange;
property Items:strings read GetData write setData;
function publishs();override;
begin
return array("name","caption","anchors","align","enabled",
"font","visible","border","color",
"height","width","left","top","items",
"multisel","popupmenu","wsdlgmodalframe",
"onmousedown","onmouseup",
"onselectionchange"
);
end
protected
function CheckListItems(s);
begin
if ifarray(s)then
begin
for i := 0 to length(s)-1 do if not CheckListItem(s[i])then return 0;
return 1;
end else
return 0;
end
function CheckListItem(s);virtual;
begin
{**
@explan(说明) 项检查,重写该方法可以控制项的类型 %%
**}
return ifstring(s);
end
function isValidIndex(n);
begin
return(n >= 0)and n<FitemData.length();
end
FitemData;
{**
@explan(说明)(TMyarrayB) list数据数据,不要试图修改该变量
**}
private
function PaintIdxBkg(idx,rc,cvs);
begin
if(idx >= min(FSelBegin,FSelEnd)and idx <= max(FSelBegin,FSelEnd))or(FMultisel=2 and FMultisel3Data[idx])then
begin
cvs.brush.Color := rgb(204,231,255);
end else
cvs.Brush.Color := Color;
cvs.FillRect(rc);
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 findBeginwith(str,n);
begin
len := class(TCustomListBoxbase).ItemCount;
while i++<> len do if AnsiStartsStr(str,getItem((i+n)%len))then return(i+n)%len;
return-1;
end
function findBeginwithCaseIndepent(str,n);
begin
len := class(TCustomListBoxbase).ItemCount;
while i++<> len do if AnsiStartsText(str,getItem((i+n)%len))then return(i+n)%len;
return-1;
end
function findExact(str,n);
begin
len := class(TCustomListBoxbase).ItemCount;
while i++<> len do if getItem((i+n)%len)=str then return(i+n)%len;
return-1;
end
function findExactCaseIndepent(str,n);
begin
len := class(TCustomListBoxbase).ItemCount;
while i++<> len do if UpperCase(getItem((i+n)%len))=UpperCase(str)then return(i+n)%len;
return-1;
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 CallMessgeFunction(FselectionChange,self(true),nil);
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 CallMessgeFunction(FselectionChange,self(true),nil);
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 CallMessgeFunction(FselectionChange,self(true),nil);
end
// FselectionCancel;
FselectionChange;
FSelBegin;
FSelEnd;
FIsMouseDown;
FMultisel;
FMultisel3Data;
FFormerSelBegin;
FFormerSelEnd;
end
type TCustomComboBoxbase=class(TCustomControl)
{**
@explan(说明) combox 基类 %%
**}
function Create(AOwner);override;
begin
inherited;
FBtnWidth := 20;
FmaxListItemShow := 10;
FScreenRect := _wapi.GetScreenRect();
FListBox := CreateAlist();
if FListBox is class(TWinControl)then
begin
//FListBox.Parent := self(true);
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 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>FBtnRect[0]and x<FBtnRect[2]and y>FBtnRect[1]and y<FBtnRect[3]then
begin
ShowDropDown(true);
end
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
SetListBoxRect();
FListBox.OnActivate := thisfunction(ListActivate);
FListBox.show(5);
CallMessgeFunction(ondropdown,self(true),e);
end else
if not(flg)and FListBox.Visible then
begin
FListBox.Visible := false;
CallMessgeFunction(oncloseup,self(true),e);
end
end
function Recycling();override;
begin
FListBox := nil;
FOnSelchanged := nil;
Foncloseup := nil;
Fondropdown := nil;
inherited;
end
published
property ItemIndex:lazyinteger 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 maxListItemShow read FmaxListItemShow write SetmaxListItemShow;
{**
@param(ItemIndex)(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;
FListbox.height := FListBox.ItemHeight * (min(max(0,FListBox.ItemCount),FmaxListItemShow))+10;
nrc := ClientToScreen(rc[0],rc[3]);
if FScreenRect[3]-nrc[1]<250 then
begin
nrc[2]:= width+nrc[0];
nrc[3]:= nrc[1]-height;
nrc[1]:= nrc[3]-FListBox.Height;
end else
begin
nrc[2]:= width+nrc[0];
nrc[3]:= FListBox.Height+nrc[1];
end
FListBox.SetBoundsRect(nrc);
end
FListBox;
private
FmaxListItemShow;
FScreenRect; //桌面区域
FBtnRect; //按钮区域
FOnSelchanged; //选择改变
Fondropdown; //下拉
Foncloseup; //收起
FBtnWidth;
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 GetItemIndex();virtual;
begin
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
public
function create(AOwner);override;
begin
inherited;
FEdit := new TcustomEdit(self);
FEdit.OnKeyDown := function(o,e)
begin
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 not o.Readonly then
begin
CallMessgeFunction(Foneditchanged,o,e);
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.onselectionchange := function(o,e);
begin
FEdit.Text := getCurrentItemText();
ShowDropDown(false);
CallMessgeFunction(OnSelchanged,self,true);
end
FEdit.Readonly := Freadonly;
FListBox.parent := self;
FEdit.parent := self;
end
function CreateAlist();override;
begin
r := new TComboListBox(self);
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) 子项字符串 %%
**}
return getItemText(FListBox.GetCurrentSelection());
end
property readonly:bool read Freadonly write setReadOnly;
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])文本被改变回调,文本显示后调用%%
**}
function publishs();override;
begin
return array("name","font","border",
"visible","anchors","align","enabled",
"height","width","left","top",
"readonly","itemindex",
"items","oncloseup","ondropdown","onselchanged","oneditchanged","oneditupdate");
end
function setReadOnly(v);
begin
nv := v?true:false;
if nv <> Freadonly then
begin
Freadonly := nv;
FEdit.Readonly := nv;
end
end
private
function GetItemIndex();override;
begin
return FListBox.GetCurrentSelection();
end
function SetItemIndex(idx);override;
begin
return FListBox.SetCurrentSelection(idx);
end
FTextHeight;
FItemHeight;
Freadonly;
Foneditchanged;
FoneditUpdate;
Fonkillfocus;
Fonsetfocus;
FEdit;
function setItems(d);
begin
return FListBox.SetData(d);
end
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 csDesigning in ComponentState then return;
if Enabled and Visible then
begin
if d=ShortCut then
begin
DoOnClick(self,new tuieventbase(0,0,0,0));
return "havedoshortcut";
end
end
end
end
function DoOnClick(o,e);virtual;
begin
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 publishs();override;
begin
return array("name","caption","enabled","imageid","visible","onclick");
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;
FCaption := ""; //标题
FOnClick := nil; //点击
FImageId :=-1; //imageid
FEnabled := true; //有效 可以点击
FVisible := true; //可见
end
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;
{**
@param(OnClick)(function[o:TToolButton;e:tuieventbase]) 点击消息 %%
@param(Caption)(string) 标题 %%
@param(ImageId)(integer) 图标id %%
@param(Enabled)(bool) 是否有效 %%
@param(Visible)(bool) 是否可见 %%
**}
private
FShortCut;
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;
end
end
function SetEnabled(v);
begin
nv := v?true:false;
if nv <> FEnabled then
begin
FEnabled := nv;
if FToolbar then FToolbar.BtnChanged();
end
end
function SetVisible(v);
begin
nv := v?true:false;
if nv <> FVisible then
begin
FVisible := nv;
if FToolbar then FToolbar.BtnChanged();
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 FToolbar.BtnChanged(); //FToolbar.InvalidateRect(nil,false);
end
end
private
FCaption; //标题
FOnClick; //点击
FCommandId; //command id 可以不要
FImageId; //imageid
FEnabled; //有效 可以点击
FVisible; //可见
FToolbar; //工具栏
FWillAddbar;
FActionLink;
end
type TcustomToolBar=class(TCustomControl)
{**
@explan(说明) 工具栏控件 %%
**}
function Create(AOwner);override;
begin
inherited;
height := 34;
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 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(FButtons[FMouseDownIdx].Enabled)then
begin
FMouseDownIdx :=-1;
return;
end
InvalidateRect(nil,false);
end
end
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 := FButtons[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;
FTimer.Start();
end
function CNALIGN(o,e):CN_ALIGN;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
st := FButtons[idx].ShortCut;
FTipWnd.Tip := FButtons[idx].Caption+(st?(" ("+st+")"):"");
FTipWnd.ShowTIp();
end
end else
begin
EndShowWnd();
end
end
function AddButton(btn);
begin
{**
@explan(说明) 添加工具栏项%%
**}
InsertButton(btn);
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) 区域 %%
**}
idx := IndexOfBtn(btn);
if idx >= 0 then
begin
return FBtnRects[idx];
end
end
function IncPaintLock(); //锁定刷新
begin
{**
@explan(说明) 锁定绘制,和 DecPaintLock() 成对使用 %%
**}
BeginUpdate();
end
function DecPaintLock(); //释放刷新
begin
{**
@explan(说明) 取消绘制锁定,和 IncPaintLock() 成对使用 %%
**}
EndUpdate();
end
function CalcHeightFixWidth(w);
begin
{**
@explan(说明) 固定宽度计算工具栏高度 %%
@param(w)(integer) 给定宽度 %%
@return(intger) 计算的高度 %%
**}
bw := 0;
if WSSizebox then
begin
bw := 16;
end else
if WsDlgModalFrame then
begin
bw := 6;
end else
if Border then bw := 2;
imglst := ImageList; //图标
imgw := 36;
imgh := 36;
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 then
begin
bw := 16;
end else
if WsDlgModalFrame then
begin
bw := 6;
end else
if Border then bw := 2;
imglst := ImageList; //图标
imgw := 36;
imgh := 36;
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 Paint();override;
begin
c := canvas;
for i := 0 to FButtons.length()-1 do
begin
bi := FButtons[i];
if not(bi.Visible)then continue;
ci := FBtnRects[i];
if not ifarray(ci)then return;
if FMouseDownIdx=i then
begin
c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONCHECK);
end else
c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH);
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();
end
end
inherited;
end
function DoControlAlign();override;
begin
CalcButtonsRect();
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 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;
end
function BtnChanged();
begin
CalcButtonsRect();
InvalidateRect(nil,false);
end
function publishs();override;
begin
return array("name","align","caption","enabled","font","left","top","width","height",
"visible","imagelist");
if Align <> alNone then
begin
return array("name","align","caption","enabled","font",
"visible","imagelist");
end else
return array("name","align","caption","enabled","font","left","top","width","height",
"visible","imagelist");
end
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 Parent then
begin
Parent.DoControlAlign();
CalcButtonsRect();
InvalidateRect(nil,false);
end
end
private
function EndShowWnd();
begin
FShowTimeIndexA :=-1;
FTimer.Stop();
FTipWnd.Visible := false;
end
function CalcButtonsRect();
begin
if(IsUpDating())then
begin
FWillModifyToolbar := true;
return;
end
imglst := ImageList; //图标
imgw := 36;
imgh := 36;
if imglst is class(TCustomImageList)then
begin
imgw := imglst.Width+4;
imgh := imglst.height+4;
end
rc := ClientRect;
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
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
y := 0;
x += imgw+1;
end else
begin
y := 0;
x += imgw+1;
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
y += imgh+1;
rct := 1;
end
end else
begin
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
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
x := 0;
y += imgh+1;
end else
begin
x := 0;
y += imgh+1;
FBtnRects[i]:= array(x,y,x+imgw,y+imgh);
x += imgw+1;
rct := 1;
end
end else
begin
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 FButtons.length()-1 do
begin
ri := FBtnRects[i];
if ri and pointinrect(p,ri)then
begin
return i;
end
end
return-1;
end
FShowLoked;
FBtnRects;
FButtons;
FTipWnd;
FShowtimeIndexA;
FTimer;
FCurrentPos;
FMouseDownIdx;
FWillModifyToolbar;
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;
FOnIncrease;
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
type TSpinCEdit=class(tedit)
function create(AOwner);override;
begin
inherited;
border := false;
caption := "0";
end
function SetDesigning(f,fc);
begin
if f then Enabled := false;
else Enabled := true;
end
end
FChar;
protected
function UpdateControl();virtual;
begin
FEdit.Text := inttostr(FValue);
end
function GetValue();virtual;
begin
if FEdit.HandleAllocated()then
begin
r := FEdit.text;
r := StrToIntDef(r,FValue);
if r <> FValue then
begin
FValue := r;
end
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(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
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 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 := class(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 TSpinCEdit(self);
FEdit.OnKeyPress := thisfunction(editkeypress);
FEdit.parent := self;
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.OnKeyPress := nil;
inherited;
end
function DoControlAlign(rect);override;
begin
rect := ClientRect;
FEdit.SetBounds(0,0,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 MouseDown(o,e);override;
begin
if FCI=CI_DOWN then
begin
doDcrease(o,e);
//InValidateRect(nil,false);
end else
if FCI=CI_UP then
begin
doIncrease(o,e);
//InValidateRect(nil,false);
end
end
function MouseMove(o,e);override;
begin
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;
end
end
function paint();override;
begin
DrawItem(CI_UP,CIS_NONE);
DrawItem(CI_DOWN,CIS_NONE);
end
property OnIncrease:eventhandler read FOnIncrease write FOnDecrease;
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
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 := 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
initialization
{$ifdef linux}
class(tUIglobalData).uisetdata("G_T_TTIMER_",class(TCustomTimer));
{$endif}
end.
Reference in New Issue View Git Blame Copy Permalink