Lazarus

Programming => General => Topic started by: Tommi on May 11, 2018, 09:54:38 am

Title: Change single character font in VirtualTreeView
Post by: Tommi on May 11, 2018, 09:54:38 am
Actually I can change font to the entire cell using VSTPaintText event.

What I would like to do is to highlight a single word in the cell.

How could I do?

Thank you
Title: Re: Change single character font in VirtualTreeView
Post by: balazsszekely on May 11, 2018, 10:04:44 am
You have to owner draw the text. I would switch to VirtualDrawTree.
Title: Re: Change single character font in VirtualTreeView
Post by: balazsszekely on May 11, 2018, 10:34:12 am
You can do it with VST too, though you loose some of the functionality of VDV. Create a new project, set VTV rootnodecount to 10, then:
Code: Pascal  [Select][+][-]
  1. uses LCLIntf, LCLType;
  2.  
  3. procedure TForm1.VSTDrawText(Sender: TBaseVirtualTree;
  4.   TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
  5.   const CellText: String; const CellRect: TRect; var DefaultDraw: Boolean);
  6. var
  7.   P: Integer;
  8.   StrNormal: String;
  9.   StrHighlight: String;
  10.   RNormal,
  11.   RHighlight: TRect;
  12. begin
  13.   P := Pos('number', CellText);
  14.   if P = 0 then
  15.     Exit;
  16.   DefaultDraw := False;
  17.   StrNormal := Copy(CellText, 1, P - 1);
  18.   StrHighlight := Copy(CellText, P, Length(CellText));
  19.   RNormal := CellRect;
  20.   RHighlight := CellRect;
  21.   DrawText(TargetCanvas.Handle, PChar(StrNormal), Length(StrNormal), RNormal, DT_LEFT or DT_BOTTOM or DT_SINGLELINE);
  22.   DrawText(TargetCanvas.Handle, PChar(StrNormal), Length(StrNormal), RNormal, DT_LEFT or DT_BOTTOM or DT_SINGLELINE + DT_CALCRECT);
  23.   RHighlight.Left := RNormal.Right + 2;
  24.   TargetCanvas.Font.Color := clRed;
  25.   TargetCanvas.Font.Style := TargetCanvas.Font.Style + [fsBold];
  26.   DrawText(TargetCanvas.Handle, PChar(StrHighlight), Length(StrHighlight), RHighlight, DT_LEFT or DT_BOTTOM or DT_SINGLELINE);
  27. end;
  28.  
  29. procedure TForm1.VSTGetText(Sender: TBaseVirtualTree;
  30.   Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
  31.   var CellText: String);
  32. begin
  33.   CellText := 'Line number ' + IntToStr(VST.AbsoluteIndex(Node));
  34. end;  
Title: Re: Change single character font in VirtualTreeView
Post by: Tommi on May 11, 2018, 10:55:38 am
Doing so I loose multiline functionality. Is there a way to restore it ?

Actually I am calculating height of the cell doing:
Code: [Select]
procedure TForm1.VSTMeasureItem(Sender: TBaseVirtualTree;
  TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer);
begin
 if Sender.MultiLine[Node] then  //WordWrap
  begin
    TargetCanvas.Font := Sender.Font;
    NodeHeight := VST.ComputeNodeHeight(TargetCanvas, Node, 2)+15;
   // NodeHeight:=NodeHeight+TargetCanvas.Font.Size*10;
  end;
end;
Title: Re: Change single character font in VirtualTreeView
Post by: balazsszekely on May 11, 2018, 10:58:23 am
Please check attachment from this post: http://forum.lazarus.freepascal.org/index.php/topic,37834.msg256597.html#msg256597 , especially the VDTDrawNode method.
Title: Re: Change single character font in VirtualTreeView
Post by: Tommi on May 12, 2018, 09:23:12 am
It isn't exactly what I need. In your example there are two different fonts, but there isn't any wordwrap on the same line with more than one font.

I found this code that I think that could solve my problem, but it is just for delhi:

