If a node in a VirtualStringTree is multiline (vsMultiline in Node.States) then how can i centre the text vertically for all columns (except the multiline column) in that node?
I have tried using the OnBeforeCellPaint (using TargetCanvas.TextOut()) but this does not paint the text at all. By default, the text for a multiline node is always painted at the top of the node.
(For non-multiline nodes the text is painted vertically centred).
Try it using DrawText(..)
you can add text alignment on it such as left, right, top, middle etc.
use the Cellrect for the Rect.
in your case i think it workable on OnDrawtext, set the DefaultText := False;
Thanks to XBasic3000, i was able to come up with this solution, which covers almost every possible combination:
procedure TForm1.TreeDrawText(
Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
Column: TColumnIndex; const Text: WideString; const CellRect: TRect;
var DefaultDraw: Boolean);
var DrawFormat : Cardinal;
R : TRect;
s : WideString;
NodeWidth,EllipsisWidth : Integer;
Size: TSize;
begin
if not (Column in [yourmultilinecolumns]) then
begin
DefaultDraw := False;
R := CellRect;
GetTextExtentPoint32W(TargetCanvas.Handle, PWideChar(Text), Length(Text), Size);
NodeWidth := Size.cx + 2 * Tree.TextMargin;
GetTextExtentPoint32W(TargetCanvas.Handle, '...', 3, Size);
EllipsisWidth := Size.cx;
if ((NodeWidth - 2 * Tree.TextMargin) > R.Right - R.Left) then
s := EllipseString(TargetCanvas.Handle, Text, R.Right - R.Left, EllipsisWidth)
else s := Text;
DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE;
Windows.DrawTextW(TargetCanvas.Handle, PWideChar(s), Length(s), R, DrawFormat);
end;
end;
The EllipseString() method is very similar to VirtualTrees.ShortenString() in VirtualTrees.pas.
The only isue is the inability to draw multiline text on other columns. You must specify the multilinecolumns set, so there is no capability to draw multiline and vertically centred.
Related
The code below should be creating a bitmap that is a 48x48 rectangle, of blue background color and a Text (actually just a letter) centered horizontally and vertically of white color.
However nothing happens.
procedure MakeCustomIcon(AText: string; AWidth: Integer; AHeight: Integer; AColor: TAlphaColor; var ABlob: TBlob);
var
Bitmap: TBitmap;
Rect: TRectF;
InStream: TMemoryStream;
begin
Bitmap := TBitmap.Create;
InStream := TMemoryStream.Create;
try
Bitmap.SetSize(AWidth, AHeight);
Bitmap.Canvas.Clear(AColor);
Bitmap.Canvas.Stroke.Kind := TBrushKind.bkSolid;
Bitmap.Canvas.StrokeThickness := 1;
Bitmap.Canvas.Fill.Color := TAlphaColorRec.White;
Bitmap.Canvas.BeginScene;
Rect.Create(0, 0, AWidth, AHeight);
Bitmap.Canvas.FillText(Rect, AText, true, 100, [TFillTextFlag.ftRightToLeft], TTextAlign.taCenter, TTextAlign.taCenter);
Bitmap.Canvas.EndScene;
Bitmap.SaveToStream(InStream);
InStream.Position := 0;
ABlob.Clear;
ABlob.LoadFromStream(InStream);
finally
Bitmap.Free;
InStream.Free;
end;
I have tested the rest of my program to make sure the image (that Blob) is actually transporting and getting displayed, and it is doing so. The problem is fully contained on the way it is drawn the bitmap on the method above.
This TBlob is an array of byte.
I am looking to do rectangles like this below, to be used in TListView:
I have prepared a project.
1-) Write Text on TImage
2-) Draw on TImage
3-) Effect to TImage
I Try on XE5
Samples:
procedure ReDraw(Image: TImage);
var
MyRect: TRectF;
begin
if Image.Bitmap.IsEmpty then Exit;
MyRect := TRectF.Create(0, Ozellik.SeritTop, Image.Bitmap.Width, Ozellik.SeritBot);
with Image.Bitmap.Canvas do
begin
BeginScene;
if not Seffaf.IsChecked then
Fill.Color := Ozellik.SeritRenk
else
Fill.Color := TAlphaColorRec.Null;
FillRect(MyRect, 0, 0, [], 1);
Fill.Color := Ozellik.YaziRenk;
if FontCombo.ItemIndex <> -1 then
Font.Family := FontCombo.Items[FontCombo.ItemIndex];
Font.Size := Ozellik.YaziBoyut;
FillText(MyRect,FonYazi.Text.Trim,True,1,[],TTextAlign.taCenter,TTextAlign.taCenter);
EndScene;
end;
Image.Repaint;
end;
http://www.dosya.tc/server32/vHsbaC/CapsYapMasa_st_.rar.html
All canvas drawings must be grouped into a BeginScene/EndScene block. Also, it is recommended to draw within a try-finally block.
So, instead of
Bitmap.Canvas.Clear(AColor);
...
Bitmap.Canvas.BeginScene;
...
Bitmap.Canvas.EndScene;
you should do:
Bitmap.Canvas.BeginScene;
try
Bitmap.Canvas.Clear(AColor);
...
finally
Bitmap.Canvas.EndScene;
end;
-- Regards
I am working on one project where I need the pixel of Last visible item in the TRichview.
By using 'LastVisibleItem' Property of TRichView I am able to find the Item Start Cordinate.
but the Problem is I need a pixel value of very last visible word.
Can any one tell me how I can get that?
Thanks in advance.
I'm a bit unsure how your LastVisibleItem property works. Below is a suggested solution to get the top-right coordinate of the last visible character. Hope it works for you.
//Function GetCharPos source: http://www.delphipages.com/forum/showthread.php?t=33707
function GetCharPos(AOwner : TControl; Index : LongInt) : TPoint;
var
p : TPoint;
begin
AOwner.Perform(EM_POSFROMCHAR,WPARAM(#p),Index);
Result := p;
end;
//Inspired by: http://www.swissdelphicenter.ch/en/showcode.php?id=1213
function GetLastVisibleCharIndex(AOwner : TControl):integer;
var
r: TRect;
begin
//The EM_GETRECT message retrieves the formatting rectangle of an edit control.
AOwner.Perform(EM_GETRECT, 0, Longint(#r));
r.Right := r.Right - 1;
r.Bottom := r.Bottom - 2;
//The EM_CHARFROMPOS message retrieves information about the character closest to a specified point in the client area of an edit control
result := AOwner.Perform(EM_CHARFROMPOS, 0, Integer(#r.BottomRight));
end;
//Get the Top-Right coordinate of the last visible character
function GetLastVisibleCharPos(AOwner : TControl):TPoint;
var Index : integer;
begin
index := GetLastVisibleCharIndex(AOwner);
result := GetCharPos(AOwner, index);
end;
Example usage:
procedure TForm2.Button3Click(Sender: TObject);
var
p : TPoint;
begin
p := GetLastVisibleCharPos(RichEdit1);
DrawCrossHair(p); //Help visualize the point
end;
//Helper proc to draw a cross-hair
procedure TForm2.DrawCrossHair(p : TPoint);
var
aCanvas: Tcanvas;
X, Y: Integer;
begin
aCanvas := TCanvas.Create;
Y := RichEdit1.Height;
X := RichEdit1.Width;
try
aCanvas.Handle := GetDC(RichEdit1.Handle);
aCanvas.Font := RichEdit1.Font;
aCanvas.Pen.color := clGreen; // Color of line
//Draw vertical line
aCanvas.MoveTo(p.x, 0);
aCanvas.LineTo(p.x, Y);
//Draw horizontal line
aCanvas.MoveTo(0, p.Y);
aCanvas.LineTo(x, p.y);
finally
ReleaseDC(RichEdit1.Handle, aCanvas.Handle);
aCanvas.Free;
end;
end;
I have a TTreeView in Delphi, with nodes at three levels.
I use node data to store another label besides the node text.
Type
TNodeData = class
ExtraNodeLabel: WideString;
//... other members
end;
I have an OnAdvancedCustomDrawItem event, where i want to display this ExtraNodeLabel before the node text.
I wish to achieve this:
The blue text would be the extra label.
higlighted item: first two words are also an extra label
What i got so far, is this:
Problems:
For some reason i can't draw text with different style if i use DrawText/drawTextW (I need drawtextW because of unicode data)
The other problem is, that anything outside the dotted focus rectangle is unclickable
What needs to be solved:
How can i draw text with different style using DrawText/DrawtextW
How can i make the whole text clickable?
Code:
procedure TMainForm.TntTreeView1AdvancedCustomDrawItem(
Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState;
Stage: TCustomDrawStage; var PaintImages, DefaultDraw: Boolean);
var
txtrect, fullrect : TRect;
DC: HDC;
fs: integer;
fc: TColor;
ExtralabelRect: TRect;
nData: TNodeData;
begin
nData := nil;
if assigned(Node.Data) then begin
nData := TNodeData(Node.Data);
end;
DC := TntTreeView1.canvas.Handle;
txtRect := Node.DisplayRect(True);
fullrect := Node.DisplayRect(False);
if stage = cdPostPaint then begin
TntTreeView1.Canvas.FillRect(txtRect);
if (cdsFocused In State) And (cdsSelected in State) then begin
DrawFocusRect(DC,txtRect);
end;
txtRect.Left := txtRect.Left + 1;
txtRect.Top := txtRect.Top + 1;
txtRect.Right := txtRect.Right - 1;
txtRect.Bottom := txtRect.Bottom - 1;
ExtralabelRect := txtRect;
fs := TntTreeView1.Canvas.Font.size;
fc := TntTreeView1.Canvas.Font.Color;
if (nData <> nil) And (nData.ExtraNodeLabel <> '') then begin
TntTreeView1.Canvas.Font.Size := 7;
TntTreeView1.Canvas.Font.color := clBlue;
DrawTextW(
DC,
PWideChar(nData.ExtraNodeLabel),
Length(nData.ExtraNodeLabel),
ExtraLabelRect,
DT_LEFT or DT_CALCRECT or DT_VCENTER
);
DrawTextW(
DC,
PWideChar(nData.ExtraNodeLabel),
Length(nData.ExtraNodeLabel),
ExtraLabelRect,
DT_LEFT or DT_VCENTER
);
txtRect.right := txtRect.Right + ExtraLabelRect.Right + 5;
txtRect.Left := ExtraLabelRect.Right + 5;
end;
TntTreeView1.Canvas.Font.Size := fs;
TntTreeView1.Canvas.Font.color := fc;
DrawTextW(
DC,
PWideChar((Node as TTntTreeNode).Text),
-1,
txtRect,
DT_LEFT or DT_VCENTER
);
end;
end;
Solution by the OP
I managed to partially solve custom drawing, by defining a TFont variable, and using SelectObject and setTextColor. Setting font color and style works, but setting the font size doesn't.
var
nFont: TFont;
begin
DC := TntTreeView1.Canvas.Handle;
NFont := TFont.Create;
// rest of the code here ...
// i tried to set nFont.Size, but it doesn't seem to work
nFont.Size := 7;
nFont.Color := colorToRGB(clBlue);
nFont.Style := TntTreeview1.Font.Style + [fsBold];
SelectObject(DC,NFont.Handle);
SetTextColor(DC,colortoRGB(clBlue));
DrawTextW(
DC,
PWideChar(nData.nodeLabel),
Length(nData.nodeLabel),
ExtraLabelRect,
DT_LEFT or DT_VCENTER
);
// rest of the code here
end;
Source:
I used the idea from here
Update 2
I solved the second problem by setting the treeview's RowSelect property to true.
For this, to work, i had to set the ShowLines property to false, and custom draw the lines and the buttons. It works now.
Update 3
I improved the solution for the first problem, by not creating a new font, but selecting the canvas font for displaying text, and this way i was able to change any aspect of the font, and the system cleartype settings are also applied:
// set font size for the canvas font (font style can be set the same time)
TntTreeView1.Canvas.Font.Size := 7;
// select canvas font for DC
SelectObject(DC,TntTreeView1.Canvas.Font.Handle);
// set font color
SetTextColor(DC,colortoRGB(clBlue));
I have a virtualstringtree (Gridlines enabled) with X headers and x roots.
I would like to add children (at least 1) to the roots that have only 1 text which is in the middle and goes through all the headers (independent). So no matter if I resize the headers, etc. the text is always aligned to the actual client size of the VirtualStringTree.
Is this possible? If so, how?
This sounds like cell merging. This is discussed here, for example, where the solution is to include toAutoSpanColumns in TreeOptions.AutoOptions.
If you want center-aligned text, override OnDrawText accordingly. Something like:
procedure TForm1.VirtualStringTree1DrawText(Sender: TBaseVirtualTree;
TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;
const Text: WideString; const CellRect: TRect; var DefaultDraw: Boolean);
var
r: TRect;
begin
r := CellRect;
Windows.DrawTextW(TargetCanvas.Handle, PWideChar(Text), Length(Text), r, DT_CENTER or DT_VCENTER);
DefaultDraw := False;
end;
I'm trying to implement an RTF-capable tool tip window in Delphi XE. To render the rich text, I'm using an off-screen TRichEdit. I need to do two things:
Measure the size of the text.
Paint the text
To accomplish both tasks, I wrote this method:
procedure TLookupHintWindow.CallFormatRange(R: TRect; var Range: TFormatRange;
MustPaint: Boolean);
var
TextRect: TRect;
begin
RichText.SetBounds(R.Left, R.Top, R.Right, R.Bottom);
TextRect := Rect(0, 0,
RichText.Width * Screen.Pixelsperinch,
RichText.Height * Screen.Pixelsperinch);
ZeroMemory(#Range, SizeOf(Range));
Range.hdc := Canvas.Handle;
Range.hdcTarget := Canvas.Handle;
Range.rc := TextRect;
Range.rcpage := TextRect;
Range.chrg.cpMin := 0;
Range.chrg.cpMax := -1;
SendMessage(RichText.Handle, EM_FORMATRANGE,
NativeInt(MustPaint), NativeInt(#Range));
SendMessage(RichText.Handle, EM_FORMATRANGE, 0, 0);
end;
The Range parameter is passed in, so I can use the calculated dimensions outside this method. The MustPaint parameter determines if the range should be calculated (False) or painted (True).
To calculate the range, I call this method:
function TLookupHintWindow.CalcRichTextRect(R: TRect; const Rtf: string): TRect;
var
Range: TFormatRange;
begin
LoadRichText(Rtf);
CallFormatRange(R, Range, False);
Result := Range.rcpage;
Result.Right := Result.Right div Screen.PixelsPerInch;
Result.Bottom := Result.Bottom div Screen.PixelsPerInch;
// In my example yields this rect: (0, 0, 438, 212)
end;
To paint it:
procedure TLookupHintWindow.DrawRichText(const Text: string; R: TRect);
var
Range: TFormatRange;
begin
CallFormatRange(R, Range, True);
end;
The problem is that while it calculates a rectangle that is 438 pixels wide and 212 high, it actually paints one that is very wide (gets clipped) and only 52 pixels high.
I have word wrap turned on, although it was my impression that that should not be needed.
Any ideas?
Your units are off. Consider this expression from your code, for example:
RichText.Width * Screen.Pixelsperinch
The left term is in pixels, and the right term is in pixels/inch, so the units of the result are pixels²/inch. The expected unit for the rectangles used in em_FormatRange is twips. If you want to convert pixels to twips, you need this:
const
TwipsPerInch = 1440;
RichText.Width / Screen.PixelsPerInch * TwipsPerInch
You don't need an off-screen rich-edit control. You just need a windowless rich-edit control, which you can instruct to paint directly onto your tool-tip. I've published some Delphi code that makes the basics straightforward. Beware that it's not Unicode-aware, and I have no plans to make it so (although it might not be too complicated to do).
The main function from my code is DrawRTF, shown below, in RTFPaint.pas. It doesn't quite fit your needs, though; you want to discover the size before drawing it, whereas my code assume you already know the dimensions of the drawing target. To measure the size of the RTF text, call ITextServices.TxGetNaturalSize.
Word wrapping is important. Without it, the control will assume it has infinite width to work with, and it will only start a new line when the RTF text requests it.
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;