unit utslvclpage; interface uses utslvclauxiliary,utslvclbase,utslvclgdi; type tcustomtabsheet = class(TCustomControl) //控件页面 {** @explan(说明)page控件页面 %% **} private FImageIndex; protected function RealSetText(s);override; begin inherited; p := parent; if ifstring(s) and p and (p is class(tcustompagecontrol)) then begin id := p.GetPageID(self(true)); p.SetTabText(id,s); end end public function paint();override; //设计器模式下绘制网格 begin drawdesigninggrid(); end function DesigningMove();override;//移动 begin return false; end function DesigningSizer();override;//调整大小 begin return false; end function create(AOwner);override; begin inherited; WsDlgModalFrame := true; //p.exstyle := 0x101; Caption := "tab"; Visible := false; end end type tcustompagecontrol = class(TCustomControl) private fclocker;//锁 FirstViewIndex; //第一个展示的序号 FCurrentid; //当前 FPrevid; //上一个 FTabItems; // [weakref]FOnSelChanged; [weakref]FOnSelChanging; //正在改变 //FOnrclick; FTabPosition; FTabHeight; FTabItemswidth; FScrollBtnRect; Fprevrect; fnextrect; FTabRects; FClientarea; private function gettabsheetitem(idx); begin if idx>=0 and idx=0 and idx=0 then return FTabItems[id].PageSheet; end function SetTabPosition(v); begin if FTabPosition=v then exit; if not(v in array(alTop,alBottom,alLeft,alRight)) then exit; FTabPosition := v; DoControlAlign(); InvalidateRect(nil,false); end function GetTabCount(); begin return FTabItems.length(); end function CreateTableItem(cp); begin r := new tcustomtabitem(); r.caption := cp; return r; end function CalcTabs(); //计算区域 begin rec := ClientRect; //区域 fclosebtnrect := array(); ft := font; fw := ft.width; if not fownerdraw then begin fh := ft.height; FTabHeight := fh+7; end FTabItemswidth := array(); e := new tuieventbase(0,0,0,0); for i := 0 to FTabItems.length()-1 do begin pg := FTabItems[i]; ta := pg.Caption; FTabItemswidth[i] := max(20, length(ta)*fw+10 ); if fonmeasuretabwidth then begin e.wparam := i; CallMessgeFunction(fonmeasuretabwidth,self(true),e); if e.lparam>=0 then FTabItemswidth[i] := e.lparam; end end FMaxsize := 0; if FTabPosition in array(alLeft,alRight) then begin FTabItemswidth := zeros(length(FTabItemswidth))+maxvalue(FTabItemswidth); FMaxsize := length(FTabItemswidth)*FTabHeight; end else begin FMaxsize := sum(FTabItemswidth); end FClientarea := rec; FScrollBtnRect := 0; Fprevrect := 0; fnextrect := 0; FTabRects := array(); case FTabPosition of alLeft: begin if FTabItemswidth then begin FClientarea[0] :=rec[0]+FTabItemswidth[0]; if length(FTabItemswidth)>1 and (FMaxsize>(rec[3]-rec[1])) then begin FScrollBtnRect := array(rec[0],rec[3]-FTabHeight*2,rec[0]+FTabItemswidth[0],rec[3]); Fprevrect := array(rec[0],rec[3]-FTabHeight*2,rec[0]+FTabItemswidth[0],rec[3]-FTabHeight); Fnextrect := array(rec[0],rec[3]-FTabHeight,rec[0]+FTabItemswidth[0],rec[3]); end else begin FirstViewIndex := 0; end ybase := 0; for i,v in FTabItemswidth do begin if i>=FirstViewIndex then begin FTabRects[i] := array(0,ybase,FTabItemswidth[0],ybase+FTabHeight); ybase+=FTabHeight; if xbase>(rec[3]-FTabHeight-FTabHeight) then break; end else FTabRects[i] := nil; end end end alRight: begin if FTabItemswidth then begin FClientarea[2] :=rec[2]-FTabItemswidth[0]; if length(FTabItemswidth)>1 and (FMaxsize>(rec[3]-rec[1])) then begin FScrollBtnRect := array(rec[2]-FTabItemswidth[0],rec[3]-FTabHeight*2,rec[2],rec[3]); Fprevrect := array(rec[2]-FTabItemswidth[0],rec[3]-FTabHeight*2,rec[2],rec[3]-FTabHeight); Fnextrect := array(rec[2]-FTabItemswidth[0],rec[3]-FTabHeight,rec[2],rec[3]); end else FirstViewIndex := 0; ybase := 0; for i,v in FTabItemswidth do begin if i>=FirstViewIndex then begin FTabRects[i] := array(rec[2]-FTabItemswidth[0],ybase,rec[2],ybase+FTabHeight); ybase+=FTabHeight; if xbase>(rec[3]-FTabHeight-FTabHeight) then break; end else FTabRects[i] := nil; end end end alTop: begin if FTabItemswidth then begin FClientarea[1] :=rec[1]+FTabHeight; if fclosebtn then begin cbt := max(0,integer((FTabHeight-16)/2)); fclosebtnrect := array(rec[2]-18,cbt,rec[2]+2,cbt+16); rec[2]-=21; end if length(FTabItemswidth)>1 and (FMaxsize>(rec[2]-rec[0]-(fclosebtn?20:0))) then begin FScrollBtnRect := array(rec[2]-FTabHeight*2,rec[1],rec[2],rec[1]+FTabHeight); Fnextrect := array(rec[2]-FTabHeight,rec[1],rec[2],rec[1]+FTabHeight); Fprevrect := array(rec[2]-FTabHeight*2,rec[1],rec[2]-FTabHeight,rec[1]+FTabHeight); end else FirstViewIndex := 0; xbase := 0; for i,v in FTabItemswidth do begin if i>=FirstViewIndex then begin FTabRects[i] := array(xbase,0,xbase+FTabItemswidth[i],FTabHeight); xbase+=FTabItemswidth[i]; if xbase>(rec[2]-FTabHeight-FTabHeight) then break; end else FTabRects[i] := nil; end end end alBottom: begin if FTabItemswidth then begin FClientarea[3] :=rec[3]-FTabHeight; if length(FTabItemswidth)>1 and (FMaxsize>(rec[2]-rec[0])) then begin FScrollBtnRect := array(rec[2]-FTabHeight*2,rec[3]-FTabHeight,rec[2],rec[3]); Fnextrect := array(rec[2]-FTabHeight,rec[3]-FTabHeight,rec[2],rec[3]); Fprevrect := array(rec[2]-FTabHeight*2,rec[3]-FTabHeight,rec[2]-FTabHeight,rec[3]); end else FirstViewIndex := 0; xbase := 0; for i,v in FTabItemswidth do begin if i>=FirstViewIndex then begin FTabRects[i] := array(xbase,rec[3]-FTabHeight,xbase+FTabItemswidth[i],rec[3]); xbase+=FTabItemswidth[i]; if xbase>(rec[2]-FTabHeight-FTabHeight) then break; end else FTabRects[i] := nil; end end end end end function InsureIdxVisible(id); //确保可见 begin if FScrollBtnRect and (not FTabRects[id]) then begin tl := (FTabItems.length()-1); if id>FirstViewIndex then begin while(not FTabRects[min(id+1,tl)]) do begin FirstViewIndex++; CalcTabs(); end end else if id=0 and id-1 and fOnSelChanging then begin e := new tuieventbase(0,FCurrentid,id,0); //m,w,l,h doonSelChanging(self(true),e); if e.skip then return ; end FPrevid := FCurrentid; FCurrentid := id; InsureIdxVisible(id); InvalidateRect(nil,false); DoControlAlign(); if FOnSelChanged then begin doonSelChange(self(true),new tuieventbase(0,FPrevid,FCurrentid,0)); end end else if FTabItems.length()=0 then begin FPrevid := -1; FCurrentid := -1; end end function PaintTabs();//绘制tab begin lk := new tcountlocker(fclocker); dc := Canvas; dc.font := font; ar := 0->(FTabItems.length()-1); if FTabRects[FCurrentid] then begin ar[FCurrentid] := -100; ar[length(ar)] := FCurrentid; end for ii,i in ar do begin rec := FTabRects[i]; if rec then begin if fownerdraw and fondrawtab then begin e := new teventdrawtab(i,(FCurrentid=i),rec,dc); CallMessgeFunction(fondrawtab,self(true),e); continue; end dc.pen.color := 13158600;//rgb(200,200,200); if FCurrentid=i then begin dc.brush.color := 0xf0f0f0;//rgb(100,192,250);//rgb(230,240,250);//rgb(200,200,200); end else dc.brush.color := 16711422;//rgb(254,254,254); dc.draw("roundrect",array(rec[0:1],rec[2:3],array(2,2))); rec[1]+=2; it := FTabItems[i]; dc.drawtext(it.caption,rec,DT_CENTER .|DT_VCENTER); end end end function PaintScroll(); //绘制滚动 begin dc := Canvas; if FScrollBtnRect then begin case FTabPosition of alTop,alBottom: begin rc1 := array(FScrollBtnRect[0:1]+1,(FScrollBtnRect[0]+FTabHeight-1,FScrollBtnRect[3]-1)); dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLLEFT); rc1 := array((FScrollBtnRect[0]+FTabHeight+1,FScrollBtnRect[1]+1),FScrollBtnRect[2:3]-1); dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLRIGHT); end else begin rc1 := array(FScrollBtnRect[0:1]+1,(FScrollBtnRect[2]-1,FScrollBtnRect[3]-FTabHeight-1)); dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLUP); rc1 := array((FScrollBtnRect[0]+1,FScrollBtnRect[3]-FTabHeight+1),FScrollBtnRect[2:3]-1); dc.draw("framecontrol",rc1,DFC_SCROLL,DFCS_SCROLLDOWN); end end end if fclosebtnrect then begin dc.brush.color := 0x0000ff; dc.FillRect(fclosebtnrect); dc.pen.color := 0xf0f0f0; dc.moveto(fclosebtnrect[0:1]); dc.LineTo(fclosebtnrect[2:3]); dc.moveto(array(fclosebtnrect[2],fclosebtnrect[1])); dc.LineTo(array(fclosebtnrect[0],fclosebtnrect[3])); end end function ScrollPrev(); //滚动到下一个 begin if FScrollBtnRect and FirstViewIndex>0 then begin FirstViewIndex-- ; CalcTabs(); InvalidateRect(nil,false); end end function scrollnext(); //滚动到上一个 begin if FScrollBtnRect and FirstViewIndex=0) then return ; FTabItems.splice(id,1); if id = FCurrentid then begin if id = 0 then begin if FTabItems.length()=0 then begin FCurrentid := -1; FPrevid := -1; end end FCurrentid := -1; FPrevid := -1; cid := min(max(0,id-1),FTabItems.length()-1); if cid >=0 then begin return setselidx(cid); end else begin if FOnSelChanged then begin doonSelChange(self(true),new tuieventbase(0,-1,-1,0)); end end end else if id1 then begin if page then begin page.visible := false; end end it.PageSheet := Page; if FCurrentid=-1 then begin setselidx(0); end else begin if not (page is class(TWinControl)) then CalcTabs(); InvalidateRect(nil,false); end end public function FontChanged(o);override; begin inherited; DoControlAlign(); end function hittabat(xy); //命中 begin r := array(); if (FScrollBtnRect and pointinrect(xy,FScrollBtnRect)) then begin r["idx"] := "scroll"; return r; end if (fclosebtnrect and pointinrect(xy,fclosebtnrect)) then begin r["idx"] := "closebtn"; return r; end for i,v in FTabRects do begin if v and pointinrect(xy,v) then begin r["idx"] := i; r["pos"] := array(xy[0]-v[0],xy[1]-v[1]); return r; end end return r; end function checknewchild(achild);override;//检查child begin r := inherited; if isacceptsheettype( achild) then achild.Align := alNone; return r; end function getsheetrect(); //获得sheet begin {** @explan(说明) 获得sheet可视区域 %% @return(array) array(左,上,右,下) %% **} if not FClientarea then CalcTabs(); return FClientarea; end function DesigningClick();override; begin return true; end function create(aowner); begin inherited; fclosebtn := false; FTabHeight := font.height+7; faccepttype := array(); acceptsheettype(class(tcustomtabsheet)); end function AfterConstruction();override; begin inherited; fclocker := new tcountkernel(); color := 0xffffff; height := 200; width := 200; left := 10; top := 10; FTabPosition := alTop; FirstViewIndex := 0; FCurrentid := -1; FPrevid := -1; FTabItems := new tnumindexarray(); end function ControlAppended(AControl);override; begin if not isacceptsheettype(AControl) {not(AControl is class(tcustomtabsheet))} then return; addtabitem(AControl); end function ControlDeleted(AControl);override; begin if not isacceptsheettype(AControl){ not(AControl is class(tcustomtabsheet))} then return; id := GetPageID(AControl); RemovePageTab(id); //fcoolbands.deleteitem(AControl,true); end Function SetCurSel(id); //设置当前序号 begin if isacceptsheettype(id) {id is class(tcustomtabsheet)} then begin return SetCurSel(GetPageID(id)); end if ifnumber(id) and id>=0 then begin iid := integer(id); setselidx(iid); end end function paint();override; //绘制 begin PaintTabs(); PaintScroll(); end function MouseUp(o,e);override;//鼠标弹起 begin if e.skip then return ; ps := e.pos(); mb := e.button(); //if mb=mbRight then return ; if(mb=mbLeft) then begin if fclosebtn and fclosebtnrect and pointinrect(ps,fclosebtnrect) then begin if fonclosebtnclick then begin e := new tuieventbase(0,0,0,0); CallMessgeFunction(fonclosebtnclick,self(true),e); end return ; end if FScrollBtnRect and pointinrect(ps,fnextrect) then begin return ScrollNext(); end if FScrollBtnRect and pointinrect(ps,Fprevrect) then begin return scrollprev(); end end if not FTabRects then return ; for i := 0 to length( FTabRects)-1 do begin v := FTabRects[i]; if v and pointinrect(ps,v) then begin setselidx(i); if Onclick and (mb = mbLeft) then begin CallMessgeFunction(Onclick,o,e); end else if onrclick and (mb = mbRight) then begin CallMessgeFunction(onrclick,o,e); end return ; end // end end function doonSelChange(o,e);virtual; begin CallMessgeFunction(FOnSelChanged,o,e); end function doonSelChanging(o,e);virtual; begin CallMessgeFunction(fOnSelChanging,o,e); end function TabRect(AIndex: Integer); //获取区域 begin r := FTabRects[AIndex]; if r then return r; return array(0,0,0,0); end function GetTabText(AIndex);//获得caption begin r := ""; if AIndex0 then return FTabItems[AIndex].Caption; return r; end function GetPageID(page);//获得page序号 begin {** @explan(说明)获取page的序号 %% **} r := -1; if {page is class(tcustomtabsheet)} isacceptsheettype(page) then begin for it := 0 to FTabItems.length()-1 do begin if FTabItems[it].PageSheet = page then begin return it; end end end return r; end function DoControlAlign();override;//调整位置 begin CalcTabs(); for i := 0 to FTabItems.length()-1 do begin pg := FTabItems[i].PageSheet; if not pg then continue; pg.Align := alNone; if (pg is class(TWinControl)) and pg.WsPopUp then begin if i=FCurrentid then begin pg.show(); end continue; end if i=FCurrentid then begin pg.Visible := true; rc := getsheetrect(); if not rc then return ; rc[1]+=1; if csDesigning in ComponentState then begin rc[0]+=2; rc[2]-=2; rc[3]-=2; end pg.SetBoundsrect(rc); end else begin pg.Visible := false; end end end function SetTabText(i,Value); begin {** @explan(说明)修改tab标签文字 %% @param(i)(integer)序号 %%; @param(Value)(string)文本 %%; **} it := FTabItems[i]; if it and value<>it.caption then begin it.Caption := Value; DoControlAlign(); InvalidateRect(nil,false); end end function SetTabIndex(AIndex,AIndexnew); begin {** @explan(说明) 修改标签的次序 %% @param(AIndex)(integer) 位置 %% @param(AIndexnew)(integer) 新位置 %% **} if (AIndex<>AIndexnew) and (AIndex>=0) and (AIndex=0) and (AIndexnewfclosebtn then begin fclosebtn := nv; DoControlAlign(); end end function settabheight(h); begin if ownerdraw and ( h>=0) and FTabHeight<>h then begin FTabHeight := h; DoControlAlign(); end end end implementation type tcustomtabitem = class() // {** @explan(说明)tab控件标签对象 %% **} private FCaption; FVisible; [weakref]FPageSheet; function SetVisible(v);//设置可见 begin nv := v?true:false; if nv<>FVisible then begin FVisible := v; end end function SetCaption(s);//设置标签 begin if ifstring(s) and s<>FCaption then begin FCaption := s; if PageSheet then PageSheet.Caption := s; end end public function Create();//构造 begin FVisible:= true; FCaption := ""; end published property Caption read FCaption write SetCaption; property PageSheet read FPageSheet Write FPageSheet; _tag; end type teventdrawtab = class(tuieventbase) {** @explan(说明)单元格绘制消息对象 %% @param(idx)(integer) 序号 %% @param(sel)(integer) 是否选中 %% @param(rec)(array(左上右下)) 区域 %% @param(canvas)(TCanvas) 画布 %% **} function create(id,s,rc,cvs); begin inherited create(0,0,0,0); idx := id; sel := s; rec := rc; canvas := cvs; end idx; sel; rec; canvas; end initialization end.