Code: [Select]
procedure DrawRTF(Canvas: TCanvas; const RTF: string; const Rect: TRect;
  const Transparent, WordWrap: Boolean);
var
  Host: ITextHost;
  Unknown: IUnknown;
  Services: ITextServices;
  HostImpl: TTextHostImpl;
  Stream: TEditStream;
  Cookie: TCookie;
  res: Integer;
begin
  HostImpl := TDrawRTFTextHost.Create(Rect, Transparent, WordWrap);
  Host := CreateTextHost(HostImpl);
  OleCheck(CreateTextServices(nil, Host, Unknown));
  Services := Unknown as ITextServices;
  Unknown := nil;
  PatchTextServices(Services);

  Cookie.dwCount := 0;
  Cookie.dwSize := Length(RTF);
  Cookie.Text := PChar(RTF);
  Stream.dwCookie := Integer(@Cookie);
  Stream.dwError := 0;
  Stream.pfnCallback := EditStreamInCallback;
  OleCheck(Services.TxSendMessage(em_StreamIn, sf_RTF or sff_PlainRTF,
    lParam(@Stream), res));

  OleCheck(Services.TxDraw(dvAspect_Content, 0, nil, nil, Canvas.Handle,
    0, Rect, PRect(nil)^, PRect(nil)^, nil, 0, txtView_Inactive));
  Services := nil;
  Host := nil;
end;

If it would work I would create a rtf string and I would copy the rendered image on the treeview canvas.

I also tried to create a TRichMemo without setting a parent, but it doesn't work.
Title: Re: Change single character font in VirtualTreeView
Post by: balazsszekely on May 12, 2018, 09:43:27 am
Yes, your case is special. Personally I would go with the embedded TRichMemo. How many rows do you have? A few hundred should be OK, if you have more lines the application will become sluggish.
Title: Re: Change single character font in VirtualTreeView
Post by: wp on May 12, 2018, 11:28:05 am
Instead of rtf you could also go the html way. In the attached unit "htmltext" I extracted the html rendering routines used by the JVCL library. It seems to have an issue with subscripts, though, and the color values seem to be against html specification. Of course, this can be fixed...
Title: Re: Change single character font in VirtualTreeView
Post by: balazsszekely on May 12, 2018, 11:33:13 am
If you choose to go with rtf, I attach a project which converts a TRichMemo to a Bmp. All you have to do is render the bitmap on the VTV canvas. This will slightly slow down the load of the tree but then this is a complex issue.
Title: Re: Change single character font in VirtualTreeView
Post by: Soner on May 12, 2018, 01:17:15 pm
Instead of rtf you could also go the html way. In the attached unit "htmltext" I extracted the html rendering routines used by the JVCL library. It seems to have an issue with subscripts, though, and the color values seem to be against html specification. Of course, this can be fixed...
Nice functions.

Error with subscripts located here:
Code: Pascal  [Select][+][-]
  1.         if ScriptPosition = spSubscript then
  2.           R.Top := R.Bottom - Height - 1; //this must be from line height not whole rect height.
  3.  

This solves the problem(I commented changes with my name):
Code: Pascal  [Select][+][-]
  1.   procedure Draw(const M: string);
  2.   var
  3.     Width, Height, aLineheight: Integer; //soner add: aLineheight
  4.     R: TRect;
  5.     OriginalFontSize: Integer;
  6.   begin
  7.     R := Rect;
  8.     Inc(R.Left, CurLeft);
  9.     if Assigned(Canvas) then
  10.     begin
  11.       OriginalFontSize := Canvas.Font.Size;
  12.       try
  13.         if ScriptPosition <> spNormal then begin
  14.           aLineheight:=CanvasMaxTextHeight(Canvas); //soner add
  15.           Canvas.Font.Size := Round(Canvas.Font.Size * SuperSubScriptRatio);
  16.         end;
  17.  
  18.         Width  := Canvas.TextWidth(M);
  19.         Height := CanvasMaxTextHeight(Canvas);
  20.  
  21.         if ScriptPosition = spSubscript then
  22.           R.Top := R.Top+ aLineheight  - Height; //soner original: R.Top := R.Bottom - Height - 1;
  23.  
  24.         if IsLink and not MouseOnLink then
  25.           if (MouseY >= R.Top) and (MouseY <= R.Top + Height) and
  26.              (MouseX >= R.Left) and (MouseX <= R.Left + Width) and
  27.              ((MouseY > 0) or (MouseX > 0)) then
  28.           begin
  29.             MouseOnLink := True;
  30.             Canvas.Font.Color := clRed; // hover link
  31.             LinkName := TempLink;
  32.           end;
  33.         if CalcType = htmlShow then
  34.         begin
  35.           if Trans then
  36.             Canvas.Brush.Style := bsClear; // for transparent
  37.           Canvas.TextOut(R.Left, R.Top, M);
  38.         end;
  39.         CurLeft := CurLeft + Width;
  40.       finally
  41.         Canvas.Font.Size := OriginalFontSize;
  42.       end;
  43.     end;
  44.   end;
  45.  

