unit utslvclgrid; interface uses utslvclauxiliary,utslvclmemstruct,utslvclgdi; {** @explan(说明) 表格控件相关 %% @date(20220510) **} type TcustomGridCtl = class(tcustomscrollcontrol) //自绘制表格基类 {** @explan(说明) 自绘制表格控件 %% **} protected function GetClientXCapacity();virtual; //宽度容量 begin r := integer(ClientRect[2]/GetXScrollDelta()); return r; end function GetClientYCapacity();virtual; //高度容量 begin r := integer(ClientRect[3]/GetYScrollDelta()); return r; end function GetClientXCount();virtual; //宽度间隔 begin r := integer(0.99+ allwidth()/FColWidth); return r; end function GetClientYCount();virtual; //高度项 begin return integer(0.99+allheigth()/FRowHeight); end function GetXScrollDelta();override; begin return FColWidth; end function GetYScrollDelta();override; begin return FRowHeight; end function PositionChanged();virtual; begin InvalidateRect(nil,false); end public 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; UpDateScrollBar(); end end inherited; end function UpDateScrollBar(); begin DoControlAlign(); end function DoControlAlign();override; begin if(IsUpDating())then begin FScroolChanged := true; end else begin UpDateFixed(); pt := New TPAINTCOUNT(self); InitialScroll(); end end function Create(AOwner);override; //构造 begin inherited; end function AfterConstruction();override; begin inherited; Width := 300; Height := 260; FMouseSizeColumnWidth := 1; AutoScroll := 3; FItemCount := 0; FFixedRows := 1; FColumFixed := 0; FColWidth := 5; //10; FRowWidth := 10; FC_NORMAL := OCR_NORMAL; FC_SIZE := OCR_SIZEWE; FC_SIZE2 := OCR_SIZENS; FMarginLeft := 1; FMarginTop := 1; FMarginRight := 0; FMarginBottom := 0; FRowHeight := 30; FColsWidths := new tnumindexarray(); FRowsHeight := new tnumindexarray(); FVariableRows := false; ThumbTrack := true; FScroolChanged := false; end function GetItemRect(i);virtual; //根据行号获得其区域 begin {** @explan(说明) 获得行的区域 %% @param(i)(integer) 行号 %% @return(array) array(左,上,右,下); **} yrct := GetItemYBound(i); if not yrct then return nil; basex := FMarginLeft-FColWidth * GetXpos(); //r := array(basex,yrct[0],yrct[1],0); r := array(basex,yrct[0],0,yrct[1]); for ii := 0 to FColsWidths.length()-1 do begin basex += FColsWidths[ii]; end r[2]:= basex; return r; end function GetItemStartY(i);virtual; //获得行的top begin {** @explan(说明) 获得行的区域范围 %% @param(i)(integer) 行号 %% @return(array) array(上,下); **} if(i<0 or i >= GetItemCount())then return nil; yb := FMarginTop; itv := FRowHeight; if FVariableRows then begin for ii := 0 to i-1 do begin yb += FRowsHeight[ii]; end //itv := FRowWidth; end else yb += i * FRowHeight; if i= 0 and j= x then return i; if basex >= x then return i; end return r; end function InvalidateItem(i);virtual; begin {** @explan(说明) 刷新行%% @param(i)(integer) 行号 %% **} bd := GetItemYBound(i); if not bd then return false; rec := ClientRect; if bd[1]>rec[3]or bd[0]rec[3]or rec1[3]rec[2]or rec1[2]= x then return i; if basex >= x then return i; end end else begin r := integer((y-FMarginTop)/FRowHeight); if y <= FYfiexed then begin if r >= FItemCount then return-1; return r; end ybase := GetYPos(); r += ybase; if r >= FItemCount then return-1; return r; end return r; end function SetColumns(cls,beg,len);virtual; begin {** @explan(说明) 设置列宽信息 %% @param(cls)(array of integer) 列宽 %% @param(beg)(integer) 开始位置 %% @param(len)(integer) 替代长度 %% **} clsa := array(); for i,v in cls do begin if v >= 0 then clsa[length(clsa)]:= v; end FColsWidths.splices(beg>0?beg:0,len >= 0?len:FColsWidths.Length(),clsa); DoControlAlign(); end function SetRows(rows,beg,len);virtual; begin if not FVariableRows then return; clsa := array(); for i,v in rows do begin if v>0 then clsa[length(clsa)]:= v; end FRowsHeight.splices(beg>0?beg:0,len >= 0?len:FRowsHeight.Length(),clsa); DoControlAlign(); end function GetColumnWidth(i); begin {** @explan(说明) 获得第i列宽度 %% @param(i)(integer) 列号 %% @return(integer) 宽度 %% **} return FColsWidths[i]; end function SetColumnWidth(i,w); begin {** @explan(说明) 设置列宽 %% @param(i)(integer) 列序号 %% @param(w)(integer) 新宽度 0 %% **} vi := FColsWidths[i]; if vi >= 0 and w >= 0 and vi <> w then UpDateColumWidth(i,w); end function DrawCell(cvs,rec,i,j);virtual; begin {** @explan(说明) 绘制单元格 %% @param(cvs)(tcustomcanvas) 画布 %% @param(rec)(array) array(左上右下) %% @param(i)(integer) 行号 %% @param(j)(integer) 列号 %% **} dr := array(rec[0:1],rec[2:3]); if i0 then ps[2]:= min(ClientRect[2]-FMarginRight,ps[2]); if FMarginBottom>0 then ps[3]:= min(ClientRect[3]-FMarginBottom,ps[3]); FValidateRect := ps; tp := ps[1]; bo := ps[3]; //***************计算表头区域******************* basex := FMarginLeft-xpos * FColWidth; x := basex; x2 := FMarginLeft; cvs.Font := font; drawcol := array(); for i,v in FColsWidths.Data do begin if i= ps[0])and x2= FColumFixed then begin if(x+v >= ps[0])and x= ps[1])and y2= FFixedRows then begin if(y+v >= ps[1])and y= vj[1]then continue; for i,vi in drawrow do begin if i= FColumFixed then begin if FindMerge(i,j,mergb)then begin end else partb[partbl++]:= array(array(vj[0],vi[0],vj[1],vi[1]),i,j); end else if i >= FFixedRows and j= FFixedRows and j >= FColumFixed then begin if FindMerge(i,j,mergd)then begin end else partd[partdl++]:= array(array(vj[0],vi[0],vj[1],vi[1]),i,j); end end end if parta or merga then begin DrawAllParts(cvs,parta,merga,array(FMarginLeft,FMarginTop,FXfiexed,FYfiexed)); end if partb or mergb then begin DrawAllParts(cvs,partb,mergb,array(FXfiexed,FMarginTop,ps[2],FYfiexed)); end if partc or mergc then begin DrawAllParts(cvs,partc,mergc,array(FMarginLeft,FYfiexed,FXfiexed,ps[3])); end if partd or mergd then begin DrawAllParts(cvs,partd,mergd,array(FXfiexed,FYfiexed,ps[2],ps[3])); end end function MouseDown(o,e);override; begin if csDesigning in ComponentState then return false; if e.button()<> mbLeft then return false; if FC_CURRENT=FC_SIZE then //调整大小 begin FSizeColum := 1; _wapi.ClipCursor(FCursorRect); return true; end else if FC_CURRENT=FC_SIZE2 then begin FSizeColum := 2; _wapi.ClipCursor(FCursorRect); return true; end end function MouseUp(o,e);override; begin if FSizeColum then begin FSizeColum := false; _wapi.ClipCursor(0); return true; end end function MouseMove(o,e);override; begin if csDesigning in ComponentState then return false; if not FMouseSizeColumnWidth then begin setcursornormal(); return 0; end y := e.yPos; X := e.xpos; if FMouseSizeColumnWidth .& 1>0 then begin if x0)and FVariableRows then begin basey := FMarginTop; if y >= FYfiexed then begin xdx := GetYpos(); basey := FMarginTop-FRowHeight * xdx; end end if(FMouseSizeColumnWidth=0)then begin setcursornormal(); return 0; end if FColsWidths.length()>0 and GetItemCount()>0 and x>(FMarginLeft+5)and y>(FMarginTop+5) {and y<(FMarginTop+FRowHeight*FFixedRows) }then begin if FSizeColum=1 then begin wd := FColsWidths[FCurrentSizeId]; UpDateColumWidth(FCurrentSizeId,wd+x-FCurrentSizePos); FCurrentSizePos := x; return true; end else if FSizeColum=2 then begin wd := FRowsHeight[FCurrentSizeId]; UpDateRowWidth(FCurrentSizeId,wd+y-FCurrentSizePos); FCurrentSizePos := y; return true; end else begin bx := basex; rc := ClientRect; if FMouseSizeColumnWidth .& 1>0 then begin for i,v in FColsWidths.Data do begin if abs(x-bx-v)<3 then begin FCurrentSizeId := i; FCurrentSizePos := x; FCursorRect := array(clientToScreen(max(bx+6,rc[0]+6),y-10),clientToScreen(rc[2],y+10)); setcursorsize(); return true; end bx += v; end end if FVariableRows and(FMouseSizeColumnWidth .& 2>0)then begin bx := basey; for i,v in FRowsHeight.Data do begin if abs(y-bx-v)<3 then begin FCurrentSizeId := i; FCurrentSizePos := y; FCursorRect := array(clientToScreen(x-10,max(rc[1]+6,bx+6)),clientToScreen(x+10,rc[3])); setcursorsize2(); return true; end bx += v; end end end end setcursornormal(); return false; end function MergeCells(cells); begin {** @explan(说明) 单元格 %% @param(cells)(array) array(开始行,开始列,结束行,结束列) %% **} nm := new TMerger(); nm.SetMergeCells(cells); if nm.isok then begin if not ifarray(FMergers)then FMergers := array(); FMergers[length(FMergers)]:= nm; end end function GetMergeInfo(); begin {** @explan(说明) 获得合并信息 %% **} r := array(); for i,v in FMergers do begin r[i]:= v.FCells; end return r; end function CleanMergeCells(); begin {** @explan(说明) 清空合并信息 %% **} FMergers := array(); end //******************* property ItemCount read GetItemCount write SetItemCount; property ItemHeight read FRowHeight write SetRowHeigt; property MouseSizeCell read FMouseSizeColumnWidth write FMouseSizeColumnWidth; property FixedRows read FFixedRows write SetFixedRows; property FixedColumns read FColumFixed write SetFixedColumns; property ColumnCount read GetColumnCount; property VariableRows read FVariableRows write SetVariableRows; {** @param(ItemCount)(integer) 行数 %% @param(MouseSizeCell)(bool) 鼠标改变列宽 %% @param(FixedRows)(integer) 固定的行数作为列标 %% **} private function GetGridMargin(); begin return array(FMarginLeft,FMarginTop,FMarginRight,FMarginBottom); end function SetGridMargin(l,t,r,b); begin if l >= 0 then nl := integer(l); if t >= 0 then nt := integer(t); if r >= 0 then nr := integer(r); if b >= 0 then nb := integer(b); f := false; if nl >= 0 and nl <> FMarginLeft then begin f := true; FMarginLeft := nl; end if nt >= 0 and nt <> FMarginTop then begin f := true; FMarginTop := nt; end if nr >= 0 and nr <> FMarginRight then begin //f := true; FMarginRight := nr; end if nb >= 0 and nb <> FMarginBottom then begin //f := true; FMarginBottom := nb; end if f then DoControlAlign(); end function allwidth(); begin return FxWidth; end function allheigth(); begin return FyHeight; end function DrawAllParts(cvs,part,merg,rec); begin bcvs := new TCanvsRgnClipAutoSave(cvs,rec); for i,v in part do DrawCell(cvs,v[0],v[1],v[2]); drawmerge(cvs,merg); return; end function drawmerge(cvs,merga); begin for i,v in merga do begin rec := GetMergRect(v); if not rec then return; v.mergeid(ri,ci); DrawCell(cvs,rec,ri,ci); end end function GetMergRect(mr); begin rg := mr.GetRange(); rec := GetSubItemRect(rg[0],rg[1]); rec2 := GetSubItemRect(rg[2],rg[3]); if rec and rec2 then begin rec[2:3]:= rec2[2:3]; return rec; end return array(); end function FindMerge(i,j,ret); begin for ii,v in FMergers do begin if v.CellInMerge(i,j)then begin f := true; for k := 0 to length(ret)-1 do begin if ret[k]=v then begin f := false; break; end end if f then begin ret[length(ret)]:= v; end return v; end end end function GetItemCount(); begin if FVariableRows then return FRowsHeight.Length(); return FItemCount; end function SetVariableRows(v); begin nv := v?true:false; if nv <> FVariableRows then begin if not FVariableRows then begin if FItemCount>0 then begin FRowsHeight.splices(0,FRowsHeight.length(),(zeros(FItemCount)+FRowHeight)); end end else begin FItemCount := FRowsHeight.Length(); end FVariableRows := nv; DoControlAlign(); end end function GetColumnCount(); begin return FColsWidths.length(); end function SetItemCount(ct); begin if FItemCount <> ct and ct >= 0 then begin FItemCount := ct; if not FVariableRows then DoControlAlign(); end end function SetRowHeigt(h); begin if FRowHeight <> h and h >= 5 then begin FRowHeight := h; DoControlAlign(); end end function SetFixedColumns(rs); begin if rs >= 0 and FColumFixed <> rs then begin FColumFixed := rs; DoControlAlign(); end end function SetFixedRows(rs); begin if rs >= 0 and FFixedRows <> rs then begin FFixedRows := rs; DoControlAlign(); end end function UpDateColumWidth(idx,value); begin if idx >= 0 and value >= 0 then begin if FColsWidths[idx]=value then return; FColsWidths[idx]:= value; DoControlAlign(); end end function UpDateRowWidth(idx,value); begin if FVariableRows and idx >= 0 and value>0 then begin if FRowsHeight[idx]=value then return; FRowsHeight[idx]:= value; DoControlAlign(); end end function UpDateFixed(); //更新固定宽度 begin xfix := 0; FxWidth := 0; nx := min(FColumFixed,FColsWidths.length())-1; for i := 0 to FColsWidths.length()-1 do begin vi := FColsWidths[i]; if i <= nx then xfix += vi; FxWidth += vi; end if FVariableRows then begin FyHeight := FMarginTop; FYfiexed := FMarginTop; ny := min(FFixedRows,FRowsHeight.length())-1; for i := 0 to FRowsHeight.length()-1 do begin vi := FRowsHeight[i]; if i <= ny then FYfiexed += vi; FyHeight += vi; end end else begin FyHeight := FRowHeight*FItemCount; FYfiexed := FMarginTop+FFixedRows * FRowHeight; end FXfiexed := FMarginLeft+xfix; end function setcursorsize2(); begin IF FC_CURRENT <> FC_SIZE2 then begin cursor := FC_SIZE2; FC_CURRENT := FC_SIZE2; end end function setcursorsize(); begin IF FC_CURRENT <> FC_SIZE then begin cursor := FC_SIZE; FC_CURRENT := FC_SIZE; end end function setcursornormal(); begin if FC_CURRENT <> FC_NORMAL then begin cursor := FC_NORMAL; FC_CURRENT := FC_NORMAL; end end FScroolChanged; FMergers; FAutoScroll; //固定*********** FXfiexed; FYfiexed; //********鼠标************* FC_NORMAL; FC_SIZE; FC_SIZE2; FC_CURRENT; //******位置*************** FMarginLeft; FMarginTop; FMarginRight; FMarginBottom; //*******表头*********** FColWidth; FRowWidth; // 变高基础高度 FxWidth; FyHeight; FFixedRows; FColsWidths; FRowsHeight; FColumFixed; FRowHeight; FVariableRows; //列高可变 //****************表体******************* FItemCount; //*******滚动条******* //调整列宽 FMouseSizeColumnWidth; FSizeColum; FCursorRect; FCurrentSizeId; FCurrentSizePos; end implementation type TPAINTCOUNT=class()//绘制标记 function create(v); begin FPainter := v; v.IncPaintLock(); end function Destroy(); begin FPainter.DecPaintLock(); FPainter := nil; end FPainter; end type TMerger=class()//合并单元格类型 public FCells; function Create(); begin FCells := array(); // r,c value end function isok(); begin return length(FCells); end function mergeid(i,j);//是否合并 begin i := FCells[0]; j := FCells[1]; end function CellInMerge(i,j);//是属于某个合并 begin if isok()then begin if i >= FCells[0]and i <= FCells[2]and j >= FCells[1]and j <= FCells[3]then return true; end return false; end function GetRange();//获得合并的区域 begin r := array(); if isok()then begin return FCells; end return r; end function SetMergeCells(rec);//合并区域 begin FCells := array(); if not ifarray(rec)then return; if(rec[2]>= rec[0]and rec[3]>rec[1])or(rec[2]>rec[0]and rec[3]>= rec[1])then FCells := rec; end end end.