head hurting - DBGrid Word Wrapping

[cazzajay]

Hey all

I have spent all day googling this, even returning some searches with only 4 results - that's how unusual I think my case it.

I have figured out using various webpages and trial and error how to word wrap in a DBGrid component - I have this:

Code: [Select]

procedure TForm1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  textstyle: ttextstyle;
  examine: string;

begin
  DBGrid2.Canvas.FillRect(Rect);
  TextStyle := Canvas.TextStyle;
  TextStyle.Wordbreak := True;
  TextStyle.SingleLine := false;


  examine := WrapText(DBGrid2.DataSource.DataSet.Fields[DataCol].value, #13#10, ['.',' ',#9,'-'] , dbgrid2.Columns[Datacol].width);

  DBGrid2.Canvas.TextRect(Rect, Rect.Left+1, Rect.Top+1, examine, textstyle);

end;                           
Which works great - as long as the rows are of sufficient height to see the wrapped text.

The next stage is to get the rows to change height to show this.

I tried expanding on my code with a few loops, using 18 as a starting row height (for one line) and increasing by 15 for each additional line - this fits with the font size I am using:

Code: [Select]

procedure TForm1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  textstyle: ttextstyle;
  i,x: integer;
  examine: string;

begin
  DBGrid2.Canvas.FillRect(Rect);
  TextStyle := Canvas.TextStyle;
  TextStyle.Wordbreak := True;
  TextStyle.SingleLine := false;


  examine := WrapText(DBGrid2.DataSource.DataSet.Fields[DataCol].value, #13#10, ['.',' ',#9,'-'] , dbgrid2.Columns[Datacol].width);
  DBGrid2.Canvas.TextRect(Rect, Rect.Left+1, Rect.Top+1, examine, textstyle);


  x := 18;

  for i := 1 to length(examine) do begin
    if examine[i-1] = #13 then x := x + 15;
  end;

  for i := 1 to tstringgrid(dbgrid2).rowcount do begin
    tstringgrid(dbgrid2).RowHeights[i-1] := x;
  end;

end;     
                     

However this does not work, because for some reason, the string "examine" does not appear to have the character #13 in it anywhere except once at the very end - even if it is wrapped across 5 lines.

I have tried everything, from working out the height of the textrect and using that (which stays constant regardless of the wrapped lines) right the way through to using a hidden label containing the same data to try and figure out the width of the original text and divide by the width of the column to work out approximate area....... but my head has been increasingly hurting trying to figure this one out

so I put it to the forum - can anyone please shed some light on this for me, or even just point me in the direction - or even just tell me if it is impossible or possible?

Thank you!! 

[taazz]

This should calculate the text rectangle required to show the string. This has been taken out from a working library that has a lot more checks and it was using a different wraptext function. I do not know how well will work in your case. If required I'll post the warptext function I am using.

Code: [Select]

uses LCLIntf, LCLType;


ffunction QueryTextRect(const Canvas:TCanvas; const aText:String; const aFont:TFont; const MaxRect: TRect):TRect;
const
  DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
begin
  if (Text <> '') then
  begin
    Canvas.Font := aFont;
    Result := MaxRect;
    LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
      Result, DrawTextFlags);
  end
  else
    FillChar(Result, SizeOf(Result), 0);
end;



[cazzajay]

Thanks taazz,

I tried your function to calculate height but it doesn't seem to provide a result that varies with the size of the text in the DBGrid.  I think it's because the event DBGridDrawColumnCell is called once for each cell?

I have found this delphi code on the internet:

http://stackoverflow.com/questions/7719025/calculating-size-of-text-before-drawing-to-a-canvas

A quick translate into Lazarus gives me this as a function:

Code: [Select]

function GetHeight(const s:String; const w:Integer):integer;
var
  r: TRect;

begin
  r.top := 1;
  r.left := 1;
  r.right := w;
  r.bottom := 60;

  DrawText(Canvas.Handle,
    PChar(S),
    Length(S),
    r,
    DT_LEFT or DT_WORDBREAK or DT_CALCRECT);

  result := r.Bottom - r.top;

end;       

but it fails to compile on Canvas.Handle with "identifier not found"... I'm not sure how to create an arbitrary canvas to do the calculation with (let alone if the calculation will work with Lazarus)

[taazz]

Its the same trick that my function uses. I do not know what you mean by "result that varies" make sure that you use it only on the column that needs the multi line calculations not on every cell that needs to be painted because it will be the same as using it only on the last column.

If you want all rows to have the same height then things will become a bit more complicated. In any way please provide some code to look at.

[cazzajay]

Thank you for getting back to me taazz!

I have this code using your function:

Code: [Select]

function QueryTextRect(const vCanvas:TCanvas; const aText:String; const MaxRect: TRect):TRect;
const
  DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
begin
  if (aText <> '') then
  begin
    //Canvas.Font := aFont;
    Result := MaxRect;
    LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
      Result, DrawTextFlags);
  end
  else
    FillChar(Result, SizeOf(Result), 0);