Edit:
There can be still errors with multiline text, because it should here calculated with line top not with component top:
  R.Top := R.Top+ aLineheight  - Height;

Edit2:
There is no problem with multiline text. Multiline text must be added with:
txt := '<b>Line1'+LineEnding+'Line2';
Title: Re: Change single character font in VirtualTreeView
Post by: wp on May 12, 2018, 06:31:15 pm
Thank you for your code, I added it to the JVCL unit JvJVCLUtils from which the code was copied (https://sourceforge.net/p/lazarus-ccr/svn/HEAD/tree/components/jvcllaz/). I also added these fixes:
As for the line breaks, you can also insert <br> tags. You only have to pass the string to the function HTMLPrepareText which does a lot of replacements of html entities (e.g. '&amp;' by '&'), among them also '<br>' by sLineBreak.

In the attachment I am providing the updated version of htmltext.pas.
Title: Re: Change single character font in VirtualTreeView
Post by: Tommi on May 13, 2018, 07:51:56 am
Thank you to every one. After many testsI found that the best solution for me is this one:
Code: [Select]
procedure TForm1.VSTDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas;
  Node: PVirtualNode; Column: TColumnIndex; const CellText: String;
  const CellRect: TRect; var DefaultDraw: Boolean);
var
  S:string='';
  a,b,c,d,e,f:integer;
  cond1:boolean;
  cond2:boolean;
  lun:integer;
begin
   DefaultDraw:=false;
   lun:=length(CellText);
   c:=0;
   d:=0;
   for a:=1 to lun do
   begin
     b:=TargetCanvas.TextWidth(CellText[a]);
   
    <-------Here I change my font  --------->

     TargetCanvas.TextOut(CellRect.Left+c,CellRect.Top+d,CellText[a]);
     c:=c+b;
     cond1:=c+b>CellRect.Right-CellRect.Left;
     f:=0;
     if (CellText[a]=' ') and (a<lun) then
     begin
       for e := a+1 to lun do
       begin
         if CellText[e]<>' ' then S:=S+CellText[e] else break;
       end;
       f:=TargetCanvas.TextWidth(S);
     end;
     cond2:=c+f>CellRect.Right-CellRect.Left-4;
     S:='';
     if cond1 or cond2 then
     begin
       c:=0;
       d:=d+trunc(TargetCanvas.TextHeight(CellText));
     end;
   end;
end; 

From here I can manage easily the text changing colors, underline etc.

Now the question is: what I put in onMeasure event?

I cannot change TargetCanvas height from onDrawText so actually I am doing this:
Code: [Select]
procedure TForm1.VSTMeasureItem(Sender: TBaseVirtualTree;
  TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer);
begin
 if Sender.MultiLine[Node] then  //WordWrap
  begin
    TargetCanvas.Font := Sender.Font;
    NodeHeight := VST.ComputeNodeHeight(TargetCanvas, Node, 2)+80;
   // NodeHeight:=NodeHeight+TargetCanvas.Font.Size*10;
  end;
end;

I put arbitrary 80 to the regular measure, but I think that I could be more precise...
TinyPortal © 2005-2018