type tcontrol = class(tcomponent) {** @explan(说明) 界面控件基类 %% @date(20220509) %% **} ///////////平台判断//////// {$ifdef linux} {$define gtkpaint} {$define linuxgtk} {$else} {$define gdipaint} {$endif} uses utslvclauxiliary,utslvclmemstruct,utslvclevent,utslvclgdi,utslvclaction,utslvclmenu; private //私有变量 #!begin //members STATIC FSIDC; //控件id生成器 FActionLink: TControlActionLink; FCanvas: TCanvas; //为可视控件提供画板 [weakref]FMessagehandle;//消息表 FtagPAINTSTRUCT; //绘制区域 FAnchors; fautosize; fautosizing; FAnchorBounds; FCaption;//标题 FCaptureMouseButtons;//鼠标样式 FColor;//颜色 FBKBitmap; //背景图片 FControlFlags;//控件标记 FControlStyle;//控件样式 //FDesktopFont; //FDockOrientation; FDragCursor; FFont; //字体 FBorder; //边框 //FHostDockSite: TWinControl; //FLastDoChangeBounds: TRect; //FLastDoChangeClientSize: TPoint; //FLastResizeClientHeight: integer; //FLastResizeClientWidth: integer; //FLastResizeHeight: integer; //FLastResizeWidth: integer; weakref FOnClick; //点击 Fonrclick; FOnContextPopup; FOnDblClick; //双击 FOnDragDrop; FOnDragOver; FOnSize; FOnMove; //FOnEditingDone; FOnEndDock; FOnEndDrag; FOnMouseDown; //按下 FOnMouseEnter; //进入 FMouseEntereded; FOnMouseLeave; //离开 FOnMouseMove; //移动 FOnPopupMenu; FOnMouseUp; //弹起 FOnMouseWheel; //滚动 FOnMouseWheelDown; //滚动按下 FOnMouseWheelUp; //滚动弹起 //FOnQuadClick; //FOnResize; // FOnShowHint; FOnStartDock; FOnStartDrag; fonfontchanged; //FOnTripleClick; autoref protected //可以重写的函数以及使用的成员变量 //对齐 FAlign;//对齐方式 FUnAlignBounds; [weakref]FParent;// TWinControl; //父节点 //FParentBiDiMode;//: Boolean; FPopupMenu;//: TPopupMenu; //FIsControl;//: Boolean; //FShowHint;//: Boolean; FParentColor;//: Boolean; FParentFont;//: Boolean; //FParentShowHint;//: Boolean; //FAutoSizingAll;//: boolean; //FAutoSizingSelf;//: Boolean; FEnabled;//: Boolean; //有效 //FMouseEntered;//: boolean; FVisible;//: Boolean; //可见 FID; //id #!end //位置信息 FLeft:integer; //左边 FTop:integer;//: Integer; //上 FWidth:integer; FHeight:integer; //高度 FControls; //子控件 FControlState; //状态 FCursor; //鼠标 {** @param(FLeft)(integer) 左边 %% @param(FTop)(integer) 上边 %% @param(FWidth)(integer) 宽度 %% @param(FHeight)(integer) 高度 %% **} function SetAction(Value);virtual; begin if csDesigning in ComponentState then begin FActionLink := Value; return; end 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 function getparenttype(); begin return class(TWinControl); end procedure DoActionChange(Sender:TObject); begin if Sender=Action then ActionChange(Sender,False); end function GetAction();virtual; begin if csDesigning in ComponentState then begin return FActionLink; end if FActionLink then begin return FActionLink.Action; end end function SetEnabled(v);virtual; begin nv := v?true:false; if FEnabled <> nv then begin FEnabled := nv; end end procedure SetAlign(Value:TAlign);virtual; begin if not(Value in array(alLeft,alRight,alBottom,alTop,alNone,alClient))then exit; if FAlign=Value then exit; oalign := FAlign; //旧对齐方式 FAlign := Value; //调其兄弟节点的位置 %% if (FParent is getparenttype()) and FParent.HandleAllocated()then begin if (FAlign=alNone) or (oalign = alNone) then begin if oalign=alClient then //恢复原有 begin bds := UnAlignBounds; SetBounds(bds[0],bds[1],bds[2]-bds[0],bds[3]-bds[1]); end else //保存现在 begin FUnAlignBounds := BoundsRect; end end FParent.DoControlAlign(); //调整位置 end end function setautosize(v); begin nv := v?true:false; if nv=fautosize then return ; fautosize := nv; if nv and NoRecycled() then AdjustSize(); end procedure SetAnchors(Value);virtual; begin if not ifarray(Value)then exit; if FAnchors=Value then exit; FAnchorBounds := 0; val := Value union2 array(); aks := array(akLeft,akRight,akTop,akBottom); for i,v in val do begin if not(v in aks)then exit; end FAnchors := val; end function SetParentFont(v:bool);virtual; begin nv := v?true:false; if FParentFont <> nv then begin ft1 := Font; if ft1 then ft1 := ft1.fontinfo(); FParentFont := nv; nft := Font; ft2 := nft; if ft2 then ft2 := ft2.fontinfo(); if ft1 and ft2 and (ft1<>ft2) then begin r2 := nft.changedkeys((ft2 .<> ft1)); FontChanged(); end return 1; end end function SetParentcolor(v:bool);virtual; begin nv := v?true:false; if FParentColor <> nv then begin FParentColor := nv; return 1; end end private //位置,大小,对齐等属性设置函数 function SetUnAlignBounds(Value); begin {** @explan(说明) 设置非对齐的范围 %% **} if(align in array(alTop,alLeft,alRight,alBottom,alClient))then exit; if CheckArrayIsControlBounds(Value)and FUnAlignBounds <> Value then begin FUnAlignBounds := Value; if parent and(Align <> alNone)and Parent.HandleAllocated()then Parent.DoControlAlign(); end end Function GetUnAlignBounds();virtual; //type_tcontrol begin {if alNone=FAlign then begin FUnAlignBounds := GetBoundsRect(); end} if not ifarray(FUnAlignBounds)then FUnAlignBounds := GetBoundsRect(); return FUnAlignBounds; end function GetEnabled();virtual; begin return FEnabled; end procedure SetLeft(Value:Integer); //type_tcontrol begin if Value>-5000000 and Value<5000000 and Value <> FLeft then SetBounds(Value,FTop,FWidth,FHeight); end procedure SetTop(Value:Integer); //type_tcontrol begin if Value>-5000000 and Value<5000000 and Value <> FTop then SetBounds(FLeft,Value,FWidth,FHeight); end procedure SetWidth(Value:Integer); //type_tcontrol begin if Value>-5000000 and Value<5000000 and Value <> FWidth then SetBounds(FLeft,FTop,Max(0,Value),FHeight); end procedure SetHeight(Value:Integer); //type_tcontrol begin if Value>-5000000 and Value<5000000 and Value <> FHeight then SetBounds(FLeft,FTop,FWidth,Max(0,Value)); end function GetText(); //type_tcontrol begin return RealGetText(); end procedure SetText(Value:string); //type_tcontrol begin return RealSetText(Value); end public function PaintStruct(); begin {** @explan(说明) 获取绘制消息结对象 %% @return(TPAINTSTRUCT) 包含绘制 **} if not FtagPAINTSTRUCT then begin FtagPAINTSTRUCT := new TPAINTSTRUCT(); end return FtagPAINTSTRUCT; end function bindmessage(id,func); //绑定事件 begin {** @ignore 忽略 %% @explan(说明) 绑定处理函数到消息id %% **} if not ifarray(FMessagehandle)then FMessagehandle := array(); if ifnumber(id)and (iffuncptr(func))then FMessagehandle[id]:= func; end private //事件绑定处理 static FClassDigestA; class function CtlInfoAndDigest(idx,d); //通过类的指纹保存或者获取控件信息 begin if not ifarray(FClassDigestA)then FClassDigestA := array(); if ifnil(d)then return FClassDigestA[idx]; else FClassDigestA[idx]:= d; end function FindMessageFunctionstr(o);virtual; //type_tcontrol begin { @explan(说明) 自动绑定消息函数到消息id %% } if not(o is class(tcontrol))then return array(); t := o.classinfo; idx := getmsgd_Crc32(tostm(t,0,1))+"%%"; r := CtlInfoAndDigest(idx); if ifarray(r)then return r; r := array(); hs := t["inherited"]; for i,v in hs do begin //sbf := static call(thisfunction,findclass(v,o)) name v+"%%_%%"; sbf := call(thisfunction,findclass(v,o)); for ii,vv in sbf do begin r[ii]:= vv; end end for i,v in t["subs"] do begin if v["access"]in array(2,3)then continue; fstring := v["functionname"]; if not ifstring(fstring)then continue; //f := findfunction(fstring,o); returntype := v["returntype"]; try if returntype then begin mid := invoke(o,returntype); r[mid]:= fstring; //bindmessage(mid,f); end except end end CtlInfoAndDigest(idx,r); return r; end function bindmessages(o);virtual; //type_tcontrol begin { @explan(说明) 自动绑定消息函数到消息id %% } s := FindMessageFunctionstr(o); for i,v in s do begin bindmessage(i,findfunction(v,o)); end end function preparesetparent(np); begin if (np is getparenttype()) then begin if not CheckNewParent(np) then return ; if not np.checknewchild(self(true)) then return ; end SetParent(np); end protected //部分属性设置 function GetControlFont();virtual; begin if ParentFont and Parent then return Parent.font; return FFont; end function SetControlFont(v);virtual; begin //if ParentFont and Parent then return ; //如果使用父节点的字体,那么字体无效 if ifarray(v)then begin FFont.SetValues(v); end else if v is class(Tcustomfont)then begin FFont.copyfont(v); end end function SetBorder(v);virtual; begin FBorder := v?true:false; end function SetZorder(n); begin f := Parent; if f is getparenttype() then begin return f.MoveControlOrder(self,n); end end function GetZorder(); begin f := Parent; if f is getparenttype()then begin return f.Controls.indexof(self); end end function RealGetText():TCaption;virtual; //标题 begin return FCaption; end procedure RealSetText(Value:TCaption);virtual; //标题 begin FCaption := Value; end #!begin //资源处理 function GetCursor();virtual; //鼠标 begin return FCursor; end procedure SetCursor(Value);virtual;//鼠标 begin if(FCursor is class(tcustomcursor))and ifnumber(Value)and FCursor.id <> Value then begin FCursor.id := Value; Perform(new tuieventbase(CM_CURSORCHANGED,0,0)); end; end procedure SetVisible(Value);virtual; //可见 begin FVisible := Value?true:false; end #!end protected //消息对象以及坐标 function messagecreater(hwnd,message,wparam,lparam);virtual; ////构造消息对象 begin {** @explan(说明)根据消息参数构造消息对象; **} if message in array(WM_MOUSEMOVE,WM_LBUTTONDOWN, WM_RBUTTONDOWN,WM_LBUTTONUP, WM_RBUTTONUP,WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK,WM_MBUTTONDOWN,WM_MBUTTONUP,WM_MBUTTONDBLCLK)then begin r := new TMMouse(message,wparam,lparam,hwnd); end else if message=WM_MENUSELECT then begin r := new TMMENUSELECT(message,wparam,lparam,hwnd); end else if message=WM_MEASUREITEM then begin r := new TMMEASUREITEM(message,wparam,lparam,hwnd); end else if message in array(WM_KEYDOWN,WM_KEYUP,WM_CHAR,WM_SYSCHAR,WM_SYSKEYDOWN,WM_SYSKEYUP)THEN begin r := new TMKEY(message,wparam,lparam,hwnd); end else if message=WM_DRAWITEM then begin r := new TMDRAWITEM(message,wparam,lparam,hwnd); end else if message=WM_NOTIFY then begin r := new TMNOTIFY(message,wparam,lparam,hwnd); end else if message=WM_MOUSEWHEEL then begin r := new TMMOUSEWHEEL(message,wparam,lparam,hwnd); end else if message=WM_STYLECHANGED or message=WM_STYLECHANGING then begin r := new TMSTYLECHANG(message,wparam,lparam,hwnd); end else r := new tuieventbase(message,wparam,lparam,hwnd); return r; //return new tuieventbase(message,wparam,lparam,hwnd); end function GetClientOrigin();virtual; ////坐标 begin if FParent then base := FParent.ClientOrigin(); return array(base[0]+FLeft,base[1]+FTop); end function GetLogicalClientRect();virtual; //坐标 begin return GetClientRect(); end; function GetClientScrollOffset();virtual; //坐标 begin return array(0,0); end function GetScrolledClientRect();virtual; //坐标 begin Result := GetClientRect(); ScrolledOffset := GetClientScrollOffset(); Result[0]+= ScrolledOffset[0]; Result[1]+= ScrolledOffset[1]; Result[2]+= ScrolledOffset[0]; Result[3]+= ScrolledOffset[1]; return Result; end; function GetControlOrigin();virtual; //坐标 begin Result := array(FLeft,FTop); if FParent <> nil then begin ParentsClientOrigin := FParent.ClientOrigin(); Result[0]+= ParentsClientOrigin[0]; Result[1]+= ParentsClientOrigin[1]; end; return Result; end function ControlAppended(AControl);virtual;//添加控件 begin {** @explan(说明) 子控件添加 %% **} //if AControl and AControl.ParentFont then AControl.FontChanged(); end function ControlDeleted(AControl);virtual;//子控件被删除 begin {** @explan(说明) 子控件删除 %% **} end function operatectrl(actrl,op); //控件操作通知 begin idx := FControls.indexof(actrl); if op=opRemove then begin if(idx >= 0)then begin FControls.deli(idx); aparent := actrl.FParent; actrl.FParent := nil; ControlDeleted(actrl); //if (actrl.Align<>alNone) and (aparent is class(TWincontrol)) then aparent.DoControlAlign(); ifop := true; if NoRecycled() then AdjustSize(); end end else if op=opInsert then begin if idx=-1 then begin setft := false; if actrl.ParentFont then begin ft := font; if ft then fts := ft.fontinfo(); ft := actrl.Font; nft := ft; if ft then ftc := ft.fontinfo(); setft := (fts and ftc and (fts <> ftc)); end wkactl := makeweakref(actrl); FControls.append(wkactl); actrl.FParent := self(true); ControlAppended(wkactl); if setft then begin nft.changedkeys((fts .<> ftc)); wkactl.FontChanged(); end ifop := true; end end return ifop; end function SetParent(NewParent);virtual; //设置父控件 begin //1.为窗口类 //2.可以作为父窗口 //3.调用api 可以成功 if NewParent=self then return; if NewParent=FParent then return; if NewParent is getparenttype() then begin if FParent and (objectstate(fParent) in array(1,2,3)) then begin FParent.operatectrl(self(true),opRemove); end np := NewParent.Parent; while np is getparenttype() do begin if np=self then return; np := np.Parent; end NewParent.operatectrl(self(true),opInsert); end else begin if FParent and (objectstate(fParent) in array(1,2,3)) then FParent.operatectrl(self(true),opRemove); end end procedure SetParentComponent(NewParentComponent);override; //设置父窗口 begin SetParent(NewParentComponent); end protected //大小改变 //procedure UpdateMouseCursor(X, Y: integer); begin end procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);virtual; //边界改变 begin if ALeft=-32000 or ATop = -32000 then exit ; SizeChanged :=(FWidth <> AWidth)or(FHeight <> AHeight); PosChanged :=(FLeft <> ALeft)or(FTop <> ATop); if(not SizeChanged)and(not PosChanged)then Exit; // d := new ttagWINDOWPOS(); d := new tvclwindowpos_class(0); if SizeChanged then begin d.cx := AWidth; d.cy := AHeight; D.flags := SWP_NOMOVE; e := new tuieventbase(WM_WINDOWPOSCHANGED,0,d._getptr_); class(tcontrol).wndproc(e); e := new tuieventbase(WM_SIZE,0,makeposition(AWidth,AHeight)); class(tcontrol).wndproc(e); end if PosChanged then begin d.x := ALeft; d.y := ATop; d.flags := SWP_NOSIZE; e := new tuieventbase(WM_WINDOWPOSCHANGED,0,d._getptr_); class(tcontrol).wndproc(e); e := new tuieventbase(WM_MOVE,6,makeposition( ALeft,ATop)); class(tcontrol).wndproc(e); end {if SizeChanged or PosChanged then begin if (Parent is class(TWinControl)) and Parent.HandleAllocated then begin Parent.DoControlAlign(); end end } end function MouseHover(o,e);virtual; begin if not FMouseEntereded then begin DoMouseEnter(o,e); FMouseEntereded := true; end end function MouseLeave(o,e);virtual; begin if FMouseEntereded then begin DoMouseLeave(o,e); FMouseEntereded := false; end end function defaulthandler(e);virtual; begin return 0; end public //鼠标事件 function MouseMove(o,e);virtual; begin end function MouseDown(o,e);virtual; begin {** @explan(说明) 鼠标按下消息 %% @param(o)(TWinControl) 控件自身 %% @param(e)(TMMouse) 消息 %% **} end function MouseUp(o,e);virtual; begin {** @explan(说明) 鼠标松开消息 %% @param(o)(TWinControl) 控件自身 %% @param(e)(TMMouse) 消息 %% **} end function ContextMenu(o,e);virtual; begin {** @explan(说明) 右键菜单 %% @param(o)(TWinControl) 控件自身 %% @param(e)(tuieventbase) 消息 %% **} if e.Result then exit; if FPopupMenu is class({TcustomPopupmenu}TcustomMenu) then begin uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON; _wapi.TrackPopupMenu(FPopupMenu.Handle,uf,e.lolparamsigned,e.hilparamsigned,0,e.wparam,nil); e.skip := true; end end public//通知 function Notification(AComponent:TComponent;Operation:TOperation);override; //通知 begin {** @explan(说明) 通知消息处理 %% **} if Operation=opRemove then begin if AComponent=PopupMenu then PopupMenu := nil ; else if AComponent=Action then Action := nil; idx := FControls.indexof(AComponent); //删除子控件 if idx >= 0 then begin FControls.deli(idx); end end; inherited; end; procedure FontChanged(Sender:TObject);virtual; begin //if parent then parent.FontChanged(Sender); e := new tuieventbase(); CallMessgeFunction(fonfontchanged,self(true),e); ft := Font; if ft then begin ks := ft.changedkeys(); if ks["width"] or ks["height"] then AdjustSize(); end end function GetClientRect();virtual; // //type_tcontrol visual size of client area begin {** @explan(说明) 获取客户区%% @return( array of integer) 左上右下 %% **} return array(0,0,FWidth,Height); end #!begin //消息处理 function DoCNCOMMAND(o,e);virtual; begin {** @explan(说明) 通知消息 %% @param(o)(tcontrol) 控件自身 %% @param(e)(tuieventbase) 消息 %% **} end function CNCOMMAND(o,e):CN_COMMAND;virtual; begin DoCNCOMMAND(o,e); end function DoMouseEnter(o,e);virtual; begin { @explan(说明) 鼠标进入控件回调 %% } CallMessgeFunction(FOnMouseEnter,o,e); end function DoMouseLeave(o,e);virtual; begin { @explan(说明) 鼠标离开控件回调 %% } CallMessgeFunction(FOnMouseLeave,o,e); end function DoCnNotify(o,e);virtual; begin {** @expaln(说明) 父窗口通知回调 %% **} end function CNNOTIFY(o,e):CN_NOTIFY;virtual; begin DoCnNotify(o,e); end function WMERASEBKGND(o,e):WM_ERASEBKGND;virtual; begin end function WMCancelMode(o,e):LM_CANCELMODE;virtual; begin end function WMContextMenu(o,e):LM_CONTEXTMENU;virtual; begin CallMessgeFunction(FOnPopupMenu,o,e); ContextMenu(o,e); end function WMLButtonDown(o,e):LM_LBUTTONDOWN;virtual; begin e.SetButton(mbLeft); CallMessgeFunction(FOnMouseDown,o,e); MouseDown(o,e); end function WMRButtonDown(o,e):LM_RBUTTONDOWN;virtual; begin e.SetButton(mbRight); CallMessgeFunction(FOnMouseDown,o,e); MouseDown(o,e); end function WMMButtonDown(o,e):LM_MBUTTONDOWN;virtual; begin e.SetButton(mbMiddle); CallMessgeFunction(FOnMouseDown,o,e); MouseDown(o,e); end function WMLButtonDBLCLK(o,e):LM_LBUTTONDBLCLK;virtual; begin e.SetButton(mbLeft); e.setshiftdouble(ssDouble); CallMessgeFunction(FOnMouseDown,o,e); MouseDown(o,e); end function WMRButtonDBLCLK(o,e):LM_RBUTTONDBLCLK;virtual; begin { @explan(说明) 鼠标右双击击消息 %% @param(o)(TWinControl) 控件自身 %% @param(e)(TMMouse) 消息 %% } e.SetButton(mbRight); e.setshiftdouble(ssDouble); CallMessgeFunction(FOnMouseDown,o,e); MouseDown(o,e); end function WMMOUSEHOVER(o,e):WM_MOUSEHOVER;virtual; begin MouseHover(o,e); end function WMMOUSELEAVE(o,e):WM_MOUSELEAVE;virtual; begin MouseLeave(o,e); end function WMMouseMove(o,e):LM_MOUSEMOVE;virtual; begin CallMessgeFunction(FOnMouseMove,o,e); MouseMove(o,e); end function WMLButtonUp(o,e):LM_LBUTTONUP;virtual; begin e.SetButton(mbLeft); CallMessgeFunction(FOnMouseUp,o,e); MouseUp(o,e); end function WMRButtonUp(o,e):LM_RBUTTONUP;virtual; begin e.SetButton(mbRight); CallMessgeFunction(FOnMouseUp,o,e); MouseUp(o,e); end function WMMButtonUp(o,e):LM_MBUTTONUP;virtual; begin e.SetButton(mbMiddle); CallMessgeFunction(FOnMouseUp,o,e); MouseUp(o,e); end function DoMouseWheel(o,e);virtual; begin {** @explan(说明) 鼠标滚动消息 %% @param(o)(TWinControl) 控件自身 %% @param(e)(TMMOUSEWHEEL) 滚动消息 %% **} end function WMMouseWheel(o,e):LM_MOUSEWHEEL;virtual; begin CallMessgeFunction(FOnMouseWheel,o,e); if not e.Result then begin if e.delta<0 then CallMessgeFunction(FOnMouseWheelDown,o,e); else CallMessgeFunction(FOnMouseWheelUp,o,e); end DoMouseWheel(o,e); end function DoCNALIGN(o,e);virtual; begin if FAlign=alNone then exit; if not(Visible)then exit; if(o is getparenttype())and not(o.HandleAllocated())then begin exit; end if e.width<2 or e.height<2 then //处理一下操出范围的子控件 begin case Align of alLeft,alRight,alTop,alBottom,alClient: begin SetBounds(e.left,e.top,2,2); end end ; exit; end if autosize then begin GetPreferredSize(w,h); bds:= array(0,0,w,h); end else bds := UnAlignBounds; case Align of alTop: begin ht := min(e.height,bds[3]-bds[1]); //if ht then //begin SetBounds(e.left,e.top,e.width,max(2,ht)); //SetBoundsRect(array(e.left,e.top,e.width+e.left,e.top+ht)); e.top := e.top + ht; e.height := e.height- ht; //end end alRight: begin wd := min(e.width,bds[2]-bds[0]); SetBounds(e.left+e.width-wd,e.top,max(wd,2),e.height); e.width := e.width-wd; end alLeft: begin wd := min(e.width,bds[2]-bds[0]); SetBounds(e.left,e.top,max(wd,2),e.height); e.left := e.left+wd; e.width := e.width-wd; end alBottom: begin ht := min(e.height,bds[3]-bds[1]); SetBounds(e.left,e.top+e.height-ht,e.width,max(ht,2)); e.height := e.height - ht; end alClient: begin SetBounds(e.left,e.top,max(2,e.width),max(2,e.height)); e.height := 0; e.width := 0; end end {if self is class(TWinControl) then begin //InvalidateRect(nil,true); updateWindow(); end } end public //消息id绑定相关 function CNALIGN(o,e):CN_ALIGN;virtual; begin DoCNALIGN(o,e); end function CNANCHOR(o,e):CN_ANCHOR;virtual; begin if Align <> alNone then exit; if not ifarray(FAnchors)then exit; if not(Visible)then exit; if(o is getparenttype())and not(o.HandleAllocated())then begin exit; end if akLeft+akTop=sum(FAnchors)then exit; //左上 c := e.Prec; bds := GetBoundsRect(); if not FAnchorBounds then begin FAnchorBounds := array(bds[0],bds[1],c[2]-bds[2],c[3]-bds[3]); return; end w := width; h := height; dx := c[2]-c[0]-(FAnchorBounds[0]+w+FAnchorBounds[2]); dy := c[3]-c[1]-(FAnchorBounds[1]+h+FAnchorBounds[3]); dx1 := integer(dx/2); dx2 := dx-dx1; dy1 := integer(dy/2); dy2 := dy-dy1; L := bds[0]; r := bds[2]; t := bds[1]; b := bds[3]; if(akLeft in FAnchors)and(akRight in FAnchors)then begin R := c[2]-FAnchorBounds[2]; end if not(akLeft in FAnchors)and(akRight in FAnchors)then begin R := c[2]-FAnchorBounds[2]; L := r-w; end if not(akLeft in FAnchors)and not(akRight in FAnchors)then begin L := FAnchorBounds[0]+dx1; R := l+w; end //********************************** if(akTop in FAnchors)and(akBottom in FAnchors)then begin T := FAnchorBounds[1]; B := c[3]-FAnchorBounds[3]; end if not(akTop in FAnchors)and(akBottom in FAnchors)then begin B := c[3]-FAnchorBounds[3]; T := b-h; //T := bds[1]+dy; // end if not(akTop in FAnchors)and not(akBottom in FAnchors)then begin b := c[3]-FAnchorBounds[3]+dy1; t := B-h; end SetBoundsRect(array(L,T,R,B)); return; end function WMMove(o,e):LM_MOVE;virtual; begin if not NoRecycled() then return ; CallMessgeFunction(OnMove,o,e); if (o is class(TWinControl)) and o.WsPopUp then return ; if (Align=alNone) then begin p := Parent ; if p and p.childsizing.layout>0 then return p.AdjustSize(); AdjustSize(); end end function DoWMSIZE(o,e);virtual; begin end function WMSize(o,e):LM_SIZE;virtual; begin if not NoRecycled() then return ; CallMessgeFunction(OnSize,o,e); DoWMSIZE(o,e); p := Parent ; if p and p.childsizing.layout>0 then return p.AdjustSize(); AdjustSize(); end function CMCursorChanged(o,e):CM_CURSORCHANGED;virtual; begin //if SetTempCursor(o.Cursor) then e.skip := true; //return ; if not(csDesigning in ComponentState)then begin if SetTempCursor(o.Cursor)then e.skip := true; end else begin cr := new tcustomcursor(); cr.id := IDC_ARROW; if SetTempCursor(cr)then e.skip := true; end end public //暂时不用的消息 { function WMWindowPosChanged(o,e):LM_WINDOWPOSCHANGED;virtual; begin end function CMChanged(o,e):CM_CHANGED;virtual; begin end function LMCaptureChanged(o,e):LM_CaptureChanged;virtual; begin end function CMBiDiModeChanged(o,e):CM_BIDIMODECHANGED;virtual; begin end function CMSysFontChanged(o,e):CM_SYSFONTCHANGED;virtual; begin end function CMEnabledChanged(o,e):CM_ENABLEDCHANGED;virtual; begin end function CMHitTest(o,e):CM_HITTEST;virtual; begin end function CMMouseEnter(o,e):CM_MOUSEENTER;virtual; begin end function CMMouseLeave(o,e):CM_MOUSELEAVE;virtual; begin end function CMHintShow(o,e):CM_HINTSHOW;virtual; begin end function CMParentBiDiModeChanged(o,e):CM_PARENTBIDIMODECHANGED;virtual; begin end function CMParentColorChanged(o,e):CM_PARENTCOLORCHANGED;virtual; begin end function CMParentFontChanged(o,e):CM_PARENTFONTCHANGED;virtual; begin end function CMParentShowHintChanged(o,e):CM_PARENTSHOWHINTCHANGED;virtual; begin end function CMVisibleChanged(o,e):CM_VISIBLECHANGED;virtual; begin end function CMTextChanged(o,e):CM_TEXTCHANGED;virtual; begin end } #!end //消息处理 protected //key and mouse function SetColor(v);virtual; begin if v <> FColor and ifnumber(v)then begin FColor := v; end end function getcolor();virtual; begin if FParentColor and Parent then return Parent.Color; return FColor; end function SetBitmap(v);virtual; begin if v <> FBKBitmap then begin FBKBitmap := v; end end function GetActionLinkClass();virtual; begin {** @explan(说明) 返回actionlinkclass %% @return(TControlActionLink class) **} return class(TControlActionLink); 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) or Enabled then Enabled := NewAction.Enabled; if (not CheckDefaults) or Visible then Visible := NewAction.Visible; { if not CheckDefaults or (Hint = '') then Hint := NewAction.Hint; if not CheckDefaults or (Self.HelpContext = 0) then Self.HelpContext := HelpContext; if not CheckDefaults or (Self.HelpKeyword = '') then Self.HelpKeyword := HelpKeyword; } // HelpType is set implicitly when assigning HelpContext or HelpKeyword end; end //function click(o,e);virtual;begin end //function DblClick(o,e);virtual;begin end public function ScreenToClient(X,Y);virtual; begin if Parent then begin ps := Parent.ScreenToClient(x,y); return array(ps[0]-Left,ps[1]-Top); end return array(x,y); end function ClientToScreen(x,y);virtual; begin if Parent then begin ps := array(x+Left,y+Top); return Parent.ClientToScreen(x+Left,y+Top); end return array(x,y); end function getid(); begin return Fid; end function create(aOwner);override; //构造函数 begin inherited; FControlFlags := array(); fautosize := false; if ifnil(FSIDC)then FSIDC := new tidcreater(100); FId := FSIDC.createid(); //init(); bindmessages(self(true)); FControlStyle := array(csCaptureMouse,csClickEvents,csSetCaption,csDoubleClicks); FAlign := alNone; FAnchors := array(akLeft,akTop); FControls := new TFpList(); FVisible := True; FParentBidiMode := True; FParentColor := false; FParentFont := true; //FDesktopFont := True; FParentShowHint := True; FIsControl := False; FEnabled := True; FDragCursor := crDrag; FCaption := "title"; FLeft := 10; FTop := 10; FFont := new TFontControl(); FFont.Control := self(true); FWidth := 120; FHeight := 40; FBorder := false; FColor := 0xffffff; //_wapi.GetSysColor(COLOR_WINDOW);//0xffffff; FCanvas := new TControlCanvs(); FCursor := new tcustomcursor(); FCursor.id := IDC_ARROW; end function checknewparent(AParent:TWinControl);virtual; //检查parent begin { @explan(说明) 判断是否可以作为当前类型的父节点 %% @return(bool) } return true; end function checknewchild(achild);virtual;//检查child begin { @explan(说明) 判断是否可以作为当前类型的子节点 %% @return(bool) } return true; end function Recycling();override; //销毁处理 begin {** @explan(说明) 资源回收,子类请override该方法然后在destroy中调用 %% **} FFont := nil; FMessagehandle := array(); FSIDC.deleteid(FID); SetParent(nil); //FOnClick := nil; //点击 //FOnContextPopup := nil; //FOnDblClick := nil; //双击 //FOnDragDrop := nil; //FOnDragOver := nil; //FOnSize := nil; //FOnMove := nil; //FOnEditingDone := nil; //FOnEndDock := nil; //FOnEndDrag := nil; //FOnMouseDown := nil; //按下 //FOnMouseEnter := nil; //进入 //FMouseEntereded := nil; //FOnMouseLeave := nil; //离开 //FOnMouseMove := nil; //移动 //FOnPopupMenu := nil; //FOnMouseUp := nil; //弹起 //FOnMouseWheel := nil; //滚动 //FOnMouseWheelDown := nil; //滚动按下 //FOnMouseWheelUp := nil; //滚动弹起 ////FOnQuadClick := nil; ////FOnResize := nil; // //FOnShowHint := nil; //FOnStartDock := nil; //FOnStartDrag := nil; FBKBitmap := nil; if FActionLink is class(TControlActionLink)then begin FActionLink.Recycling(); FActionLink := nil; end inherited; end function destroy();override; begin inherited; end function GetBoundsRect(); //type_tcontrol begin {** @explan(说明)获取矩形范围 %% **} return array(FLeft,FTop,FLeft+FWidth,FTop+FHeight); end; function SetBoundsRect(rect); begin {** @explan(说明) 设置矩形范围 %% **} nt := 100000; if ifarray(rect)and rect[0]0 and aHeight>0 then begin ChangeBounds(integer(ALeft),integer(ATop),integer(AWidth),integer(AHeight),false); end end function GetBounds();virtual; //type_tcontrol begin //aLeft, aTop, aWidth, aHeight: integer {** @explan(说明) 获取控件范围 %% @return( array of integer) array(aLeft, aTop, aWidth, aHeight: integer) %% **} return array(Left,top,Width,height); //ChangeBounds(ALeft, ATop, AWidth, AHeight, false); end procedure SetTempCursor(Value);virtual; begin if Parent then return Parent.SetTempCursor(Value); end // drag and dock function Dragging(); begin //return DragManager.Dragging(Self); end; procedure BeginDrag(Immediate:Boolean;Threshold); begin if not ifnumber(Threshold)then Threshold :=-1; //DragManager.DragStart(Self, Immediate, Threshold); end procedure EndDrag(Drop:Boolean); begin //if Dragging() then DragManager.DragStop(Drop); end function dispatch(o,e);virtual; //分发消息 begin {** @explan(说明)消息分发函数 %% @param(o)()控件自身 %% @param(e)(tuieventbase) 消息类及其子类 %% **} id := e.Msg; if ifnumber(id) and FMessagehandle then begin func := FMessagehandle[id]; if func then call(func,o,e); end end procedure DoControlAlign();virtual;//调整子控件位置 begin end procedure DoControlAnchor();virtual;//调整子控件位置 begin end procedure WndProc(TheMessage);virtual; //消息分发 begin {** @explan(说明) 消息循环 %% @param(e)(tuieventbase) 消息对象 %% **} TheMessage.Sender := self(true); tmsg := TheMessage.msg; case tmsg of WM_WINDOWPOSCHANGED: begin rchange := 0; d := new tvclwindowpos_class(TheMessage.lparam); flags := d.flags; //if flags .& SWP_HIDEWINDOW then return ; //if flags .& SWP_SHOWWINDOW then return ; if d.x=-32000 then return ; if d.y=-32000 then return ; if not((flags .& SWP_NOMOVE)=SWP_NOMOVE)then begin x := d.x; y := d.y; if x <> FLeft then begin FLeft := x; rchange .|=1; end if y <> FTop then begin FTop := y; rchange .|=2; end end if not((flags .& SWP_NOSIZE)=SWP_NOSIZE)then begin cx := d.cx; cy := d.cy; if cx <> FWidth then begin FWidth := cx; rchange .|=4; end if cy <> FHeight then begin FHeight := cy; rchange .|=8; end end if rchange and (csDesigning in ComponentState) then begin obj := class(tUIglobalData).uigetdata("tuiapplication"); if obj then begin obj.Notification(self(true),array("type":"possize","flag":rchange,"data":array(fleft,ftop,FWidth,FHeight))); //obj.Notification(self(true),new tpossizenote(rchange,fleft,ftop,FWidth,FHeight)); end //echo "\r\n note change mtoc:",caption,"===",mtoc; end end {WM_SIZE: begin x := TheMessage.lolparamsigned(); dxsize := x-FClientWdith; if FClientWdith<> x then FClientWdith := x; y := TheMessage.hilparamsigned(); dysize := y-FClientHeight; if FClientHeight <> y then FClientHeight := y; DoControlAnchor(array(dxsize,dysize)); DoControlAlign(array(FClientLeft,FClientTop,x,y)); end WM_MOVE: begin x := TheMessage.lolparamsigned(); if FClientLeft<> x then FClientLeft := x; y := TheMessage.hilparamsigned(); if FClientTop <> y then FClientTop := y; end } end; if(csDesigning in ComponentState)then begin //CallMessgeFunction(,self(true),TheMessage); end else if(tmsg >= LM_KEYFIRST)and(tmsg <= LM_KEYLAST)then begin // keyboard messages //Form := GetParentForm(Self); //if (Form <> nil) and (Form.WantChildKey(Self,TheMessage)) then exit; end else if((tmsg >= LM_MOUSEFIRST)and(tmsg <= LM_MOUSELAST))or((tmsg >= LM_MOUSEFIRST2)and(tmsg <= LM_MOUSELAST2))then begin // mouse messages case tmsg of LM_MOUSEMOVE: begin //Application.HintMouseMessage(Self, TheMessage); end; LM_LBUTTONDOWN,LM_LBUTTONDBLCLK: begin includestate(FControlState,csLButtonDown); if FDragMode=dmAutomatic then begin end; //BeginAutoDrag(); end; LM_LBUTTONUP: begin excludestate(FControlState,csLButtonDown); end; end; end; if tmsg=LM_PAINT then begin includestate(FControlFlags,cfProcessingWMPaint); try Dispatch(self(true),TheMessage); finally excludestate(FControlFlags,cfProcessingWMPaint); end; end else begin Dispatch(self(true),TheMessage); end end; function Perform(e); begin {** @explan(说明) 消息通知执行 %% @param(e)(tuieventbase) **} WndProc(e); return e.Result; end property ActionLink read FActionLink; //write FActionLink; public procedure AdjustSize();virtual; // smart calling DoAutoSize begin //includestate(FControlFlags,cfAutoSizeNeeded); if fautosizing then begin return ; end fautosizing := true; sf := self(true); if (sf is class(TWinControl)) and sf.WsPopUp then return ; if Parent then begin if Parent.autosize then Parent.AdjustSize(); else if Align<>alNone then Parent.DoControlAlign(); end fautosizing := false; //excludestate(FControlFlags,cfAutoSizeNeeded); end function GetPreferredSize(w,h);virtual; begin ft := Font; if ft then begin c := caption; w := ft.Width*(max(2,length(c)))+2; h := ft.Height+2; end end protected function set_Preferre_size(); begin rec := BoundsRect; GetPreferredSize(w,h); rec[2] := rec[0]+w; rec[3] := rec[1]+h; a := Align; if a=alNone then begin BoundsRect := rec; end else if a=alLeft or a=alRight then begin Width := w; end else if a=alTop or a=alBottom then begin Height := h; end else Width := w; end property UnAlignBounds read GetUnAlignBounds write SetUnAlignBounds; {** @param(Action)(taction) action对象 %% @param(UnAlignBounds)(array of integer) 去除自动对齐时的范围 %% @param(Align)(member of TAlign ) 默认 alNone 对齐方式 %% @param(Anchors)( array of TAnchorKind member) 锚定位置 ,默认 array(akTop,akLeft) %% **} published // standard properties, which should be supported by all descendants property Action:taction read GetAction write SetAction; property Anchors:anchors read FAnchors write SetAnchors; //anchors 暂时屏蔽anchors property Align:align read FAlign write SetAlign; property autosize:lazybool read fautosize write setautosize; property autosizing read fautosizing; property ParentFont:bool read FParentFont write SetParentFont; property Parentcolor:bool read FParentcolor write SetParentcolor; property Caption:string read GetText write SetText ; property Enabled:bool read GetEnabled write SetEnabled; property Cursor:syscursor read GetCursor write SetCursor; {** @param(Cursor)(tcursor 通过 member of TSystemCursor 设置) 系统鼠标 %% **} property Font:font read GetControlFont write SetControlFont;//write SetFont; property OnMouseWheel read FOnMouseWheel write FOnMouseWheel; {** @param(Caption)(string) 控件标题 %% @param(Enabled)(bool) 控件是否有效 %% @param(OnMouseWheel)(function[TControl,TMMOUSEWHEEL]) 滚动回调函数 %% **} //property MouseEntered read FMouseEntered; property OnSize:eventhandler read FOnSize write FOnSize; property OnMove:eventhandler read FOnMove write FOnMove; property OnMouseMove:eventhandler read FOnMouseMove Write FOnMouseMove; property OnPopupMenu:eventhandler read FOnPopupMenu write FOnPopupMenu; property OnMouseDown:eventhandler read FOnMouseDown write FOnMouseDown; {** @param(OnMouseMove)(function[TControl,TMMouse]) 鼠标移动回调函数 %% @param(OnPopupMenu)(function[TControl,TMMouse]) 弹出菜单回调函数 %% @param(OnMouseDown)(function[TControl,TMMouse]) 鼠标按下回调函数 %% @param(OnMouseUp)(function[TControl,TMMouse]) 鼠标松开回调函数 %% @param(OnClick)(function[TControl,TMMouse]) 鼠标点击回调函数 %% @param(OnDblClick)(function[TControl,TMMouse]) 鼠标双击回调函数 %% @param(PopupMenu)(tpopupmenu) 弹出菜单%% @param(Parent)(tcontrol) 父控件 %% @param(Visible)(bool) 是否可见 %% **} property OnMouseUp:eventhandler read FOnMouseUp write FOnMouseUp; property onfontchanged:eventhandler read fonfontchanged write fonfontchanged; property OnClick:eventhandler read FOnClick write FOnClick; property onrclick:eventhandler read Fonrclick write Fonrclick; property OnDblClick:eventhandler read FOnDblClick write FOnDblClick; //property OnResize read FOnResize write FOnResize; property OnShowHint read FOnShowHint write FOnShowHint; property Parent read FParent write preparesetparent; property PopupMenu:tpopupmenu read FPopupMenu write FPopupMenu{read GetPopupmenu write SetPopupMenu}; //property ShowHint read FShowHint write SetShowHint ; property Visible:bool read FVisible write SetVisible ; property ClientRect read GetClientRect; property Height: Integer read FHeight write SetHeight; property Width :integer read FWidth write SetWidth; property Left :integer read FLeft write SetLeft; property Top :integer read FTop write SetTop; property Border:bool read FBorder write SetBorder; {** @param(ClientRect)(array of integer) 客户区矩形array(left,top,right,bottom) %% @param(BoundsRect)(array of integer) 控件区矩形array(left,top,right,bottom) %% @param(Height)(integer) 高度 %% @param(Width)(integer) 宽度 %% @param(Zorder)(integer) 设置控件在父窗口的次序,最底层为 0 %% @param(Top)(integer) 上方位置 %% @param(Left)(integer) 左边 %% **} property BoundsRect read GetBoundsRect write SetBoundsRect; property Zorder read GetZorder write SetZorder; property ControlState: TControlState read FControlState write FControlState; property ControlFlags read fControlFlags ; property Color:color read getcolor write SetColor;//FColor; property BKBitmap:tbitmap read FBKBitmap write SetBitmap; //property OnMouseEnter:eventhandler read FOnMouseEnter write FOnMouseEnter; //property OnMouseLeave:eventhandler read FOnMouseLeave write FOnMouseLeave; property Controls read FControls; property Canvas: TCanvas read FCanvas; {** @param(Canvas)(TCanvas) 画布对象 %% @param(Controls)(TFpList of tcontrol) 子组件 %% @param(OnMouseLeave)(function[TControl,tuieventbase]) 鼠标离开回调 %% @param(OnMouseEnter)(function[TControl,tuieventbase]) 鼠标进入回调 %% @param(Color)(integer) 背景色 %% **} function isCustomPaint(); //提供给gtk使用 begin return csCustomPaint in FControlState ; end end