end;


procedure TForm1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  textstyle: ttextstyle;
  i,x: integer;
  examine: string;

begin
  DBGrid2.Canvas.FillRect(Rect);
  TextStyle := Canvas.TextStyle;
  TextStyle.Wordbreak := True;
  TextStyle.SingleLine := false;


  examine := WrapText(DBGrid2.DataSource.DataSet.Fields[DataCol].value, #13#10, ['.',' ',#9,'-'] , dbgrid2.Columns[Datacol].width);


  DBGrid2.Canvas.TextRect(Rect, Rect.Left+1, Rect.Top+1, examine, textstyle);

  x := (querytextrect(dbgrid2.canvas, examine, rect).Bottom-querytextrect(dbgrid2.canvas, examine, rect).Top);


  for i := 1 to length(examine) do begin
    if examine[i-1] = #10 then x := x + 15;
  end;

  for i := 1 to tstringgrid(dbgrid2).rowcount do begin
    tstringgrid(dbgrid2).RowHeights[i-1] := x;
  end;

end;

I removed the Font bit for testing (that's the way I teach myself) but I am not sure I am calling the function correctly to get the height in my procedure?

Regarding having the same height for all rows - I thought that was easier!! Best would be to have each row the minimum height to display all rows of text, resizing itself (redrawing?) when the column width is resized by dragging the title box...

Thank you for helping thus far!!

[taazz]

Well you didn't remove the old code and what is worst you add the new code before the old calculations having it replace all the calculation there. Take a look on the code bellow and tell me if it works as expected.

Code: [Select]

function QueryTextRect(const vCanvas:TCanvas; const aText:String; const MaxRect: TRect):TRect;
const
  DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
begin
  if (aText <> '') then
  begin
    //Canvas.Font := aFont;
    Result := MaxRect;
    LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
      Result, DrawTextFlags);
  end
  else
    FillChar(Result, SizeOf(Result), 0);
end;


procedure TForm1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  textstyle: ttextstyle;
  i,x: integer;
  examine, examine2: string;
  TextRect, MaxRect: Trect;
begin
  DBGrid2.Canvas.FillRect(Rect);
  TextStyle := Canvas.TextStyle;
  TextStyle.Wordbreak := True;
  TextStyle.SingleLine := false;


  examine := WrapText(DBGrid2.DataSource.DataSet.Fields[DataCol].value, #13#10, ['.',' ',#9,'-'] , dbgrid2.Columns[Datacol].width);


//  DBGrid2.Canvas.TextRect(Rect, Rect.Left+1, Rect.Top+1, examine, textstyle);
  MaxRect := classes.Rect(rect.Left,rect.right,0,4096);
  TextRect := querytextrect(dbgrid2.canvas, examine, 'hello',  MaxRect);
  x := TextRect.Bottom - TextRect.Top;

  for i := 1 to tstringgrid(dbgrid2).rowcount do begin
    if tstringgrid(dbgrid2).RowHeights[i-1] < x then tstringgrid(dbgrid2).RowHeights[i-1] := x;
  end;

end;

[/code

[cazzajay]

Hi taazz,

My bad re the modifications - I have been messing with the code to fix the errors and pasted garbage!

I edited my code in my previous post to correct my changes and provide my error free (but not working) function and procedure! but I think that was after you started looking at it!

I have this now (your code with the content bit un-commented-out:

Code: [Select]

function QueryTextRect(const vCanvas:TCanvas; const aText:String; const MaxRect: TRect):TRect;
const
  DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
begin
  if (aText <> '') then
  begin
    //Canvas.Font := aFont;
    Result := MaxRect;
    LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
      Result, DrawTextFlags);
  end
  else
    FillChar(Result, SizeOf(Result), 0);
end;


procedure TForm1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  textstyle: ttextstyle;
  i,x: integer;
  examine: string;
  TextRect, MaxRect: Trect;
begin
  DBGrid2.Canvas.FillRect(Rect);
  TextStyle := Canvas.TextStyle;
  TextStyle.Wordbreak := True;
  TextStyle.SingleLine := false;


  examine := WrapText(DBGrid2.DataSource.DataSet.Fields[DataCol].value, #13#10, ['.',' ',#9,'-'] , dbgrid2.Columns[Datacol].width);


  DBGrid2.Canvas.TextRect(Rect, Rect.Left+1, Rect.Top+1, examine, textstyle);
  MaxRect := classes.Rect(rect.Left,rect.right,0,4096);
  TextRect := querytextrect(dbgrid2.canvas, examine, MaxRect);
  x := TextRect.Bottom - TextRect.Top;

  for i := 1 to tstringgrid(dbgrid2).rowcount do begin
    if tstringgrid(dbgrid2).RowHeights[i-1] < x then tstringgrid(dbgrid2).RowHeights[i-1] := x;
  end;

end;                     

This populates the box but doesn't change row height as the column width is adjusted so that the text wraps many lines...?

I am open to suggestions on other ways to wrap the text?  Thanks again for the help!

[taazz]

I'll need to create a sample app for testing. Can't do it now i'll look at it later tonight.

[cazzajay]

Thank you for your help taazz, I really appreciate it!

[cazzajay]

Still stuck on this, I'm starting to think it's not possible - but it seems such a basic requirement to be able to alter the row height according to the number of wraps! 

[wp]

I think it is not possible for the standard TDBGrid to change the row heights. This is because the DBGrid loads from the database only those records needed. In case of different row heights, it would be much more complex to keep track of the position of the visible section in the database. You probably have to look for a third-party DBGrid variant.

[taazz]

I have made a couple of tests yesterday and I can confirm that the function I gave you works as expected. the WrapText function you are using is not for graphics mode programming it is for console mode or at least this is how I understand it after a quick look I might as well be wrong. In any case I have attached a sample application that has no test but it shows all the problems and how it can work it is of low quality and it requires a lot of work to make it stable and useable but it autosizes the rows as needed.

Just to make it clear I think that there are ready made components that can do this I think that KControls might support something like this and TDBVirtualTree supports it for sure. in any case this should get you started be careful with the autosizing because it also changes the size of the header haven't found a way to avoid that.

[cazzajay]

Thanks taazz!

I have transplanted this into my source, but it seems to be stuck in some sort of loop when run - constantly flickering the dbgrid?

here's my translation:

Code: [Select]

function WrapText(Canvas: TCanvas; const Text: string; MaxWidth: integer): string;
var
  DC: HDC;
  TextExtent: TSize;
  S, P, E: PChar;
  Line: string;
  IsFirstLine: boolean;
begin
  Result := '';
  DC := Canvas.Handle;
  IsFirstLine := True;
  P := PChar(Text);
  while P^ = ' ' do
    Inc(P);
  while P^ <> #0 do
  begin
    S := P;
    E := nil;
    while (P^ <> #0) and (P^ <> #13) and (P^ <> #10) do
    begin
      LCLIntf.GetTextExtentPoint(DC, S, P - S + 1, TextExtent);
      if (TextExtent.CX > MaxWidth) and (E <> nil) then
      begin
        if (P^ <> ' ') and (P^ <> ^I) then
        begin
          while (E >= S) do
            case E^ of
              '.', ',', ';', '?', '!', '-', ':',
              ')', ']', '}', '>', '/', '\', ' ':
                break;
              else
                Dec(E);
            end;
          if E < S then
            E := P - 1;
        end;
        Break;
      end;
      E := P;
      Inc(P);
    end;
    if E <> nil then
    begin
      while (E >= S) and (P^ = ' ') do
        Dec(E);
    end;
    if E <> nil then
      SetString(Line, S, E - S + 1)
    else
      SetLength(Line, 0);
    if (P^ = #13) or (P^ = #10) then
    begin
      Inc(P);
      if (P^ <> (P - 1)^) and ((P^ = #13) or (P^ = #10)) then
        Inc(P);
      if P^ = #0 then
        Line := Line + LineEnding;
    end
    else if P^ <> ' ' then
      P := E + 1;
    while P^ = ' ' do
      Inc(P);
    if IsFirstLine then
    begin
      Result := Line;
      IsFirstLine := False;
    end
    else
      Result := Result + LineEnding + Line;
  end;
end;                                                             

function QueryTextRect(const vCanvas:TCanvas; const aText:String; const MaxRect: TRect):TRect;
const
  DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
begin
  if (aText <> '') then
  begin
    //Canvas.Font := aFont;
    Result := MaxRect;
    LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
      Result, DrawTextFlags);
  end
  else
    FillChar(Result, SizeOf(Result), 0);
end;

procedure TForm1.DBGrid2ColumnSized(Sender: TObject);
var
  MaxRect  : TRect;
  TextRect : TRect;
  bkm      : TBookmark;
  Fs       : longword = 0;
  examine  : String;
  x, i     : Integer;
begin
    bkm := SQLQuery4.GetBookmark;
    SQLQuery4.First;
    repeat
      MaxRect := classes.Rect(0, DBGrid2.Columns[3].Width,0,4096);
      examine := SQLQuery4.fields[3].AsString;
      examine := WrapText(DBGrid2.Canvas,examine,dbgrid2.Columns[3].Width);
      TextRect := querytextrect(dbgrid2.canvas, examine, MaxRect);
      x := (TextRect.Bottom - TextRect.Top) + 3;
      if fs < x then fs := x;
      SQLQuery4.Next;
    until SQLQuery4.EOF;
    SQLQuery4.GotoBookmark(bkm);
    SQLQuery4.FreeBookmark(bkm);

    for i := 1 to tstringgrid(dbgrid2).rowcount do begin
      tstringgrid(dbgrid2).RowHeights[i-1] := x;
    end;

end;


procedure TForm1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  textstyle: ttextstyle;
  i,x: integer;
  examine: string;
  TextRect, MaxRect: Trect;
begin
  DBGrid2.Canvas.FillRect(Rect);
  TextStyle := Canvas.TextStyle;
  TextStyle.Wordbreak := True;
  TextStyle.SingleLine := false;
  examine := WrapText(DBGrid2.Canvas, DBGrid2.DataSource.DataSet.Fields[DataCol].AsString, (Rect.Right - Rect.Left) - 2);
  if DataCol = 3 then begin
    MaxRect := classes.Rect(rect.Left,rect.right,0,4096);
    TextRect := querytextrect(dbgrid2.canvas, examine, MaxRect);
    x := (TextRect.Bottom - TextRect.Top) + 3;
    for i := 1 to tstringgrid(dbgrid2).rowcount do begin
      TStringGrid(dbgrid2).RowHeights[i-1] := x;
    end;
  end;
  DBGrid2.Canvas.TextRect(Rect, Rect.Left+1, Rect.Top+1, examine, textstyle);
end;
                           

I can't see how I have gone wrong!? Being the author of the code is there something obvious I have missed?

with some texts it appears to flicker straight away but with others it only flickers when you scroll horizontally or vertically?

[taazz]

My knowledge on TDBGrid is minimal so I do not think I'm the best person to answer this in any case there are a few problems that I can see.

1) you have kept the if datacol = 3 that I used to limit the calculation to only the column that I have text that needs to be wrapped in the sample I provided. I do not know if that applies to your situation so please check it.

2) at the drawcell method, inside the "for i := 1 to rowcount" loop you need to make sure that the height you are setting is not smaller than the existing one, so executed only when the existing row size is smaller keeping it unchanged if it is bigger.

3) try to modify the loop to go from 2 to rowcount not 1 and see if that stops the resizing of the header.

4) make sure that the columnsized is not triggered when you set the rowheight property calculating the height multiple times.

That's all I can think of on the top of my head.

[taazz]

I made a small change on the sample I uploaded which handles things better this time around. The flicker is gone and the header is not resized any more please take a look on the attached project.