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;
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;
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.
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;
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;