（附代码）问题没解决啊~ ( 积分: 200 )

oly102 · 2005-12-01

我想把StringGrid当容器，动态创建多个TShape控件，请问怎么使TShape控件能够随着StringGrid的滚动条而滚动。其中标题合并也不理想~
请各位大侠帮忙啊
//新建一工程，在FORM1上放一StringGRID,改名GanttGrid,行个数设为多行到出现滚动条~
//2个DateTimePicker控件,2个Button
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, StdCtrls, Buttons,ExtCtrls, ComCtrls;

type
TForm1 = class(TForm)
GanttGrid: TStringGrid;
BitBtn1: TBitBtn;
Button1: TButton;
DateTimePicker1: TDateTimePicker;
DateTimePicker2: TDateTimePicker;
procedure GanttGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure FormShow(Sender: TObject);
procedure GanttGridTopLeftChanged(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
procedure MyCreateShape(sLabelCaption:String;iLeft,iTop,iWidth,iHeight:integer);
procedure MyCreateLabel(sContent:string;iLeft,iTop:integer);
procedure FillGanttGridTitle(StarDate,EndDate:string);
procedure ClearDynamicComponet(sGrid : TStringGrid);
{ Public declarations }
end;

var
Form1: TForm1;
bFillGrid:boolean;
implementation

{$R *.dfm}
procedure TForm1.ClearDynamicComponet(sGrid : TStringGrid);
//清除动态控件
var i,j : integer;
begin
{ with sGrid do
begin
for i := 0 to ComponentCount- 1 do
begin
if Components is TShape then
TShape(Components).Free;
if Components is TLabel then
TShape(Components).Free;
end;
end; }
with sGrid do
begin
j:=0;
for i := 0 to ComponentCount- 1 do
begin
if Components[j] is TShape then
begin
TShape(Components[j]).Free;
j:=j-1;
end
else if Components[j] is TLabel then
begin
TShape(Components[j]).Free;
j:=j-1;
end;
j:=j+1;
end;
end;
end;
//-----------------------------------------------------------------
procedure TForm1.FillGanttGridTitle(StarDate,EndDate:string);
var tmpDate,eDate:TDate;
i:integer;
begin
if (StarDate='') or (EndDate='') then exit;
try
tmpDate:=strToDate(StarDate);
except
Application.MessageBox('日期错误','提示;',MB_OK);
exit;
end;
try
eDate:=strToDate(EndDate)+1;
except
Application.MessageBox('日期错误','提示',MB_OK);
exit;
end;

GanttGrid.ColCount:=Round((eDate-tmpDate)*6)+1;
i:=0;
while tmpDate<eDate do
begin
GanttGrid.Cells[i*6+0,1]:='4';
GanttGrid.Cells[i*6+1,1]:='8';
GanttGrid.Cells[i*6+2,1]:='12';
GanttGrid.Cells[i*6+3,1]:='16';
GanttGrid.Cells[i*6+4,1]:='20';
GanttGrid.Cells[i*6+5,1]:='24';
GanttGrid.ColWidths[i*6+0]:=30;
GanttGrid.ColWidths[i*6+1]:=30;
GanttGrid.ColWidths[i*6+2]:=30;
GanttGrid.ColWidths[i*6+3]:=30;
GanttGrid.ColWidths[i*6+4]:=30;
GanttGrid.ColWidths[i*6+5]:=30;
GanttGrid.ColWidths[0]:=30;
i:=i+1;
tmpDate:=tmpDate+1;
end;
GanttGrid.ColWidths[i*6]:=-1;
end;
//---------------------------------------------------------------------
procedure TForm1.GanttGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
Var iRect : TRect;
Xi,Yi ,iCol,iColCount,iColWidth,m,n,iday,iRow: Integer;
iStr : String;
tmpDate,eDate:TDate;
begin
if not bFillGrid then exit;
With TStringGrid(Sender) Do
begin
// GanttGrid.Cells[0,ARow+1]:=inttostr(ARow+1);
iColCount:=6;
iColWidth:=30;
ColWidths[ACol]:=30;
tmpDate:=DateTimePicker1.Date;
eDate:=DateTimePicker2.Date;

iday:=Round(eDate-tmpDate+1);
if iDay<=0 then exit;

n:=(ACol div iColCount);
m:=(ACol mod iColCount);
if m<>0 then n:=n+1;
if n>iDay then exit;
iStr:=DateToStr(tmpDate+n-1);

iRect.Left := CellRect(ACol-m,0).Left;
iRect.Top := CellRect(ACol,0).Top;
iRect.Right := CellRect(ACol,0).Right;
iRect.Bottom :=CellRect(ACol,0).Bottom ;

canvas.Font.Size :=11; &Ograve;&raquo;&micro;&atilde;&iexcl;&pound;
canvas.Font.Color:=clBlue;
canvas.Font.Style:=[fsBold];
Canvas.Brush.Color:=clMenu;

Canvas.FillRect(iRect);

Xi := (iRect.Right-iRect.Left-Canvas.TextWidth(iStr)) div 2;
Xi := iRect.Left+Xi;
Yi := 1;

if (iColCount-m)=1 then
Canvas.TextOut(Xi,Yi,iStr);
iRow:=3;
iCol:=2;
if (ARow=iRow) and (ACol=iCol) then
MyCreateShape('任务1耗时20小时',CellRect(iCol,iRow).Left,GanttGrid.RowHeights[1]*iRow+6+iRow,155,12);
iCol:=5;
iRow:=8;
if (ARow=iRow) and (ACol=iCol) then
MyCreateShape('任务2耗时16小时',CellRect(iCol,iRow).Left,RowHeights[1]*iRow+6+iRow,124,12);
end;
end;
//------------------------------------------------------
procedure TForm1.FormShow(Sender: TObject);
begin
bFillGrid:=false;
end;
//------------------------------------------------------
procedure TForm1.GanttGridTopLeftChanged(Sender: TObject);
begin
GanttGrid.Refresh;
end;
//------------------------------------------------------
procedure TForm1.MyCreateLabel(sContent:string;iLeft,iTop:integer);
var myLabel:TLabel;
begin
myLabel:=TLabel.Create(GanttGrid);
myLabel.Parent:=GanttGrid;
myLabel.Left:=iLeft;
myLabel.Top:=iTop;
myLabel.Caption:=sContent;
// myLabel.AutoSize:=true;
myLabel.Width:=Length(sContent)*7;
myLabel.Transparent:=true;
end;
//----------------------------------------------------------------------
procedure TForm1.MyCreateShape(sLabelCaption:String;iLeft,iTop,iWidth,iHeight:integer);
var myShape:TShape;
begin
myShape:=TShape.Create(GanttGrid);
myShape.Parent:=GanttGrid;
myShape.Left:=iLeft;
myShape.Top:=iTop;
mySHape.Width:=iWidth;
myShape.Height:=iHeight;
myShape.Brush.Color:=clred;
MyCreateLabel(sLabelCaption,iLeft+iWidth+2,iTop);

end;
//----------------------------------------------------------------------
procedure TForm1.BitBtn1Click(Sender: TObject);
var iRow:integer ;
begin
bFillGrid:=true;
FillGanttGridTitle(DateToStr(DateTimePicker1.Date),DateToStr(DateTimePicker2.Date));
// MyCreateShape('任务1耗时20小时',CellRect(iCol,iRow).Left,GanttGrid.RowHeights[1]*iRow+6+iRow,155,12);
// MyCreateShape('任务2耗时16小时',CellRect(iCol,iRow).Left,RowHeights[1]*iRow+6+iRow,124,12);
end;
//----------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
begin
ClearDynamicComponet(GanttGrid);
end;
//----------------------------------------------------------------------
end.

oly102 · 2005-12-01

我想把StringGrid当容器，动态创建多个TShape控件，请问怎么使TShape控件能够随着StringGrid的滚动条而滚动。其中标题合并也不理想~
请各位大侠帮忙啊
//新建一工程，在FORM1上放一StringGRID,改名GanttGrid,行个数设为多行到出现滚动条~
//2个DateTimePicker控件,2个Button
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, StdCtrls, Buttons,ExtCtrls, ComCtrls;

type
TForm1 = class(TForm)
GanttGrid: TStringGrid;
BitBtn1: TBitBtn;
Button1: TButton;
DateTimePicker1: TDateTimePicker;
DateTimePicker2: TDateTimePicker;
procedure GanttGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure FormShow(Sender: TObject);
procedure GanttGridTopLeftChanged(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
procedure MyCreateShape(sLabelCaption:String;iLeft,iTop,iWidth,iHeight:integer);
procedure MyCreateLabel(sContent:string;iLeft,iTop:integer);
procedure FillGanttGridTitle(StarDate,EndDate:string);
procedure ClearDynamicComponet(sGrid : TStringGrid);
{ Public declarations }
end;

var
Form1: TForm1;
bFillGrid:boolean;
implementation

{$R *.dfm}
procedure TForm1.ClearDynamicComponet(sGrid : TStringGrid);
//清除动态控件
var i,j : integer;
begin
{ with sGrid do
begin
for i := 0 to ComponentCount- 1 do
begin
if Components is TShape then
TShape(Components).Free;
if Components is TLabel then
TShape(Components).Free;
end;
end; }
with sGrid do
begin
j:=0;
for i := 0 to ComponentCount- 1 do
begin
if Components[j] is TShape then
begin
TShape(Components[j]).Free;
j:=j-1;
end
else if Components[j] is TLabel then
begin
TShape(Components[j]).Free;
j:=j-1;
end;
j:=j+1;
end;
end;
end;
//-----------------------------------------------------------------
procedure TForm1.FillGanttGridTitle(StarDate,EndDate:string);
var tmpDate,eDate:TDate;
i:integer;
begin
if (StarDate='') or (EndDate='') then exit;
try
tmpDate:=strToDate(StarDate);
except
Application.MessageBox('日期错误','提示;',MB_OK);
exit;
end;
try
eDate:=strToDate(EndDate)+1;
except
Application.MessageBox('日期错误','提示',MB_OK);
exit;
end;

GanttGrid.ColCount:=Round((eDate-tmpDate)*6)+1;
i:=0;
while tmpDate<eDate do
begin
GanttGrid.Cells[i*6+0,1]:='4';
GanttGrid.Cells[i*6+1,1]:='8';
GanttGrid.Cells[i*6+2,1]:='12';
GanttGrid.Cells[i*6+3,1]:='16';
GanttGrid.Cells[i*6+4,1]:='20';
GanttGrid.Cells[i*6+5,1]:='24';
GanttGrid.ColWidths[i*6+0]:=30;
GanttGrid.ColWidths[i*6+1]:=30;
GanttGrid.ColWidths[i*6+2]:=30;
GanttGrid.ColWidths[i*6+3]:=30;
GanttGrid.ColWidths[i*6+4]:=30;
GanttGrid.ColWidths[i*6+5]:=30;
GanttGrid.ColWidths[0]:=30;
i:=i+1;
tmpDate:=tmpDate+1;
end;
GanttGrid.ColWidths[i*6]:=-1;
end;
//---------------------------------------------------------------------
procedure TForm1.GanttGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
Var iRect : TRect;
Xi,Yi ,iCol,iColCount,iColWidth,m,n,iday,iRow: Integer;
iStr : String;
tmpDate,eDate:TDate;
begin
if not bFillGrid then exit;
With TStringGrid(Sender) Do
begin
// GanttGrid.Cells[0,ARow+1]:=inttostr(ARow+1);
iColCount:=6;
iColWidth:=30;
ColWidths[ACol]:=30;
tmpDate:=DateTimePicker1.Date;
eDate:=DateTimePicker2.Date;

iday:=Round(eDate-tmpDate+1);
if iDay<=0 then exit;

n:=(ACol div iColCount);
m:=(ACol mod iColCount);
if m<>0 then n:=n+1;
if n>iDay then exit;
iStr:=DateToStr(tmpDate+n-1);

iRect.Left := CellRect(ACol-m,0).Left;
iRect.Top := CellRect(ACol,0).Top;
iRect.Right := CellRect(ACol,0).Right;
iRect.Bottom :=CellRect(ACol,0).Bottom ;

canvas.Font.Size :=11; &Ograve;&raquo;&micro;&atilde;&iexcl;&pound;
canvas.Font.Color:=clBlue;
canvas.Font.Style:=[fsBold];
Canvas.Brush.Color:=clMenu;

Canvas.FillRect(iRect);

Xi := (iRect.Right-iRect.Left-Canvas.TextWidth(iStr)) div 2;
Xi := iRect.Left+Xi;
Yi := 1;

if (iColCount-m)=1 then
Canvas.TextOut(Xi,Yi,iStr);
iRow:=3;
iCol:=2;
if (ARow=iRow) and (ACol=iCol) then
MyCreateShape('任务1耗时20小时',CellRect(iCol,iRow).Left,GanttGrid.RowHeights[1]*iRow+6+iRow,155,12);
iCol:=5;
iRow:=8;
if (ARow=iRow) and (ACol=iCol) then
MyCreateShape('任务2耗时16小时',CellRect(iCol,iRow).Left,RowHeights[1]*iRow+6+iRow,124,12);
end;
end;
//------------------------------------------------------
procedure TForm1.FormShow(Sender: TObject);
begin
bFillGrid:=false;
end;
//------------------------------------------------------
procedure TForm1.GanttGridTopLeftChanged(Sender: TObject);
begin
GanttGrid.Refresh;
end;
//------------------------------------------------------
procedure TForm1.MyCreateLabel(sContent:string;iLeft,iTop:integer);
var myLabel:TLabel;
begin
myLabel:=TLabel.Create(GanttGrid);
myLabel.Parent:=GanttGrid;
myLabel.Left:=iLeft;
myLabel.Top:=iTop;
myLabel.Caption:=sContent;
// myLabel.AutoSize:=true;
myLabel.Width:=Length(sContent)*7;
myLabel.Transparent:=true;
end;
//----------------------------------------------------------------------
procedure TForm1.MyCreateShape(sLabelCaption:String;iLeft,iTop,iWidth,iHeight:integer);
var myShape:TShape;
begin
myShape:=TShape.Create(GanttGrid);
myShape.Parent:=GanttGrid;
myShape.Left:=iLeft;
myShape.Top:=iTop;
mySHape.Width:=iWidth;
myShape.Height:=iHeight;
myShape.Brush.Color:=clred;
MyCreateLabel(sLabelCaption,iLeft+iWidth+2,iTop);

end;
//----------------------------------------------------------------------
procedure TForm1.BitBtn1Click(Sender: TObject);
var iRow:integer ;
begin
bFillGrid:=true;
FillGanttGridTitle(DateToStr(DateTimePicker1.Date),DateToStr(DateTimePicker2.Date));
// MyCreateShape('任务1耗时20小时',CellRect(iCol,iRow).Left,GanttGrid.RowHeights[1]*iRow+6+iRow,155,12);
// MyCreateShape('任务2耗时16小时',CellRect(iCol,iRow).Left,RowHeights[1]*iRow+6+iRow,124,12);
end;
//----------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
begin
ClearDynamicComponet(GanttGrid);
end;
//----------------------------------------------------------------------
end.

oly102 · 2005-12-01

帮帮忙~给点思路也行啊。

jlutt-sadan · 2005-12-01

兄弟，闪烁相当严重。。。你这样还不如直接在Cell中把需要的东东画出来。
在某一个cell中画一个长方形的红方块
procedure TForm1.GanttGridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
ShapeRect: TRect;
MBitmap: TBitmap;
begin
if (ACol = 3) and (ARow>0) then begin
MBitmap := TBitmap.Create;
try
MBitmap.Width := Rect.Right - Rect.Left;
MBitmap.Height := Rect.Bottom - Rect.Top;
ShapeRect := Classes.Rect(0, 0, MBitmap.Width, MBitmap.Height);
with MBitmap.Canvas do begin
Brush.Color := GanttGrid.Color;
FillRect(ShapeRect);
InflateRect(ShapeRect, -3, -4);
Brush.Color := clRed;
FillRect(ShapeRect);
Pen.Color := clBlack;
Rectangle(ShapeRect);
end;
GanttGrid.Canvas.Draw(Rect.Left, Rect.Top, MBitmap);
finally
MBitmap.Free;
end;
end;
end;
至于其他的条件，字什么的都可以这样做

oly102 · 2005-12-01

谢谢~，这闪烁的问题，是我把MyCreateShape函数放错地方了，应该放在BUTTON1单击事件中。~我的原来的意思是单击
BUTTON控件后获得某定单所在任务的的时间，从该时间起创建一个SHAPE来显示。
我先去吃饭~

oly102 · 2005-12-01

这个我暂时还不想结，请大侠到这里来领分。谢谢！
http://www.delphibbs.com/delphibbs/dispq.asp?lid=3282500

oly102 · 2005-12-02

问题还没解决，在跨单元格填充文字时，单击滚动条单步按钮，文字也跟着CELL走动~
而图象在跨单元格Draw时会被重新覆盖~，如果已单个单元格DRAW画多格，则在格与格之间有线条~

（附代码）问题没解决啊~ ( 积分: 200 )

oly102

Unregistered / Unconfirmed

oly102

Unregistered / Unconfirmed

oly102

Unregistered / Unconfirmed

jlutt-sadan

Unregistered / Unconfirmed

oly102

Unregistered / Unconfirmed

oly102

Unregistered / Unconfirmed

oly102

Unregistered / Unconfirmed

Similar threads