code sample
procedure TForm1.Button1Click(Sender: TObject);
var
r: Trect;
s: String;
begin
R := Rect(0,0, 300, 100);
s := 'WordWrapTextOut(TargetCanvas: TCanvas; var x, y: integer; S: string; maxwidth, lineheight: integer);';
DrawText(Canvas.Handle, PChar(s), length(s), R, DT_WORDBREAK or DT_LEFT);
end;
I want to wrap the text in 300px width but how can I get the new Height? Is there a way or any solution?
The height of the drawn text is the returned value of DrawText.
HeightOfText := DrawText(...
If you want to update your rectangle before drawing the text you could use DT_CALCRECT. DrawText will then modify your rectangle to the new height (and width if necessary). If you only need the height though use the return value as Andreas Rejbrand showed.
Here's a sample of this:
procedure TForm1.Button1Click(Sender: TObject);
var
r: Trect;
s: String;
begin
R := Rect(0,0, 300, 100);
s := 'WordWrapTextOut(TargetCanvas: TCanvas; var x, y: integer; S: string; maxwidth, lineheight: integer);';
if DrawText(Canvas.Handle, PChar(s), length(s), R, DT_CALCRECT or DT_WORDBREAK or DT_LEFT) <> 0 then
begin
DrawText(Canvas.Handle, PChar(s), length(s), R, DT_WORDBREAK or DT_LEFT);
r.Top := r.Bottom;
r.Bottom := r.Bottom * 2;
DrawText(Canvas.Handle, PChar(s), length(s), R, DT_WORDBREAK or DT_LEFT);
end;
end;
I would recommend reading the docs for more details:
http://msdn.microsoft.com/en-us/library/dd162498(v=vs.85).aspx
As was mentioned here you can get it by calling DrawText function with DT_CALCRECT flag specified what actually won't paint anything; it just calculates appropriate rectangle and returns it to variable R.
procedure TForm1.Button1Click(Sender: TObject);
var
R: TRect;
S: String;
begin
R := Rect(0, 0, 20, 20);
S := 'What might be the new high of this text ?';
DrawText(Canvas.Handle, PChar(S), Length(S), R, DT_WORDBREAK or DT_LEFT or DT_CALCRECT);
ShowMessage('New height might be '+IntToStr(R.Bottom - R.Top)+' px');
end;
What means if you call it twice using the following example, you'll get drawn the wrapped text. It's because the first call with DT_CALCRECT calculates the rectangle (and modify R variable by doing it) and the second call draws the text in that modified rectangle area.
procedure TForm1.Button1Click(Sender: TObject);
var
R: TRect;
S: String;
begin
R := Rect(0, 0, 20, 20);
S := 'Some text which will be stoutly wrapped and painted :)';
DrawText(Canvas.Handle, PChar(S), Length(S), R, DT_WORDBREAK or DT_LEFT or DT_CALCRECT);
DrawText(Canvas.Handle, PChar(S), Length(S), R, DT_WORDBREAK or DT_LEFT);
end;
Related
Problem Definition
I am trying to create a custom bitmap brush with transparency but it doesn't seem to be working as expected. If you look at this example. Add the code and hook up the paint, create and destroy events.
type
TForm3 = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FBitmap: TBitmap;
end;
// Implementation
function CreateBlockBitmap(const APenColor: TColor): TBitmap;
begin
Result := TBitmap.Create;
Result.Transparent := True;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsClear;
Result.PixelFormat := pf32bit;
Result.SetSize(20, 20);
Result.Canvas.Brush.Color := APenColor;
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
FBitmap := CreateBlockBitmap(clRed);
end;
procedure TForm3.FormPaint(Sender: TObject);
var
colNum: Integer;
rowNum: Integer;
begin
// Paint the rectangle using the brush
Canvas.Pen.Color := clGreen;
Canvas.Brush.Bitmap := FBitmap; // This is using bitmap
Canvas.Rectangle(50, 50, 250, 250);
// Draw the block using Canvas.Draw
for rowNum := 0 to 9 do
for colNum := 0 to 9 do
Canvas.Draw(350 + rowNum * 20, 50 + colNum * 20, FBitmap);
end;
This code produces two painted blocks. The left one is painted using a bitmap brush and the right hand side one is painted using a number of Canvas.Draw calls.
I need the brush to be painted with transparency similar to what would happen if you used a hatch brush. This SO answer seems to indicate that it's possible:
How can I draw a patternBrush with transparent backround (GDI)?
What I have tried
1) I tried using a solid background color instead of using bsClear. This just makes the background white.
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
If I use clFuchsia then the color is Fuchsia. I also tried painting the background clFuchsia and then setting the TransparentColor to clFuchsia. The Canvas.Draw option paints with transparency and the brush doesn't.
2) I tried setting the alpha channel directly with the following code:
procedure SetAlphaBitmap(const Dest: TBitmap;Color : TColor;Alpha:Byte);
type
TRGB32 = record
B, G, R, A: byte;
end;
PRGBArray32 = ^TRGBArray32;
TRGBArray32 = array[0..0] of TRGB32;
var
x, y: integer;
Line, Delta: integer;
ColorRGB : TColor;
begin
if Dest.PixelFormat<>pf32bit then exit;
ColorRGB := ColorToRGB(Color);
Line := integer(Dest.ScanLine[0]);
Delta := integer(Dest.ScanLine[1]) - Line;
for y := 0 to Dest.Height - 1 do
begin
for x := 0 to Dest.Width - 1 do
if TColor(RGB(PRGBArray32(Line)[x].R, PRGBArray32(Line)[x].G, PRGBArray32(Line)[x].B)) = ColorRGB then
PRGBArray32(Line)[x].A := Alpha;
Inc(Line, Delta);
end;
end;
And then calling this routine immediately after the rectangle has been painted using the background color.
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
SetAlphaBitmap(Result, clBlack, 0); // Set the alpha channel
end;
I know that the alpha channel is working because if I pass in an alpha value of 255 then it shows up in black in the Canvas.Draw too.
SetAlphaBitmap(Result, clBlack, 255);
3) I tried testing by creating a pattern brush and assigning that instead of the bitmap. That produces exactly the same results. FBrush is an HBRUSH.
FBrush := CreatePatternBrush(FBitmap.Handle);
And the setting the brush like this:
Canvas.Brush.Handle := FBrush;
4) I tried calling SetBkMode as indicated in the SO answer above. That made no difference at all.
Canvas.Pen.Color := clGreen;
Canvas.Brush.Bitmap := FBitmap;
SetBkMode(Canvas.Handle, TRANSPARENT); // This doesn't make a difference
Canvas.Rectangle(50, 50, 250, 250);
Edit
5) I just tested with a Monochrome bitmap and it has the same problem. The image is painted with a white background and black foreground for the brush and transparent for the Canvas.Draw.
function CreateMonochromeBitmap: TBitmap;
begin
Result := TBitmap.Create;
Result.Transparent := True;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
Result.PixelFormat := pf1bit;
Result.SetSize(20, 20);
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.FillRect(Rect(0,0,10,10));
end;
And in the constructor:
FBitmap := CreateMonochromeBitmap;
FBrush := CreatePatternBrush(FBitmap.Handle);
In the paint we set the handle rather than the bitmap property.
Canvas.Brush.Handle := FBrush;
Try to clear the canvas this null color before your drawing loop.
Canvas.Clear(TAlphaColorRec.Null);
Greetings.
Pau.
You need to use white color for transparent areas and SetROP2 before filling the rectangle, like this:
Canvas.Brush.Bitmap := FBitmap; // This is using bitmap
SetROP2(Canvas.Handle, R2_MASKPEN);
Canvas.Rectangle(50, 50, 250, 250);
And don't forget to restore the previous ROP mode.
Good luck!
Solved! Here is my solution:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
public
FBitmap: TBitmap;
end;
//Implementation
function CreateBlockBitmap: TBitmap;
begin
Result := TBitmap.Create;
Result.PixelFormat := pf1bit; //!! 1-bit
Result.Width := 20;
Result.Height := 20;
Result.Canvas.Brush.Color := clBlack;
Result.Canvas.FillRect(Rect(0, 0, 10, 10));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FBitmap := CreateBlockBitmap;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
const
PatternColor = clRed; //brush color to be used
var
R: TRect;
begin
//filling the background with different colors for test
Canvas.Brush.Color := clGreen;
Canvas.FillRect(Rect(0,0,100,600));
Canvas.Brush.Color := clAqua;
Canvas.FillRect(Rect(100,0,200,600));
Canvas.Brush.Color := clYellow;
Canvas.FillRect(Rect(200,0,300,600));
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Rect(300,0,400,600));
//draw the rectangle
R := Rect(50, 50, 500, 500);
Canvas.Brush.Color := PatternColor;
BitBlt(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, Canvas.Handle, 0, 0, PATINVERT);
Canvas.Brush.Bitmap := FBitmap;
SetROP2(Canvas.Handle, R2_MASKPEN);
Canvas.Rectangle(R); //draw any figure here
Canvas.Brush.Color := PatternColor;
SetROP2(Canvas.Handle, R2_COPYPEN);
BitBlt(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom, Canvas.Handle, 0, 0, PATINVERT);
end;
I'm trying to use the Windows API function DrawText but don't get the results I expect. Maybe I'm doing something wrong here, but as I read the documentation I really don't see the problem. I'm using the following code.
function GetEllipsisString(Font: TFont; const Text: string;
Width: integer): String;
var
DC: HDC;
SaveFont: HFont;
R: TRect;
begin
DC := GetDC(0);
try
SaveFont := SelectObject(DC, Font.Handle);
R := Rect (0, 0, Width-1, 0);
Result := Text+' ';
Winapi.Windows.DrawtextW (DC, PChar(Result), Length(Result), R,
DT_CALCRECT+DT_LEFT+DT_PATH_ELLIPSIS+DT_MODIFYSTRING);
SelectObject(DC, SaveFont);
finally
ReleaseDC(0, DC);
end;
end;
DT_PATH_ELLIPSIS just doesn't seem to do anything. I tried it with DT_END_ELLIPSIS and that gave me some result (see example). When I give the paramater "Text" a string with a backslash (\) in it, it does seem to set the ellipsis but the function ignores the rect measurements.
Example
Text = 'This text has to many characters to fit.'
DT_END_ELLIPSIS returns 'This text has to m...'#0'characters to fit. '
DT_PATH_ELLIPSIS returns 'This text has to many characters to fit. '
Here's a procedure that draws a string with an ellipsis in the middle if the string is too wide for the given rect:
procedure DrawTextWithMiddleEllipsis(Canvas: TCanvas; Text: string; DrawRect:
TRect; Flags: Integer);
var
S, LastS: string;
R: TRect;
Sz: TSize;
RectWidth, I: Integer;
begin
S := Text;
R := DrawRect;
GetTextExtentPoint32(Canvas.Handle, S, Length(S), Sz);
RectWidth := DrawRect.Right - DrawRect.Left;
if Sz.cx > RectWidth then
begin
//The string is too wide. Need to cut it down with ellipsis
//Start with the smallest possible truncated-and-ellipsis-modified string,
//and expand until we have the biggest one that can fit
S := '...';
for I := 1 to Length(Text) div 2 do
begin
LastS := S;
//Get the first I chars, then the ellipsis, then the last I chars
S := Copy(Text, 1, I) + '...' + Copy(Text, Length(Text) - I + 1, I);
GetTextExtentPoint32(Canvas.Handle, S, Length(S), Sz);
if Sz.cx > RectWidth then
begin
DrawText(Canvas.Handle, LastS, Length(LastS), DrawRect, Flags);
Break;
end;
end;
end else
//The string will fit in the width of the given rect, don't mess with it
DrawText(Canvas.Handle, S, Length(S), DrawRect, Flags);
end;
Here's an example of how its called (PaintBox1 is a TPaintBox):
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
S: string;
R: TRect;
begin
S := 'This is extra long text that should overflow';
R := PaintBox1.ClientRect;
DrawTextWithMiddleEllipsis(PaintBox1.Canvas, S, R, DT_LEFT or DT_TOP);
end;
Based on #jthurman code
Advantages:
*simplified,
*more universal
*fixes a bug
Enjoy.
{ Takes a long string and truncates it in the middle. Example: '123...789' }
function GetEllipsisText(CONST s: string; Canvas: TCanvas; MaxWidth: Integer; Flags: Integer= DT_LEFT or DT_TOP): string;
var
NewStr, LastStr: string;
TextSize: TSize;
EllipsisSize: Integer;
begin
NewStr := '...';
EllipsisSize:= Canvas.TextWidth(NewStr);
GetTextExtentPoint32(Canvas.Handle, s, Length(s), TextSize);
if TextSize.cX > MaxWidth
then
//Start with the smallest possible truncated-and-ellipsis-modified string, and expand until we have the biggest one that can fit
for VAR i:= 1 to Length(s) div 2 do
begin
LastStr := NewStr;
NewStr := Copy(s, 1, I) + '...' + Copy(s, Length(s) - I + 1, I); // Get the first I chars, then the ellipsis, then the last I chars
GetTextExtentPoint32(Canvas.Handle, NewStr, Length(NewStr), TextSize);
if TextSize.cx > (MaxWidth - EllipsisSize)
then Exit(LastStr);
end
else
Result:= s; //The string will fit in the width of the given rect, don't mess with it
end;
Using Delphi 2010 and a TStringGrid component, I currently display five filds from a database query.
Here is a simplied example of what i am doing
//set up the grid
procedure TGriddata.FormCreate(Sender: TObject);
begin
grdMain.Rows[0].commatext:='"One","Two","Three","Four","Five"';
grdMain.ColWidths[0]:= 50;
grdMain.ColWidths[1]:= 175;
grdMain.ColWidths[2]:= 175;
grdMain.ColWidths[3]:= 100;
grdMain.ColWidths[4]:= 300;
end;
//display the data in the grid
//note, I am not showing my creation, execution, or destroy of the query
procedure TGriddata.load;
begin
...
grdMain.Cells[0,row]:= FieldByName('one').AsString;
grdMain.Cells[1,row]:= FieldByName('two').AsString;
grdMain.Cells[2,row]:= FieldByName('three').AsString;
grdMain.Cells[3,row]:= FieldByName('four').AsString;
//draw progress bar here
...
end;
One of the columns ("Five") needs to display a navy blue horizontal bar in the col. It should also diplay some text centered in the bar. I have no expereince using the custom drawing. What properties do i set to only custom draw the one column and use the default drawing for the other columns?
Add the text to the cells like you normally would. But you have to draw those bars in the OnDrawCell event. Leave DefaultDrawing as is (True by default), and erase the already drawn cell text in those columns by filling it in advance:
procedure TForm1.grdMainDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
Progress: Single;
R: TRect;
Txt: String;
begin
with TStringGrid(Sender) do
if (ACol = 4) and (ARow >= FixedRows) then
begin
Progress := StrToFloatDef(Cells[ACol, ARow], 0) / 100;
Canvas.FillRect(Rect);
R := Rect;
R.Right := R.Left + Trunc((R.Right - R.Left) * Progress);
Canvas.Brush.Color := clNavy;
Canvas.Rectangle(R);
Txt := Cells[ACol, ARow] + '%';
Canvas.Brush.Style := bsClear;
IntersectClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
Canvas.Font.Color := clHighlightText;
DrawText(Canvas.Handle, PChar(Txt), -1, Rect, DT_SINGLELINE or
DT_CENTER or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX);
SelectClipRgn(Canvas.Handle, 0);
ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
Canvas.Font.Color := clWindowText;
DrawText(Canvas.Handle, PChar(Txt), -1, Rect, DT_SINGLELINE or
DT_CENTER or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX);
SelectClipRgn(Canvas.Handle, 0);
end;
end;
For more options, you might consider this DrawStatus routine.
Here you can view a sample (Draw percentage in a cell in a Grid), to draw a bar in a cell of a TStringGrid.
The explanation is in spanish, but you can download the code, that is very simple.
Also you can use authomatic translation on right of page.
procedure TFormDrawCell.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
const
STR_EMPTY = '';
CHAR_PERCENT = '%';
SPACE_TO_CENTER_CELLTEXT = 0;
var
fValue: Integer;
ActualPenColor, ActualBrushColor: TColor;
EmptyDS: Boolean;
DrawRect: TRect;
fWidth1, fLeft2: Integer;
StrValue: string;
begin
if not (Column.FieldName = 'Precent') then
Exit;
if not (cbdraw.Checked) then
Exit;
EmptyDS := ((TDBGrid(Sender).DataSource.DataSet.EoF) and
(TDBGrid(Sender).DataSource.DataSet.Bof));
if (Column.Field.IsNull) then begin
fValue := -1;
StrValue := STR_EMPTY;
end
else begin
fValue := Column.Field.AsInteger;
StrValue := IntToStr(fValue) + CHAR_PERCENT;
end;
DrawRect := Rect;
InflateRect(DrawRect, -1, -1);
fWidth1 := (((DrawRect.Right - DrawRect.Left) * fValue) DIV 100);
ActualPenColor := TDBGrid(Sender).Canvas.Pen.Color;
ActualBrushColor := TDBGrid(Sender).Canvas.Brush.Color;
TDBGrid(Sender).Canvas.Pen.Color := clHighlight;
TDBGrid(Sender).Canvas.Brush.Color := clWhite;
TDBGrid(Sender).Canvas.Rectangle(DrawRect);
if (fValue > 0) then begin
TDBGrid(Sender).Canvas.Pen.Color := clSkyBlue;
TDBGrid(Sender).Canvas.Brush.Color := clSkyBlue;
DrawRect.Right := DrawRect.Left + fWidth1;
InflateRect(DrawRect, -1, -1);
TDBGrid(Sender).Canvas.Rectangle(DrawRect);
end;
if not (EmptyDS) then begin
DrawRect := Rect;
InflateRect(DrawRect, -2, -2);
TDBGrid(Sender).Canvas.Brush.Style := bsClear;
fLeft2 := DrawRect.Left + (DrawRect.Right - DrawRect.Left) shr 1 -
(TDBGrid(Sender).Canvas.TextWidth(StrValue) shr 1);
TDBGrid(Sender).Canvas.TextRect(DrawRect, fLeft2,
DrawRect.Top + SPACE_TO_CENTER_CELLTEXT, StrValue);
end;
TDBGrid(Sender).Canvas.Pen.Color := ActualPenColor;
TDBGrid(Sender).Canvas.Brush.Color := ActualBrushColor;
end;
Regards.
A simple demo of a default TLabel with font set to Arial Regular 16 is shown below.
The code when the button is clicked is:
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Font.Style := Label1.Font.Style + [fsItalic];
end;
When you click the button, the last character is truncated viz:
By default, TLAbel.AutoSize is true so this should be ok, right? This is in XE and Delphi 7 is the same. Is this a bug?
An extra space at the end is a quick work around for this.
Yes, it would seem so (although a rather minor bug). Possible work-arounds include
drawing the text yourself, using the Windows API function TextOut (or DrawText), and
using a TStaticText (instead of a TLabel), which is merely a wrapper for a Windows static control (in text mode). Of course, Windows draws the text correctly.
Using TextOut
procedure TForm4.FormPaint(Sender: TObject);
const
S = 'This is a test';
begin
TextOut(Canvas.Handle,
10,
10,
PChar(S),
length(S));
end;
Using a static control (TStaticText)
I would guess that this is not a problem in the Microsoft Windows operating system, but only in the VCL TLabel control.
Update
I tried
procedure TForm4.FormPaint(Sender: TObject);
const
S = 'This is a test';
var
r: TRect;
begin
r.Left := 10;
r.Top := 10;
r.Bottom := r.Top + DrawText(Canvas.Handle,
PChar(S),
length(S),
r,
DT_SINGLELINE or DT_LEFT or DT_CALCRECT);
DrawText(Canvas.Handle,
PChar(S),
length(S),
r,
DT_SINGLELINE or DT_LEFT);
end;
and the result is this:
Thus, this is a problem in the Microsoft Windows operating system (or the Arial font), after all.
A workaround is to add the DT_NOCLIP flag:
procedure TForm4.FormPaint(Sender: TObject);
const
S = 'This is a test';
var
r: TRect;
begin
r.Left := 10;
r.Top := 10;
r.Bottom := r.Top + DrawText(Canvas.Handle,
PChar(S),
length(S),
r,
DT_SINGLELINE or DT_LEFT or DT_CALCRECT);
DrawText(Canvas.Handle,
PChar(S),
length(S),
r,
DT_SINGLELINE or DT_LEFT or DT_NOCLIP);
end;
Update 2
A light-weight fix might be
type
TLabel = class(StdCtrls.TLabel)
protected
procedure DoDrawText(var Rect: TRect; Flags: Integer); override;
end;
...
{ TLabel }
procedure TLabel.DoDrawText(var Rect: TRect; Flags: Integer);
begin
inherited;
if (Flags and DT_CALCRECT) <> 0 then
Rect.Right := Rect.Right + 2;
end;
yielding the result
(But hard-coding a magic value (2) seems nasty...)
I want to have one fixed row as a header, but the texts are rather long, so I'd like to increase the row height and insert CR/LF into the cell text.
Googling shows this as a solution (and it's the first thing I thought of before googling), but it doesn't seem to work. Any ideas?
Grid.Cells[2,3] := 'This is a sample test' + #13#10 + 'This is the second line';
What happens is that the cell contains This is a sample testThis is the second line
I am using Delphi 7 if it makes any difference.
[Bounty] "My bad. I actually awarded this an answer two years ago without checking and now find that the answer did not work. Apologies to anyone who was misled. This is a frequently asked, often wrongly answered question."
I presume that we are looking to use OnDrawCell, but imagine that we would also have to increase the height of the string grid row which contains the cell.
I will award the answer for either code or a FOSS VCL component.
[Update] must work with Delphi XE2 Starter edition
TStringGrid uses Canvas.TextRect, which uses ExtTextOut, which in turn does not support drawing of multiline text.
You have to draw this yourself in an OnDrawCell event handler with WinAPI's DrawText routine. See for example this answer on how to use DrawText for multiline text, and this recent answer on how to implement custom drawing in OnDrawCell:
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure FormCreate(Sender: TObject);
procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
private
procedure FillWithRandomText(AGrid: TStringGrid);
procedure UpdateRowHeights(AGrid: TStringGrid);
end;
procedure TForm1.FillWithRandomText(AGrid: TStringGrid);
const
S = 'This is a sample'#13#10'text that contains'#13#10'multiple lines.';
var
X: Integer;
Y: Integer;
begin
for X := AGrid.FixedCols to AGrid.ColCount - 1 do
for Y := AGrid.FixedRows to AGrid.RowCount - 1 do
AGrid.Cells[X, Y] := Copy(S, 1, 8 + Random(Length(S) - 8));
UpdateRowHeights(AGrid);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FillWithRandomText(StringGrid1);
end;
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
with TStringGrid(Sender) do
if Pos(#13#10, Cells[ACol, ARow]) > 0 then
begin
Canvas.FillRect(Rect);
Inc(Rect.Left, 2);
Inc(Rect.Top, 2);
DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), -1, Rect,
DT_NOPREFIX or DT_WORDBREAK);
end;
end;
procedure TForm1.UpdateRowHeights(AGrid: TStringGrid);
var
Y: Integer;
MaxHeight: Integer;
X: Integer;
R: TRect;
TxtHeight: Integer;
begin
for Y := AGrid.FixedRows to AGrid.RowCount - 1 do
begin
MaxHeight := AGrid.DefaultRowHeight - 4;
for X := AGrid.FixedCols to AGrid.ColCount - 1 do
begin
R := Rect(0, 0, AGrid.ColWidths[X] - 4, 0);
TxtHeight := DrawText(AGrid.Canvas.Handle, PChar(AGrid.Cells[X, Y]), -1,
R, DT_WORDBREAK or DT_CALCRECT);
if TxtHeight > MaxHeight then
MaxHeight := TxtHeight;
end;
AGrid.RowHeights[Y] := MaxHeight + 4;
end;
end;
There are also other StringGrid components able of drawing multiline text. For instance, this one which I wrote myself (download source: NLDStringGrid) with possibly this result:
var
R: TRect;
begin
NLDStringGrid1.Columns.Add;
NLDStringGrid1.Columns.Add;
NLDStringGrid1.Cells[1, 1] := 'Sample test'#13#10'Second line';
NLDStringGrid1.Columns[1].MultiLine := True;
NLDStringGrid1.AutoRowHeights := True;
SetRect(R, 2, 2, 3, 3);
NLDStringGrid1.MergeCells(TGridRect(R), True, True);
NLDStringGrid1.ColWidths[2] := 40;
NLDStringGrid1.Cells[2, 2] := 'Sample test'#13#10'Second line';
end;
The TStringGrid's default renderer don't support multiple lines. By setting the TStringGrid in OwnerDraw mode (by invoking the OnDrawCell event) you can render each cell by your own liking.
Have a look at this for an example that helped a previous user.
Linked reference code inserted:
procedure DrawSGCell(Sender : TObject; C, R : integer; Rect : TRect;
Style : TFontStyles; Wrap : boolean; Just : TAlignment;
CanEdit : boolean);
{ draws formatted contents in string grid cell at col C, row R;
Style is a set of fsBold, fsItalic, fsUnderline and fsStrikeOut;
Wrap invokes word wrap for the cell's text; Just is taLeftJustify,
taRightJustify or taCenter; if CanEdit false, cell will be given
the background color of fixed cells; call this routine from
grid's DrawCell event }
var
S : string;
DrawRect : TRect;
begin
with (Sender as tStringGrid), Canvas do begin
{ erase earlier contents from default drawing }
if (R >= FixedRows) and (C >= FixedCols) and CanEdit then
Brush.Color:= Color
else
Brush.Color:= FixedColor;
FillRect(Rect);
{ get cell contents }
S:= Cells[C, R];
if length(S) > 0 then begin
case Just of
taLeftJustify : S:= ' ' + S;
taRightJustify : S:= S + ' ';
end;
{ set font style }
Font.Style:= Style;
{ copy of cell rectangle for text sizing }
DrawRect:= Rect;
if Wrap then begin
{ get size of text rectangle in DrawRect, with word wrap }
DrawText(Handle, PChar(S), length(S), DrawRect,
dt_calcrect or dt_wordbreak or dt_center);
if (DrawRect.Bottom - DrawRect.Top) > RowHeights[R] then begin
{ cell word-wraps; increase row height }
RowHeights[R]:= DrawRect.Bottom - DrawRect.Top;
SetGridHeight(Sender as tStringGrid);
end
else begin
{ cell doesn't word-wrap }
DrawRect.Right:= Rect.Right;
FillRect(DrawRect);
case Just of
taLeftJustify : DrawText(Handle, PChar(S), length(S), DrawRect,
dt_wordbreak or dt_left);
taCenter : DrawText(Handle, PChar(S), length(S), DrawRect,
dt_wordbreak or dt_center);
taRightJustify : DrawText(Handle, PChar(S), length(S), DrawRect,
dt_wordbreak or dt_right);
end;
end
end
else
{ no word wrap }
case Just of
taLeftJustify : DrawText(Handle, PChar(S), length(S), DrawRect,
dt_singleline or dt_vcenter or dt_left);
taCenter : DrawText(Handle, PChar(S), length(S), DrawRect,
dt_singleline or dt_vcenter or dt_center);
taRightJustify : DrawText(Handle, PChar(S), length(S), DrawRect,
dt_singleline or dt_vcenter or dt_right);
end;
{ restore no font styles }
Font.Style:= [];
end;
end;
end;
I think this will work fine for you...