type TMoveSG = class(TCustomGrid); // reveals protected MoveRow procedure {...}
procedure SortGridByCols(Grid: TStringGrid; ColOrder: array of Integer);
var i, j: Integer; Sorted: Boolean;
function Sort(Row1, Row2: Integer): Integer;
var C: Integer;
begin
C := 0; Result := AnsiCompareStr(Grid.Cols[ColOrder[C]][Row1], Grid.Cols[ColOrder[C]][Row2]);
if Result = 0 then begin
Inc(C); while (C < = High(ColOrder)) and (Result = 0) do begin
Result := AnsiCompareStr(Grid.Cols[ColOrder[C]][Row1],
Grid.Cols[ColOrder[C]][Row2]); Inc(C);
end; end; end;
begin
if SizeOf(ColOrder) div SizeOf(i) < > Grid.ColCount then Exit;
for i := 0 to High(ColOrder) do
if (ColOrder[i] < 0) or (ColOrder[i] >= Grid.ColCount) then Exit; j := 0; Sorted := False;
repeat
Inc(j); with Grid do
for i := 0 to RowCount - 2 do if Sort(i, i + 1) > 0 then begin
TMoveSG(Grid).MoveRow(i + 1, i); Sorted := False; end;
until Sorted or (j = 1000); Grid.Repaint;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{ Sort rows based on the contents of two or more columns.
Sorts first by column 1. If there are duplicate values
in column 1, the next sort column is column 2 and so on...}
SortGridByCols(StringGrid1, [1, 2, 0, 3, 4]);
end;
type TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private {...}
public {...}
end;
type TStringGridHack = class(TStringGrid)
protected
procedure DeleteRow(ARow: Longint); reintroduce;
procedure InsertRow(ARow: Longint);
end;
var Form1: TForm1;
implementation {$R *.DFM}
procedure TStringGridHack.DeleteRow(ARow: Longint);
var GemRow: Integer;
begin
GemRow := Row; if RowCount > FixedRows + 1 then inherited DeleteRow(ARow)
else Rows[ARow].Clear; if GemRow < RowCount then Row := GemRow;
end;
procedure TStringGridHack.InsertRow(ARow: Longint);
var GemRow: Integer;
begin
GemRow := Row; while ARow < FixedRows do Inc(ARow); RowCount := RowCount + 1;
MoveRow(RowCount - 1, ARow); Row := GemRow; Rows[Row].Clear;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin // Insert Row, Zeile hinzufügen
TStringGridHack(StringGrid1).InsertRow(1); // Remove Row, Zeile entfernen
TStringGridHack(StringGrid1).DeleteRow(2);
end;
end.
var LastRow, LastCol : Integer;
//Pokaz dymka celi
procedure TForm1.ShowCellHint(X,Y:Integer);
var ACol, ARow : Integer;
begin //ShowHint auf True setzen
If StringGrid.ShowHint = False Then StringGrid.ShowHint := True; //Col und Row Position lesen
StringGrid.MouseToCell(X, Y, ACol, ARow); //wenn im gültigen Bereich zeige Zelleninhalt als Hint
If (ACol < > -1) And (ARow < > -1) Then StringGrid.Hint:=StringGrid.Cells[ACol,ARow];
If (ACol < > LastCol) or (ARow < > LastRow) Then begin
Application.CancelHint; LastCol:=ACol; LastRow:=ARow;
end; end;
//Przykład po przesunięciu myszy nad celę:
procedure TForm1.StringGridMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
ShowCellHint(X,Y);
end;
uses Clipbrd;
//Kopiowanie
procedure TForm1.Button1Click(Sender: TObject);
var S: string; GRect: TGridRect; C, R: Integer;
begin
GRect := StringGrid1.Selection; S := '';
for R := GRect.Top to GRect.Bottom do begin
for C := GRect.Left to GRect.Right do begin
if C = GRect.Right then S := S + (StringGrid1.Cells[C, R])
else S := S + StringGrid1.Cells[C, R] + #9; end; S := S + #13#10; end;
ClipBoard.AsText := S;
end;
// Wstawianie
procedure TForm1.Button2Click(Sender: TObject);
var Grect: TGridRect; S, CS, F: string; L, R, C: Byte;
begin
GRect := StringGrid1.Selection; L := GRect.Left; R := GRect.Top; S := ClipBoard.AsText; R := R - 1;
while Pos(#13, S) > 0 do begin
R := R + 1; C := L - 1; CS := Copy(S, 1,Pos(#13, S));
while Pos(#9, CS) > 0 do begin C := C + 1;
if (C < = StringGrid1.ColCount - 1) and (R < = StringGrid1.RowCount - 1) then
StringGrid1.Cells[C, R] := Copy(CS, 1,Pos(#9, CS) - 1); F := Copy(CS, 1,Pos(#9, CS) - 1);
Delete(CS, 1,Pos(#9, CS)); end;
if (C < = StringGrid1.ColCount - 1) and (R < = StringGrid1.RowCount - 1) then
StringGrid1.Cells[C + 1,R] := Copy(CS, 1,Pos(#13, CS) - 1); Delete(S, 1,Pos(#13, S));
if Copy(S, 1,1) = #10 then Delete(S, 1,1);
end; end;
W selektorze właściwości wybrać (klik) opcję OnDrawCell, która po uzupełnieniu powinna mieć taką postać:
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
const SelectedColor = Clblue;
begin
if (state = [gdSelected]) then with TStringGrid(Sender), Canvas do begin
Brush.Color := SelectedColor; FillRect(Rect);
TextRect(Rect, Rect.Left + 2, Rect.Top + 2, Cells[aCol, aRow]);
end; end;
{ 1. wersja }
procedure TForm1.Button1Click(Sender: TObject);
var i, k: Integer;
begin
with StringGrid1 do for i := 0 to ColCount - 1 do for k := 0 to RowCount - 1 do Cells[i, k] := '';
end;
{ 2. wersja - szybsza w działaniu }
procedure TForm1.Button2Click(Sender: TObject);
var I: Integer;
begin
for I := 0 to StringGrid1.RowCount - 1 do StringGrid1.Rows[I].Clear();
end;
type TStringGridHack = class(TStringGrid)
public
procedure DeleteCol(ACol: Longint);
end;
var Form1: TForm1;
implementation
procedure TStringGridHack.DeleteCol(ACol: Longint);
begin
if ACol = FixedCols then if ACol = (ColCount - 1) then begin Cols[ACol].Clear;
if ColCount(FixedCols + 1) then ColCount := (ColCount - 1);
end else begin Cols[ACol] := Cols[ACol + 1]; DeleteCol(ACol + 1);
end; end;
Zapis TStringGrid do pliku
procedure SaveStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var f: TextFile; i, k: Integer;
begin
AssignFile(f, FileName); Rewrite(f); with StringGrid do begin // Write number of Columns/Rows
Writeln(f, ColCount); Writeln(f, RowCount); // loop through cells
for i := 0 to ColCount - 1 do for k := 0 to RowCount - 1 do Writeln(F, Cells[i, k]);
end; CloseFile(F);
end;
// Ładowanie TStringGrid z pliku
procedure LoadStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var f: TextFile; iTmp, i, k: Integer; strTemp: String;
begin
AssignFile(f, FileName); Reset(f); with StringGrid do begin // Get number of columns
Readln(f, iTmp); ColCount := iTmp; // Get number of rows
Readln(f, iTmp); RowCount := iTmp; // loop through cells i fill in values
for i := 0 to ColCount - 1 do for k := 0 to RowCount - 1 do begin
Readln(f, strTemp); Cells[i, k] := strTemp;
end; end; CloseFile(f);
end;
// Zapis StringGrid1 do pliku 'c:\temp.txt':
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveStringGrid(StringGrid1, 'c:\temp.txt');
end;
// Ładowanie StringGrid1 z 'c:\temp.txt':
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadStringGrid(StringGrid1, 'c:\temp.txt');
end;
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
var dx: Integer;
begin
with (Sender as TStringGrid) do begin // Don't change color for first Column, first row
if (ACol = 0) or (ARow = 0) then Canvas.Brush.Color := clBtnFace
else begin case ACol of
1: Canvas.Font.Color := clBlack; 2: Canvas.Font.Color := clBlue; end; // Draw the Band
if ARow mod 2 = 0 then Canvas.Brush.Color := $00E1FFF9
else Canvas.Brush.Color := $00FFEBDF;
Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, cells[acol, arow]); Canvas.FrameRect(Rect);
end; end; end;
procedure SortStringGrid(var GenStrGrid: TStringGrid; ThatCol: Integer);
const TheSeparator = '@'; // okreslenie separatora
var CountItem, I, J, K, ThePosition: integer; MyList: TStringList; MyString, TempString: string;
begin // Give the number of rows in the StringGrid
CountItem := GenStrGrid.RowCount; //Create the List
MyList := TStringList.Create; MyList.Sorted := False;
try begin for I := 1 to (CountItem - 1) do
MyList.Add(GenStrGrid.Rows[I].Strings[ThatCol] + TheSeparator + GenStrGrid.Rows[I].Text);
Mylist.Sort; //Sort the List
for K := 1 to Mylist.Count do begin //Take the String of the line (K – 1)
MyString := MyList.Strings[(K - 1)]; //Find the position of the Separator in the String
ThePosition := Pos(TheSeparator, MyString); TempString := '';
{Eliminate the Text of the column on which we have sorted the StringGrid}
TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
MyList.Strings[(K - 1)] := ''; MyList.Strings[(K - 1)] := TempString;
end;
// przeładowanie StringGrida danymi po sortowaniu
for J := 1 to (CountItem - 1) do
GenStrGrid.Rows[J].Text := MyList.Strings[(J - 1)];
end; finally //Free the List
MyList.Free;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// Sortowanie według kolumny 2 (1 bo pierwsza to 0)
SortStringGrid(StringGrid1, 1);
end;
procedure GridDeleteRow(RowNumber: Integer; Grid: TstringGrid);
var i: Integer;
begin
Grid.Row := RowNumber; if (Grid.Row = Grid.RowCount - 1) then { On the last row}
Grid.RowCount := Grid.RowCount - 1
else begin { Not the last row}
for i := RowNumber to Grid.RowCount - 1 do
Grid.Rows[i] := Grid.Rows[i + 1]; Grid.RowCount := Grid.RowCount - 1;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GridDeleteRow(3, stringGrid1);
end;
uses printers;
//StringGrid Inhalt ausdrucken
procedure PrintStringGrid(Grid: TStringGrid; Title: string; Orientation: TPrinterOrientation);
var P, I, J, YPos, XPos, HorzSize, VertSize: Integer;
AnzSeiten, Seite, Zeilen, HeaderSize, FooterSize, ZeilenSize, FontHeight: Integer;
mmx, mmy: Extended; Footer: string;
begin
//Kopfzeile, Fußzeile, Zeilenabstand, Schriftgröße festlegen
HeaderSize := 100; FooterSize := 200; ZeilenSize := 36; FontHeight := 36; //Printer initializieren
Printer.Orientation := Orientation; Printer.Title := Title; Printer.BeginDoc;
//Druck auf mm einstellen
mmx := GetDeviceCaps(Printer.Canvas.Handle, PHYSICALWIDTH) /
GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSX) * 25.4;
mmy := GetDeviceCaps(Printer.Canvas.Handle, PHYSICALHEIGHT) /
GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY) * 25.4;
VertSize := Trunc(mmy) * 10; HorzSize := Trunc(mmx) * 10;
SetMapMode(Printer.Canvas.Handle, MM_LOMETRIC);
//Zeilenanzahl festlegen
Zeilen := (VertSize - HeaderSize - FooterSize) div ZeilenSize; //Seitenanzahl ermitteln
if Grid.RowCount mod Zeilen < > 0 then AnzSeiten := Grid.RowCount div Zeilen + 1
else AnzSeiten := Grid.RowCount div Zeilen;
Seite := 1; //Grid Drucken
for P := 1 to AnzSeiten do begin //Kopfzeile
Printer.Canvas.Font.Height := 48;
Printer.Canvas.TextOut((HorzSize div 2 - (Printer.Canvas.TextWidth(Title) div 2)), - 20,Title);
Printer.Canvas.Pen.Width := 5; Printer.Canvas.MoveTo(0, - HeaderSize);
Printer.Canvas.LineTo(HorzSize, - HeaderSize); //Fußzeile
Printer.Canvas.MoveTo(0, - VertSize + FooterSize);
Printer.Canvas.LineTo(HorzSize, - VertSize + FooterSize);
Printer.Canvas.Font.Height := 36;
Footer := 'Seite: ' + IntToStr(Seite) + ' von ' + IntToStr(AnzSeiten);
Printer.Canvas.TextOut((HorzSize div 2 - (Printer.Canvas.TextWidth(Footer) div 2)), - VertSize + 150,Footer); //Zeilen drucken
Printer.Canvas.Font.Height := FontHeight; YPos := HeaderSize + 10;
for I := 1 to Zeilen do begin
if Grid.RowCount >= I + (Seite - 1) * Zeilen then begin XPos := 0;
for J := 0 to Grid.ColCount - 1 do begin
Printer.Canvas.TextOut(XPos, - YPos, Grid.Cells[J, I + (Seite - 1) * Zeilen - 1]); XPos := XPos + Grid.ColWidths[J] * 3;
end;
YPos := YPos + ZeilenSize; end; end; //Seite hinzufügen
Inc(Seite); if Seite < = AnzSeiten then Printer.NewPage; end; Printer.EndDoc;
end;
//Przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin //Drucken im Querformat
PrintStringGrid(Grid, 'StringGrid Print Landscape', poLandscape); //Drucken im Hochformat
PrintStringGrid(Grid, 'StringGrid Print Portrait', poPortrait);
end;
function IsCellSelected(StringGrid: TStringGrid; X, Y: Longint): Boolean;
begin
Result := False;
try if (X > = StringGrid.Selection.Left) and (X < = StringGrid.Selection.Right) and
(Y > = StringGrid.Selection.Top) and (Y < = StringGrid.Selection.Bottom) then Result := True;
except end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsCellSelected(stringgrid1, 2, 2) then ShowMessage('Cela (2,2) jest zaznaczona.');
end;
procedura tak dopasowuje szerokość kolumn aby tekst (i tylko tekst) w nich był widoczy w całości. W przykładzie ograniczono ilość rekordów do 10
type TGridHack = class(TCustomGrid);
procedure ResizeStringGrid(_Grid: TCustomGrid);
var Col, Row: integer; Grid: TGridHack; MaxWidth: integer; ColWidth: integer;
ColText: string; MaxRow: integer; ColWidths: array of integer;
begin
Grid := TGridHack(_Grid); SetLength(ColWidths, Grid.ColCount); MaxRow := 10;
if MaxRow > Grid.RowCount then MaxRow := Grid.RowCount;
for Col := 0 to Grid.ColCount - 1 do begin
MaxWidth := 0; for Row := 0 to MaxRow - 1 do begin
ColText := Grid.GetEditText(Col, Row); ColWidth := Grid.Canvas.TextWidth(ColText);
if ColWidth > MaxWidth then MaxWidth := ColWidth;
end;
if goVertLine in Grid.Options then Inc(MaxWidth, Grid.GridLineWidth);
ColWidths[Col] := MaxWidth + 4; Grid.ColWidths[Col] := ColWidths[Col];
end; end;
{1. wersja}
procedure SetGridColumnWidths(Grid: TStringGrid;
const Columns: array of Integer);
{autodopasowanie - autosize podczas dwukrotnego kliku myszą na nagłówku kolumny}
procedure AutoSizeGridColumn(Grid: TStringGrid; column, min, max: Integer);
{ Set for max and min some minimal/maximial Values}
var i: Integer; temp: Integer; tempmax: Integer;
begin
tempmax := 0; for i := 0 to (Grid.RowCount - 1) do begin
temp := Grid.Canvas.TextWidth(Grid.cells[column, i]);
if temp > tempmax then tempmax := temp;
if tempmax > max then begin tempmax := max; break; end;
end;
if tempmax < min then tempmax := min; Grid.ColWidths[column] := tempmax + Grid.GridLineWidth + 3;
end;
procedure TForm1.StringGrid1DblClick(Sender: TObject);
var P: TPoint; iColumn, iRow: Longint;
begin
GetCursorPos(P); with StringGrid1 do begin
P := ScreenToClient(P); MouseToCell(P.X, P.Y, iColumn, iRow);
if P.Y < DefaultRowHeight then AutoSizeGridColumn(StringGrid1, iColumn, 40, 100);
end; end;
{2. wersja }
procedure TForm1.Button1Click(Sender: TObject);
const DEFBORDER = 8;
var max, temp, i, n: Integer;
begin
with Grid do begin Canvas.Font := Font;
for n := Low(Columns) to High(Columns) do begin
max := 0; for i := 0 to RowCount - 1 do begin
temp := Canvas.TextWidth(Cells[Columns[n], i]) + DEFBORDER;
if temp > max then max := temp; end; { For }
if max > 0 then ColWidths[Columns[n]] := max;
end; { For }
end; { With }
end; {SetGridColumnWidths }
type TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
end; {...}
implementation
// wyświetla tekst pionowo w celach
procedure StringGridRotateTextOut(Grid: TStringGrid; ARow, ACol: Integer; Rect: TRect; Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);
var lf: TLogFont; tf: TFont;
begin // jak są fonty za duże to autodopasowanie
if (Size > Grid.ColWidths[ACol] div 2) then Size := Grid.ColWidths[ACol] div 2;
with Grid.Canvas do begin // to wymieni fonty
Font.Name := Schriftart; Font.Size := Size; Font.Color := Color; tf := TFont.Create;
try tf.Assign(Font); GetObject(tf.Handle, SizeOf(lf), @lf);
lf.lfEscapement := 900; lf.lfOrientation := 0; tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
finally tf.Free; end; // wypełni prostokąt
FillRect(Rect); // tekstem
if Alignment = taLeftJustify then
TextRect(Rect, Rect.Left + 2, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
if Alignment = taCenter then
TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size + Size div 3, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
if Alignment = taRightJustify then
TextRect(Rect, Rect.Right - Size - Size div 2 - 2, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
end; end;
// 2. wariant
procedure StringGridRotateTextOut2(Grid:TStringGrid;ARow,ACol:Integer;Rect:TRect;
Schriftart:String;Size:Integer;Color:TColor;Alignment:TAlignment);
var NewFont, OldFont : Integer; FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin // if the font is to big, resize it
If (Size > Grid.ColWidths[ACol] DIV 2) Then Size := Grid.ColWidths[ACol] DIV 2;
with Grid.Canvas do begin // Set font
If (fsBold IN Font.Style) Then FontStyle := FW_BOLD
Else FontStyle := FW_NORMAL;
If (fsItalic IN Font.Style) Then FontItalic := 1 Else FontItalic := 0;
If (fsUnderline IN Font.Style) Then FontUnderline := 1 Else FontUnderline := 0;
If (fsStrikeOut IN Font.Style) Then FontStrikeout:=1 Else FontStrikeout:=0;
Font.Color := Color;
NewFont := CreateFont(Size, 0, 900, 0, FontStyle, FontItalic,
FontUnderline, FontStrikeout, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH, PChar(Schriftart));
OldFont := SelectObject(Handle, NewFont); // fill the rectangle
FillRect(Rect); // Write text depending on the alignment
If Alignment = taLeftJustify Then TextRect(Rect,Rect.Left+2,Rect.Bottom-2,Grid.Cells[ACol,ARow]);
If Alignment = taCenter Then TextRect(Rect,Rect.Left+Grid.ColWidths[ACol] DIV 2 - Size + Size DIV 3,
Rect.Bottom-2,Grid.Cells[ACol,ARow]);
If Alignment = taRightJustify Then TextRect(Rect,Rect.Right-Size - Size DIV 2 - Rect.Bottom-2, Grid.Cells[ACol,ARow]); // Recreate reference to the old font
SelectObject(Handle, OldFont); // Recreate reference to the new font
DeleteObject(NewFont);
end; end;
// W metodzie OnDrawCell wpisać
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
// In the second column: Rotate Text by 90° and left align the text
if ACol = 1 then StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12,clRed, taLeftJustify);
// In the third column: Center the text
if ACol = 2 then StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue, taCenter);
// In all other columns third row: right align the text
if ACol > 2 then StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12,clGreen, taRightJustify);
end;
end.
//Dołączyć do formularza składnik ComboBox i StringGrid komponentu.
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ComboBox1Exit(Sender: TObject);
procedure StringGrid1SelectCell (Sender: TObject; Col, Row: Integer; var CanSelect: Boolean);
private { Private declarations }
public { Public declarations }
end;
varForm1: TForm1;
implementation
{$R *.DFM}
//zdarzenie OnCreate w Form
procedure TForm1.FormCreate(Sender: TObject);
begin
{Regulacja wysokości ComboBox do wysokości wiersza StringGrid}
StringGrid1.DefaultRowHeight := ComboBox1.Height;
ComboBox1.Visible := False; { Ukrywa ComboBox}
end;
// zdarzenie OnChange ComboBox
procedure TForm1.ComboBox1Change (Sender: TObject);
begin
StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row] := ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;
// to zdarzenie w OnExit ComboBox
procedure TForm1.ComboBox1Exit (Sender: TObject);
begin
StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row] := ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False; StringGrid1.SetFocus;
end;
// zdarzenie OnSelectCell stringgrida
procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col, Row: Integer; var CanSelect: Boolean);
var R: TRect;
begin
if ((Col = 3) AND (Row < > 0)) then begin
R := StringGrid1.CellRect(Col, Row);
R.Left := R.Left + StringGrid1.Left; R.Right := R.Right + StringGrid1.Left;
R.Top := R.Top + StringGrid1.Top; R.Bottom := R.Bottom + StringGrid1.Top;
ComboBox1.Left := R.Left + 1; ComboBox1.Top := R.Top + 1;
ComboBox1.Width := (R.Right + 1) - R.Left; ComboBox1.Height := (R.Bottom + 1) - R.Top;
ComboBox1.Visible := True; ComboBox1.SetFocus;
end; CanSelect := True;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.RowHeights[0] := 15; StringGrid1.RowHeights[1] := 20;
StringGrid1.RowHeights[2] := 50; StringGrid1.RowHeights[3] := 35;
end;
// Uważaj, aby nie podać nieistniejący rząd
uses printers;
procedure printgrid(sgrid: tstringgrid; stitle: string);
var x1, x2: integer; y1, y2: integer; tmpi: integer; f: integer; tr: trect;
begin
printer.title := stitle; printer.begindoc;
//Te ustawienia mogą być zmieniane
printer.canvas.pen.color := 0; printer.canvas.font.name := 'times new roman';
printer.canvas.font.size := 12; printer.canvas.font.style := [fsbold, fsunderline];
printer.canvas.textout(0, 100, printer.title);
for f := 1 to sgrid.colcount - 1 do
begin
x1 := 0; for tmpi := 1 to (f - 1) do
x1 := x1 + 5 * (sgrid.colwidths[tmpi]); y1 := 300; x2 := 0;
for tmpi := 1 to f do
x2 := x2 + 5 * (sgrid.colwidths[tmpi]); y2 := 450; tr := rect(x1, y1, x2 - 30, y2);
printer.canvas.font.style := [fsbold]; printer.canvas.font.size := 7;
printer.canvas.textrect(tr, x1 + 50, 350, sgrid.cells[f, 0]);
printer.canvas.font.style := [];
for tmpi := 1 to sgrid.rowcount - 1 do
begin
y1 := 150 * tmpi + 300; y2 := 150 * (tmpi + 1) + 300;
tr := rect(x1, y1, x2 - 30, y2);
printer.canvas.textrect(tr, x1 + 50, y1 + 50, sgrid.cells[f, tmpi]);
end; end; printer.enddoc;
end;
unit maingrid;
interface
uses windows, messages, sysutils, variants, classes, graphics, controls, forms,
dialogs, grids, extctrls, stdctrls;
type
pgridtexte = ^tgridtexte;
tgridtexte = record
msg: string;
zeit: ttime;
zeitstr: string;
end;
tstringgrid = class(grids.tstringgrid)
private
procedure wmsetcursor(var msg: twmsetcursor); message wm_setcursor;
procedure gridtextedestroy;
procedure fmemosetze;
procedure fmemoonenter(sender: tobject);
procedure fmemoonexit(sender: tobject);
procedure frownull;
function newgridtexte(t: ttime): pgridtexte;
public
fmemo: tmemo;
ftextlist: tlist;
frow, fcol: integer;
constructor create(aowner: tcomponent); override;
destructor destroy; override;
procedure gridtextecreate(max: integer);
end;
tmain = class(tform)
panelzeitbox: tpanel;
stringgrid: tstringgrid;
memo1: tmemo;
procedure formcreate(sender: tobject);
procedure stringgriddrawcell(sender: tobject; acol, arow: integer;
rect: trect; state: tgriddrawstate);
procedure formshow(sender: tobject);
private
public { public-deklarationen }
end;
var main: tmain;
implementation
uses dateutils;
{$r *.dfm}
{$i maingrid.inc}
procedure tmain.formcreate(sender: tobject);
begin
panelzeitbox.align := alright; panelzeitbox.width := 300;
with stringgrid do
begin
parent := panelzeitbox; defaultrowheight := panelzeitbox.height div 12;
height := panelzeitbox.height; defaultcolwidth := 60; rowcount := 24 * 4;
colwidths[1] := panelzeitbox.width - defaultcolwidth - 18;
gridtextecreate(rowcount); fmemosetze;
end; end;
procedure tmain.formshow(sender: tobject);
begin
stringgrid.fmemo.setfocus;
end;
procedure tmain.stringgriddrawcell(sender: tobject; acol, arow: integer;
rect: trect; state: tgriddrawstate);
var s: string; i: integer; hour, min, sec, msec: word;
begin
with stringgrid, canvas do
begin
frownull; if acol > 0 then
begin
s := pgridtexte(ftextlist[arow])^.msg;
drawtext(canvas.handle, pchar(s), length(s), rect, dt_wordbreak);
end else begin
s := pgridtexte(ftextlist[arow])^.zeitstr;
decodetime(pgridtexte(ftextlist[arow])^.zeit, hour, min, sec, msec);
if min = 0 then font.style := [fsbold]
else
font.style := []; rect.right := rect.right - 5; rect.top := rect.top + textheight(s);
drawtext(canvas.handle, pchar(s), length(s), rect, dt_right);
end; end;
end;
{tstringgrid-public***}
procedure tstringgrid.wmsetcursor(var msg: twmsetcursor);
begin
inherited;
fmemo.visible := true; if fmemo.focused then exit;
fcol := col; frow := row; fmemosetze; fmemo.setfocus;
end;
constructor tstringgrid.create(aowner: tcomponent);
begin
inherited create(aowner);
ftextlist := tlist.create; fmemo := tmemo.create(self);
with fmemo do
begin
parent := self; borderstyle := bsnone;
maxlength := 100; //sollten nur max 2 zeilen werden
color := tcolor($00c8d6dd); onenter := fmemoonenter; onexit := fmemoonexit
end;
fixedcols := 1; fixedrows := 0; fixedcolor := $00bbccd5; color := $00bbccd5;
scrollbars := ssvertical; borderstyle := bsnone; options := [gohorzline];
fcol := 1; frow := 0; colcount := 2;
end;
destructor tstringgrid.destroy;
begin
fmemo.free; gridtextedestroy; inherited destroy;
end;
procedure tstringgrid.gridtextecreate(max: integer);
var i: integer; t: ttime;
begin
t := 0; for i := 0 to max do
begin
ftextlist.add(newgridtexte(t)); t := incminute(t, 15); //dateutils
end; end;
//private********
procedure tstringgrid.gridtextedestroy;
var i: integer;
begin
for i := 0 to ftextlist.count - 1 do dispose(pgridtexte(ftextlist[i]));
ftextlist.free;
end;
procedure tstringgrid.fmemosetze;
var r: trect;
begin
frownull;
if (fcol = 1) and (frow < rowcount) then
begin
r := cellrect(fcol, frow); r.left := r.left + left; r.right := r.right + left;
r.top := r.top + top; r.bottom := r.bottom + top;
with fmemo do
begin
left := r.left - 1; top := r.top - 1;
width := r.right - r.left; height := r.bottom - r.top;
visible := true; text := pgridtexte(ftextlist[frow])^.msg;
end; end; end;
procedure tstringgrid.fmemoonenter(sender: tobject);
const noselection: tgridrect = (left: - 1; top: - 1; right: - 1; bottom: - 1);
begin
repaint; frownull;
fmemo.text := pgridtexte(ftextlist[frow])^.msg;
selection := noselection;
end;
procedure tstringgrid.fmemoonexit(sender: tobject);
begin
frownull; pgridtexte(ftextlist[frow])^.msg := fmemo.text;
end;
procedure tstringgrid.frownull;
begin
if (frow < 0) or (frow > ftextlist.count - 1) then frow := 0;
end;
function tstringgrid.newgridtexte(t: ttime): pgridtexte;
begin
result := new(pgridtexte);
with result^ do
begin
msg := ''; zeit := t; zeitstr := timetostr(t);
end; end;
procedure tformhistory.listhistorydrawcell(sender: tobject; col, row: integer; rect: trect;
state: tgriddrawstate);
var s : string; drawrect : trect; currentcolor : tcolor;
begin
if (sender as tstringgrid).cells[column_incoming , row ] = '1'
then currentcolor:=clblue else currentcolor:=clmaroon;
if (sender as tstringgrid).row = row
then currentcolor := clhighlighttext ;
(sender as tstringgrid).canvas.font.color := currentcolor;
s:= (sender as tstringgrid).cells[ col, row ];
if (col = column_message ) and (row < > row_header)
then begin
if length(s) > 0 then
begin
drawrect:=rect;
drawtext((sender as tstringgrid).canvas.handle, pchar(s), length(s),
drawrect, dt_calcrect or dt_wordbreak or dt_left );
if (drawrect.bottom - drawrect.top) > (sender as tstringgrid).rowheights[row] then
(sender as tstringgrid).rowheights[row] :=(drawrect.bottom - drawrect.top)
else begin
drawrect.right:=rect.right; (sender as tstringgrid).canvas.fillrect( drawrect );
drawtext((sender as tstringgrid).canvas.handle, pchar(s), length(s), drawrect,
dt_wordbreak or dt_left);
end; end; end else
if row < > row_header
then (sender as tstringgrid).canvas.textout(rect.left+3, rect.top+3 , s );
end;
Jest to plik tekstowy z tej treści:
data 210 372 czas 13,00
data 220 345 czas 14,50
A tak należy wykorzystać stringgird aby pobrać ten plik.
var ... f:text; ...
procedure tform1.button1click(sender: tobject);
var s:string; s1:string[6]; i:integer;
begin
stringgrid.cells[1,0]:='data'; stringgrid.cells[2,0]:='czas';
i:=0; assignfile(f,'inform.txt'); reset(f);
repeat
inc(i); readln(f,s); delete(s,1,5); s1:=s;
stringgrid.cells[1,i]:=s1; delete(s,1,13);
stringgrid.cells[2,i]:=s; stringgrid.cells[0,i]:=inttostr(i);
until eof(f); closefile(f);
end;
const dt = 'data'; tm = 'czas';
var f: textfile; s, s1: string; i, j: integer;
begin
if fileexists('test.txt') then
begin
assignfile(f, 'test.txt'); reset(f); j:=1;
while not eof(f) do
begin
readln(f, s); s:=s+' '; i:=pos(dt, s);
if i = 0 then begin closefile(f); exit end; // nieprawidłowy ciąg
delete(s, 1, i+length(dt));
while s[1] = ' ' do
delete(s,1,1); i:=pos(tm, s); stringgrid1.cells[1, j]:=copy(s, 1, i-1);
i:=pos(tm, s); delete(s, 1, i+length(tm));
while s[1]=' ' do
delete(s, 1, 1); stringgrid1.cells[2, j]:=s; inc(j)
end; closefile(f)
end;
w zdarzeniu ondrawcell stringgrida, który tu ma nazwę mygrid.
Oto przykład zmiany czcionki w drugiej kolumnie w Courier New.
procedure tform1.mygriddrawcell(sender: tobject; acol, arow: integer;
rect: trect; state: tgriddrawstate);
var oldname: string;
begin
oldname:=mygrid.canvas.font.name;
if (acol=2) then
mygrid.canvas.font.name:='courier new';
mygrid.canvas.textrect(rect, rect.left+2, rect.top+2, mygrid.cells[acol, arow]);
mygrid.canvas.font.name:=oldname;
end;
procedure tform1.stringgrid1drawcell(sender: tobject; acol, arow: integer;
rect: trect; state: tgriddrawstate);
var i, x, y: integer;
begin
if gdfixed in state then exit;
if arow > 1 then exit; {rysuj 1 wiersz z celą 1,1 obejmujący cały tekst}
with sender as tstringgrid do
begin {rozszerz siatkę w prawo o ile nie jest cela ostatnią w wierszu}
if acol < pred(colcount) then
rect.right := rect.right + gridlinewidth;
{gdzie tekst pierwszej celi w stosunku do cel aktualnego prostokąta}
y := rect.top + 2; x := rect.left + 2;
for i:= 1 to acol - 1 do
x := x - colwidths[i] - gridlinewidth; {cela koloru żółtego}
canvas.brush.color := $7fffff; canvas.brush.style := bssolid;
canvas.fillrect( rect ); {wypełnienie tekstem celi 1,1}
canvas.textrect( rect, x, y, cells[1, 1] );
end; end;
procedure tform1.formcreate(sender: tobject);
var i, k: integer;
begin
with stringgrid1 do
begin
cells[1, 1] := 'przykładowy, dość długi wiersz, który sięga poza celę';
for i:= 1 to colcount-1 do
for k:= 2 to rowcount -1 do
cells[i,k] := format( 'cell[%d, %d]', [i, k]);
end; end;
Trzeba utworzyć zdarzenie ondrawcell. Oto kod:
procedure tform.sgrdrawcells(sender: tobject; col, row: longint; rect: trect; state: tgriddrawstate);
var acol: longint absolute col; arow: longint absolute row; buf: array[byte] of char;
begin
if state = gdfixed then exit;
with sgrgrid do
begin
canvas.font := font; canvas.font.color := clwindowtext; canvas.brush.color := clwindow;
canvas.fillrect(rect); strpcopy(buf, cells[acol, arow]);
drawtext(canvas.handle, buf, -1, rect, dt_singleline or dt_vcenter or dt_noclip or dt_left);
end; end;
table.first;
row := 0;
grid.rowcount := table.recordcount;
while not table.eof do
begin
for i := 0 to table.fieldcount-1 do
grid.cells[i,row] := table.fields[i].asstring;
inc (row); table.next;
end;
Poniżej kod, ładuje dane z tabeli. Działa bardzo szybko, nawet jeśli z pliku pobrano setki kolumn.
procedure tformlookupdb.fillcells;
var row, i: integer; w: integer; grid: tstringgrid;
begin
dogrid.rowcount := 0; if not assigned(fdb) then exit;
row := 0;
for i := low(fcolwidths) to high(fcolwidths) do
fcolwidths[i] := 100
/ / poniżej tymczasowy grid służy do ochrony przed dużym naborem danych w ramach procesu
application.processmessages,
/ / dane wprowadzane do grida w inny sposób powodują migotanie tego obiektu
/ / Potem dopiero następuje ładowanie, poczynając od góry, do obiektu Dogrid.
grid := tstringgrid.create(self); grid.visible := false;
with fdb do
try
grid.colcount := ffields.count; disablecontrols;
//Filtr został ustawiony za pomocą właściwości self.filter
first;
while not eof do
try
grid.rowcount := row + 1; for i := 0 to grid.colcount - 1 do
begin
grid.cells[i, row] :=fieldbyname(ffields.strings[i]).asstring
w := dogrid.canvas.textwidth(grid.cells[i, row]);
if fcolwidths[i] < w then fcolwidths[i] := w;
end inc(row);
finally next; end
finally dogrid.rowcount := grid.rowcount; dogrid.colcount := grid.colcount;
for i := 0 to grid.colcount - 1 do
begin
dogrid.cols[i] := grid.cols[i]; dogrid.colwidths[i] := fcolwidths[i] + 4
end
grid.free; enablecontrols end
end;
Kod poniżej przeprowadza kursor do następnej kolumny. Przy kolumnie ostatniej kursor przechodzi do
następnego wiersza. Kiedy dojdziesz do końca grida to zostaniesz przeniesiony do jego początku.
Oczywiście, można zmienić to zachowanie, i ustanowić inny tryb.
procedure tform1.stringgrid1keypress(sender: tobject; var key: char);
begin
if key = #13 then
with stringgrid1 do
if col < colcount - 1 then {aktualna kolumna!}
col := col + 1 else if row < rowcount - 1 then
begin {następna kolumna!}
row := row + 1; col := 1; end
else begin {koniec siatki więc na początek!}
row := 1; col := 1;
{lub.... tu można przekazać sterowanie do innego elementu}
end; end;
Taki zapis jest najlepszy, szczególnie przy dużych TStringgridach.
var: mystream: tfilestream;
begin
mystream1 := tfilestream.create('grid1.sav', fmcreate);
mystream1.writecomponent(stringgrid1);
mystream1.destroy;
end;
A dla odczytu:
mystream := tfilestream.create('grid1.sav', fmopenread);
stringgrid1 := mystream1.readcomponent(stringgrid1) as tstringgrid;
procedure tform1.drawcell(sender: tobject; col: longint; row: longint; rect: trect; state: tgriddrawstate);
var lrow, lcol: longint; s: string;
begin
lrow := row; lcol := col;
with sender as tstringgrid, canvas do
begin
if (gdselected in state) then
begin
brush.color := clhighlight; { *** }
end else
if (lrow < fixedrows) or (lcol > fixedcols) then
begin
brush.color := fixedcolor;
end else begin
brush.color := color;
end;
fillrect(rect); setbkmode(handle, transparent);
textout(rect.left + 2, rect.top + 2, cells[lcol, lrow]);
end; end;
Łańcuch z komentarzem {***} w tym kontekście jest sprawą kluczową. On "mówi", że jeśli my edytujemy
celę, która ma focus to następuje zmiana podświetlenia. Wtedy może być problem z widocznością liter;
trzeba dobrać zawczasu odpowiedni ich kolor albo własciwość tstringgrid defaultdrawing ustawić na
True.
Ten problem należy rozwiązać programowo. Robić to należy po pobraniu danych lub jeżeli pobiera
dane w kolumnach, załadować je w pętli poniżej:
var i, j, temp, max: integer;
begin
for i := 0 to grid.colcount - 1 do begin
max := 0;
for j := 0 to grid.rowcount - 1 do begin
temp := grid.canvas.textwidth(grid.cells[i, j]);
if temp > max then max := temp;
end;
grid.colwidths[i] := max + grid.gridlinewidth + 1;
end; end;
Aby cały tekst w kolumnie był widoczny i nie dotykał do ramki (z zapasem).
procedure tform1.stringgrid1selectcell(sender: tobject; vcol, vrow: longint; var canselect: boolean);
var wid: integer;
begin
with sender as tstringgrid do
begin
wid := canvas.textwidth(cells[col, row] + ' ');
if wid > colwidths[col] then colwidths[col] := wid;
end; end;
procedure tform1.stringgrid1keypress(sender: tobject; var key: char);
var wid: integer;
begin
if key = #13 then
with sender as tstringgrid do
begin
wid := canvas.textwidth(cells[col, row] + ' ');
if wid > colwidths[col] then colwidths[col] := wid;
end; end;
Należy pamiętać, aby w zdarzeniu onselectcell parametry col i row przemianować np na vcol i vrow,
aby uniknąć nieporozumień z właściwości stringgrid, o tej samej nazwie.
Stringgrid domyślnie ustawia wszystkie kolumny tej samej szerokości - w niektórych tekst komórki
zostanie obcięty. Aby tego uniknąć, po wypełnieniu stringgrida potrzeba dla każdej kolumny tekstu
znaleźć odpowiednią szerokość kolumny.
var x, y, w: integer; s: string; maxwidth: integer;
begin
with stringgrid1 do clientheight := defaultrowheight * rowcount + 5;
with stringgrid1 do begin
for x := 0 to colcount - 1 do begin maxwidth := 0;
for y := 0 to rowcount - 1 do begin w := canvas.textwidth(cells[x,y]);
if w > maxwidth then maxwidth := w;
end; colwidths[x] := maxwidth + 5;
end; end; end;
Przy usuwaniu wierszy i kolumn sprawdzać i usuwać tylko obiekty uprzednio zaznaczone.
unit gridfunc;
interface
uses sysutils, winprocs, grids;
procedure insertrow(sender: tstringgrid; toindex: longint);
procedure deleterow(sender: tstringgrid; fromindex: longint);
procedure insertcolumn(sender: tstringgrid; toindex: longint);
procedure deletecolumn(sender: tstringgrid; fromindex: longint);
implementation
type
tcsgrid = class(tstringgrid)
private
public
procedure moverow(fromindex, toindex: longint);
procedure movecolumn(fromindex, toindex: longint);
end;
procedure tcsgrid.moverow(fromindex, toindex: longint);
begin
rowmoved(fromindex, toindex); { usuwa od wiersza do wiersza }
end;
procedure tcsgrid.movecolumn(fromindex, toindex: longint);
begin
columnmoved(fromindex, toindex); { przenosi kolumny od do.. }
end;
procedure insertrow(sender: tstringgrid; toindex: longint);
var xx, yy: integer;
begin
if toindex >= 0 then with tcsgrid(sender) do
if (toindex < = rowcount) then begin
rowcount := rowcount + 1; xx := rowcount - 1;
for yy := 0 to colcount - 1 do
begin
cells[yy, xx] := ' '; objects[yy, xx] := nil;
end;
if toindex < rowcount - 1 then moverow(rowcount - 1, toindex);
end else
messagebeep(0)
else
messagebeep(0);
end;
procedure deleterow(sender: tstringgrid; fromindex: longint);
begin
if fromindex > = 0 then with tcsgrid(sender) do
if (rowcount > 0) and (fromindex < rowcount) then
begin
if (fromindex < rowcount - 1) then moverow(fromindex, rowcount - 1);
rows[rowcount - 1].clear; rowcount := rowcount - 1;
end else
messagebeep(0)
else
messagebeep(0);
end;
procedure insertcolumn(sender: tstringgrid; toindex: longint);
var xx, yy: integer;
begin
if toindex >= 0 then with tcsgrid(sender) do
if (toindex <= colcount) then
begin
colcount := colcount + 1; xx := colcount - 1; cols[xx].beginupdate;
for yy := 0 to rowcount - 1 do
begin
cells[xx, yy] := ' '; objects[xx, yy] := nil; end; cols[xx].endupdate;
if toindex < colcount - 1 then movecolumn(colcount - 1, toindex);
end else
messagebeep(0)
else
messagebeep(0);
end;
procedure deletecolumn(sender: tstringgrid; fromindex: longint);
begin
if fromindex >= 0 then
with tcsgrid(sender) do
if (colcount > 0) and (fromindex < colcount) then
begin
if (fromindex < colcount - 1) then movecolumn(fromindex, colcount - 1);
cols[colcount - 1].clear; colcount := colcount - 1;
end else
messagebeep(0)
else
messagebeep(0);
end;
end.
Z wykorzystaniem zdarzenia ondrawcell stringgrida:
procedure tform1.stringgrid1drawcell(sender: tobject; col, row: longint;
rect: trect; state: tgriddrawstate);
var txt: array[0..255] of char;
begin
strpcopy(txt, stringgrid1.cells[col, row]); settextalign(stringgrid1.canvas.handle,
gettextalign(stringgrid1.canvas.handle) and not (ta_left or ta_center) or ta_right);
exttextout(stringgrid1.canvas.handle, rect.right - 2, rect.top + 2,
eto_clipped or eto_opaque, @rect, txt, strlen(txt), nil);
end;
Wersja 2 - Wyrównanie kolumn stringgrida do prawej strony
procedure tform1.stringgrid1drawcell(sender: tobject; col, row: longint; rect: trect; state: tgriddrawstate);
var lrow, lcol: longint;
begin
lrow := row; lcol := col;
with sender as tstringgrid, canvas do
begin
if (gdselected in state) then begin brush.color := clhighlight;
end else
if (gdfixed in state) then begin
brush.color := fixedcolor;
end else begin
brush.color := color;
end;
fillrect(rect); setbkmode(handle, transparent);
settextalign(handle, ta_right);
textout(rect.right - 2, rect.top + 2, cells[lcol, lrow]);
end; end;
Wersja 3- wyrównanie kolumn stringgrida
procedure writetext(acanvas: tcanvas; const arect: trect; dx, dy: integer;
const text: string; format: word);
var s: array[0..255] of char; b, r: trect;
begin
with acanvas, arect do begin
case format of
dt_left: exttextout(handle, left + dx, top + dy, eto_opaque or
eto_clipped, @arect, strpcopy(s, text), length(text), nil);
dt_right: exttextout(handle, right - textwidth(text) - 3, top + dy, eto_opaque or
eto_clipped, @arect, strpcopy(s, text), length(text), nil);
dt_center: exttextout(handle, left + (right - left - textwidth(text)) div 2, top + dy, eto_opaque or
eto_clipped, @arect, strpcopy(s, text), length(text), nil);
end; end;
end;
procedure tbefstringgrid.drawcell(col, row: longint; rect: trect; state: tgriddrawstate);
var
procedure display(const s: string; alignment: talignment);
const formats: array[talignment] of word = (dt_left, dt_right, dt_center);
begin
writetext(canvas, rect, 2, 2, s, formats[alignment]);
end;
begin
{ tutaj wybór wierszy i kolumn oraz formatowanie }
case row of
0: { tu centrowanie nagłówków kolumn }
if (col < colcount) then display(cells[col, row], tacenter)
else { reszta ...do prawego }
display(cells[col, row], taright);
end; end;
Wersja 4 - wyrównywanie kolumn stringgrida
Poniżej stworzona własna metoda drawcell:
procedure tsearchfrm.grid1drawcell(sender: tobject; col, row: longint; rect: trect; state: tgriddrawstate);
var l_oldalign: word;
begin
if (row = 0) or (col < 2) then {nagłówek będzie pogrubiony}
grid1.canvas.font.style := grid1.canvas.font.style + [fsbold];
if col < > 1 then
begin
l_oldalign := settextalign(grid1.canvas.handle, ta_right);
{tekst rysuj po prawej stronie}
grid1.canvas.textrect(rect, rect.right - 2, rect.top + 2, grid1.cells[col, row]);
settextalign(grid1.canvas.handle, l_oldalign);
end else begin
grid1.canvas.textrect(rect, rect.left + 2, rect.top + 2, grid1.cells[col, row]);
end;
grid1.canvas.font.style := grid1.canvas.font.style - [fsbold];
end;
procedure tform1.button3click(sender: tobject);
var i,j: integer;
begin
j:=sg1.row; // według wybranego wiersza
sg1.rows[j].clear;
for i:=j to sg1.rowcount-2 do
sg1.rows[i].assign(sg1.rows[i+1]); sg1.rowcount:=sg1.rowcount-1;
end;
Podczas używania nie zapomnij o rowheights (lub defaultrowheight), bowiem tekst zajmie nawet wiele
wierszy. Do używania zapisać go pod nazwą "wrapgrid.pas" i zainstaluj go w Delphi by potem używać
go zamiast standardowego TStringgrid. Autor luis j. de la Rosa.
unit wrapgrid;
interface
uses sysutils, wintypes, winprocs, messages, classes, graphics, controls, forms, dialogs, grids;
type
twrapgrid = class(tstringgrid)
private { private declarations }
protected { protected declarations }
{ Procedura drawcell wykonuje zawijanie tekstu w celi }
procedure drawcell(acol, arow: longint; arect: trect; astate: tgriddrawstate); override;
public { public declarations }
constructor create(aowner: tcomponent); override;
published { published declarations }
end;
procedure register;
implementation
constructor twrapgrid.create(aowner: tcomponent);
begin
{ tworzymy tstringgrid }
inherited create(aowner);
defaultdrawing := false;
end;
{ procedura drawcell wykonuje zawijanie tekstu w celi }
procedure twrapgrid.drawcell(acol, arow: longint; arect: trect; astate: tgriddrawstate);
var
sentence, { wyprowadzany tekst }
curword: string; { bieżące słowo }
spacepos, { pozycja pierwszego miejsca }
curx, { współrzędna X kursora }
cury: integer; { współrzędna Y kursora }
endofsentence: boolean; { początek wypełniania cel }
begin
{ inicjacja czcionki }
canvas.font := font;
with canvas do begin
{ jeżeli to cela fixed to taki kolot tła i pena }
if gdfixed in astate then begin
pen.color := fixedcolor;
brush.color := fixedcolor;
end else begin { w przeciwnym razie takie kolory }
pen.color := color; brush.color := color;
end;
rectangle(arect.left, arect.top, arect.right, arect.bottom); { kolor tła celi }
end;
curx := arect.left; cury := arect.top; { rozpoczynamy rysowanie od lewej, górnej }
sentence := cells[acol, arow]; { tu jest zawartość celi }
endofsentence := false; { dla każdego słowa celi }
while (not endofsentence) do
begin
spacepos := pos(' ', sentence); { szukaj takie słowo}
if spacepos > 0 then
begin
curword := copy(sentence, 0, spacepos); { otrzymujemy aktualne słowo plus spacja }
{ niżej otrzymujemy pozostałą część zdania }
sentence := copy(sentence, spacepos + 1, length(sentence) - spacepos);
end else begin
{ to ostatnie słowo w zdaniu }
endofsentence := true; curword := sentence;
end;
with canvas do
begin
{ jeżeli tekst wychodzi poza granicę celi }
if (textwidth(curword) + curx) > arect.right then
begin
{ przenosimy go na następną linię }
cury := cury + textheight(curword); curx := arect.left;
end;
{ wyprowadzamy słowo }
textout(curx, cury, curword);
{ zwiększamy x-koordynaty kursora }
curx := curx + textwidth(curword);
end; end; end;
procedure register;
begin
{ można go instalować gdzie indziej w delphi }
registercomponents('samples', [twrapgrid]);
end;
end.
procedure tform1.stringgrid1keypress(sender: tobject; var key: char);
var s: string; c: byte;
begin
with stringgrid1 do
s := cells[col, row]; if length(s) = 0 then
begin
if key in ['a'..'z'] then begin
c := ord(key) - 32; key := chr(c); end; exit;
end;
if s[length(s)] = ' ' then
if key in ['a'..'z'] then begin
c := ord(key) - 32; key := chr(c);
end; end;
// W zakresie obsługi zdarzenia onkeypress wpisz:
if length(field.text) = 0 then key := upcase (key);
Najpierw trzeba użyc do obsługi zdarzenia ondrawcell TStringgrida:
procedure tform1.stringgrid1drawcell(sender: tobject; acol, arow: integer;
rect: trect; state: tgriddrawstate);
var i, x, y: integer;
begin
if gdfixed in state then exit;
if arow > 1 then exit;
{draw row 1 with text from cell 1,1 spanning all cells in the row}
with sender as tstringgrid do
begin
if acol < pred(colcount) then
rect.right := rect.right + gridlinewidth;
{figure out where the text of the first cell would start relative to the current cells rect}
y := rect.top + 2; x := rect.left + 2;
for i:= 1 to acol - 1 do
x := x - colwidths[i] - gridlinewidth; {paint cell pale yellow}
canvas.brush.color := $7fffff; canvas.brush.style := bssolid;
canvas.fillrect( rect ); {paint text of cell 1,1 clipped to current cell}
canvas.textrect( rect, x, y, cells[1, 1] );
end; end;
// tworzymy okno z długim tekstem
procedure tform1.formcreate(sender: tobject);
var i, k: integer;
begin
with stringgrid1 do
begin
cells[1, 1] := 'dość długi wiersz, który będzie łączyć cele';
for i:= 1 to colcount-1 do for k:= 2 to rowcount -1 do
cells[i,k] := format( 'cell[%d, %d]', [i, k]);
end; end;
procedure setgridfocus(sgrid: tstringgrid; r, c: integer);
var srect: tgridrect;
begin
with sgrid do begin
setfocus; {nadajemy focus siatce}
row := r; {ustawiamy row/col}
col := c;
srect.top := r; {określamy wybrany obszar}
srect.left := c; srect.bottom := r; srect.right := c;
selection := srect; {ustanawiamy wybór}
end; end;
Dla wywołania procedury wpisz: setgridfocus(stringgrid1, 10, 2);
Po kliknięciu na dowolną celę stringgrida, poprzednio zaznaczona cela przyjmuje kolor niebieski ...
procedure tform1.stringgrid3drawcell(sender: tobject; vcol, vrow: longint;
rect: trect; state: tgriddrawstate);
begin
if sender = activecontrol then exit;
if not (gdselected in state) then exit;
with sender as tstringgrid do begin
canvas.brush.color := color; canvas.font.color := font.color;
canvas.textrect(rect, rect.left + 2, rect.top + 2, cells[vcol, vrow]);
end; end;
Należy pamiętać, by w obsłudze zdarzeń w ondrawcell przemianować parametr col i row na vcol i vrow,
aby uniknąć konfliktu z właściwościami stringgrida.