Currently using canvas.textout in a TGraphicControl Component, to show some text but i need the text to stay inside an area. Is there any property like word wrap i could use.. or a way to set the textout area? like so
var
r: TRect
s: string
begin
s := 'some long text that takes up about 3-4 lines';
r.Left := 10;
r.Top := 10;
r.Right := 20;
r.bottom := 50;
textout(r,s);
end;
You can use the DrawText function for this:
procedure TForm1.FormPaint(Sender: TObject);
const
S = 'This is some sample text. It is very long. Very long, indeed.' +
'Very, very, long.';
var
R: TRect;
begin
R := Rect(100, 100, 200, 200);
DrawText(Canvas.Handle, S, length(S), R, DT_WORDBREAK);
end;
Related
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;
Is there a way to draw a transparent text on form that has some controls? If I use TLabel control, it would always show behind controls on the form.
You cannot use a TLabel control, since it is not a windowed control, and therefore it will be hidden by every windowed child control of the form. You could use a TStaticText, which is indeed a windowed control (a STATIC control), but it will be a bit difficult to make it truly transparent, I'd suppose.
You can use layered windows for this:
Create a new VCL project, and add a bunch of windowed controls to it.
Create a new form in the project, named splash. Set BorderStyle to bsNone, and set the font name, size, and colour to whatever you desire (e.g., Segoe UI, 42, red).
Add a public method
procedure Tsplash.UpdateSplash(const Str: string);
var
R: TRect;
P: TPoint;
S: TPoint;
bm: TBitmap;
bf: TBlendFunction;
EXSTYLE: DWORD;
x, y: integer;
pixel: PRGBQuad;
TextRed,
TextGreen,
TextBlue: byte;
begin
EXSTYLE := GetWindowLong(Handle, GWL_EXSTYLE);
SetWindowLong(Handle, GWL_EXSTYLE, EXSTYLE or WS_EX_LAYERED);
R := ClientRect;
bm := TBitmap.Create;
try
bm.PixelFormat := pf32bit;
bm.SetSize(ClientWidth, ClientHeight);
bm.Canvas.Brush.Color := clBlack;
bm.Canvas.FillRect(ClientRect);
bm.Canvas.Font.Assign(Self.Font);
bm.Canvas.Font.Color := clWhite;
DrawText(bm.Canvas.Handle, PChar(Str), Length(Str), R,
DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_WORD_ELLIPSIS);
TextRed := GetRValue(Font.Color);
TextGreen := GetGValue(Font.Color);
TextBlue := GetBValue(Font.Color);
for y := 0 to bm.Height - 1 do
begin
pixel := bm.ScanLine[y];
x := 0;
while x < bm.Width do
begin
with pixel^ do
begin
rgbReserved := (rgbRed + rgbGreen + rgbBlue) div 3;
rgbBlue := TextBlue * rgbReserved div 255;
rgbGreen := TextGreen * rgbReserved div 255;
rgbRed := TextRed * rgbReserved div 255;
end;
inc(pixel);
inc(x);
end;
end;
P := Point(0, 0);
S := Point(bm.Width, bm.Height);
bf.BlendOp := AC_SRC_OVER;
bf.BlendFlags := 0;
bf.SourceConstantAlpha := 255;
bf.AlphaFormat := AC_SRC_ALPHA;
UpdateLayeredWindow(Handle, 0, nil, #S, bm.Canvas.Handle, #P, 0, #bf,
ULW_ALPHA)
finally
bm.Free;
end;
end;
To your main form, add private methods
procedure TForm1.CreateSplash;
var
p: TPoint;
begin
splash.Visible := true;
UpdateSplash;
end;
procedure TForm1.UpdateSplash;
var
p: TPoint;
begin
if not (Assigned(splash) and splash.Visible) then Exit;
p := ClientToScreen(Point(0, 0));
splash.SetBounds(p.X, p.Y, ClientWidth, ClientHeight);
splash.UpdateSplash('Sample Text');
end;
and call UpdateSplash every time the form is moved or resized:
procedure TForm1.WMMove(var Message: TWMMove);
begin
UpdateSplash;
end;
procedure TForm4.FormResize(Sender: TObject);
begin
UpdateSplash;
end;
Finally, you can do, just to try it out,
procedure TForm1.FormClick(Sender: TObject);
begin
if splash.Visible then
splash.Hide
else
CreateSplash;
end;
Compiled demo EXE
Take the below image I will use for the following examples:
The dimensions unchaged are currently 96 x 71
Lets say I wanted to resize the canvas to 115 x 80 - the resulting image should then be:
Finally if I resized it to a smaller size than the original canvas was, eg 45 x 45 the output would appear like so:
This is what I have tried so far:
procedure ResizeBitmapCanvas(Bitmap: TBitmap; H, W: Integer);
var
Bmp: TBitmap;
Source, Dest: TRect;
begin
Bmp := TBitmap.Create;
try
Source := Rect(0, 0, Bitmap.Width, Bitmap.Height);
Dest := Source;
Dest.Offset(Bitmap.Width div 2, Bitmap.Height div 2);
Bitmap.SetSize(W, H);
Bmp.Assign(Bitmap);
Bmp.Canvas.FillRect(Source);
Bmp.Canvas.CopyRect(Dest, Bitmap.Canvas, Source);
Bitmap.Assign(Bmp);
finally
Bmp.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ResizeBitmapCanvas(Image1.Picture.Bitmap, 110, 110);
end;
If you try the above on a bitmap loaded into a TImage the actual bitmap does not center, the canvas does change size however.
The properties I have set for the Image are:
Image1.AutoSize := True;
Image1.Center := True;
Image1.Stretch := False;
I think it could be the line Dest.Offset(Bitmap.Width div 2, Bitmap.Height div 2); which needs looking at, to calculate the correct center position?
The code has been adapted/modified slightly from a recent question David Heffernan answered.
How do I resize the canvas that surrounds a bitmap, but without stretching the bitmap?
I think this is what you are looking for:
procedure ResizeBitmapCanvas(Bitmap: TBitmap; H, W: Integer; BackColor: TColor);
var
Bmp: TBitmap;
Source, Dest: TRect;
Xshift, Yshift: Integer;
begin
Xshift := (Bitmap.Width-W) div 2;
Yshift := (Bitmap.Height-H) div 2;
Source.Left := Max(0, Xshift);
Source.Top := Max(0, Yshift);
Source.Width := Min(W, Bitmap.Width);
Source.Height := Min(H, Bitmap.Height);
Dest.Left := Max(0, -Xshift);
Dest.Top := Max(0, -Yshift);
Dest.Width := Source.Width;
Dest.Height := Source.Height;
Bmp := TBitmap.Create;
try
Bmp.SetSize(W, H);
Bmp.Canvas.Brush.Style := bsSolid;
Bmp.Canvas.Brush.Color := BackColor;
Bmp.Canvas.FillRect(Rect(0, 0, W, H));
Bmp.Canvas.CopyRect(Dest, Bitmap.Canvas, Source);
Bitmap.Assign(Bmp);
finally
Bmp.Free;
end;
end;
I can't remember if XE supports setting Width and Height for a TRect. If not then change the code to
Source.Right := Source.Left + Min(W, Bitmap.Width);
and so on.
On some forms I have dbEdits that sometimes aren't wide enough to show all the text their fields may contain. For them I have the following code:
procedure Tgm12edLots.dbeLotNameMouseEnter(Sender: TObject);
begin
with dbeLotName do begin
ShowHint := True;
Hint := Text;
end;
end;
I'd like to avoid the hint showing if all the text is visible, but I don't how to test for that condition.
Thanks for any tips/suggestions!
Here is a fast version (without a TBitmap overhead) that takes into account the Edit control's Margins (i.e. EM_SETMARGINS).
Use IsEditTextOverflow below to determine if the Text overflows the visible area.
type
TCustomEditAccess = class(TCustomEdit);
function EditTextWidth(Edit: TCustomEdit): Integer;
var
DC: HDC;
Size: TSize;
SaveFont: HFont;
begin
DC := GetDC(0);
SaveFont := SelectObject(DC, TCustomEditAccess(Edit).Font.Handle);
GetTextExtentPoint32(DC, PChar(Edit.Text), Length(Edit.Text), Size);
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
Result := Size.cx;
end;
function EditVisibleWidth(Edit: TCustomEdit): Integer;
var
R: TRect;
begin
SendMessage(Edit.Handle, EM_GETRECT, 0, LPARAM(#R));
Result := R.Right - R.Left;
end;
function IsEditTextOverflow(Edit: TCustomEdit): Boolean;
begin
Result := EditTextWidth(Edit) > EditVisibleWidth(Edit);
end;
I think this should work...
function CanShowAllText(Edit: TDBEdit):Boolean;
var
TextWidth:Integer;
VisibleWidth: Integer;
Bitmap: TBitmap;
const
//This could be worked out but without delphi I can't remember all that goes into it.
BordersAndMarginsWidthEtc = 4;
begin
Bitmap := TBitmap.Create;
try
Bitmap.Canvas.Font.Assign(Edit.Font);
TextWidth := Bitmap.Canvas.TextWidth(Edit.Text);
VisibleWidth := Edit.Width - BordersAndMarginsWidthEtc;
Result := TextWidth < VisibleWidth;
finally
Bitmap.Free;
end;
end;
I think my question is clear enough, but I explain more. Simply, when we are using AntiAlias on RenderText procedure, the value gotten within TextWidth function is not correct. What can I do to get the right text width?
You can look for the algorithm in their own code. They must also calculate it. Anyway this is how I do it.
function TGR32Canvas.TextWidth(const Text: string): Integer;
var
TempFont: TFont;
TempWidth: Integer;
begin
if Text <> '' then
begin
TempFont := TFont.Create;
try
TempFont.Assign(Font);
TempFont.Size := Font.Size shl AA_MODE;
TempWidth := GetTextWidth(Text, TempFont);
finally
TempFont.Free;
end;
end
else
TempWidth := 0;
TempWidth := (TempWidth shr AA_MODE + 1) shl AA_MODE;
Result := TempWidth shr AA_MODE;
end;
The GetTextWidth function is simple. You can do it differently.
function GetTextWidth(const Text: string; const Font: TFont): Integer;
var
Canvas: TCanvas;
begin
Canvas := TCanvas.Create;
try
Canvas.Handle := GetDC(0);
try
Canvas.Font.Assign(Font);
Result := Canvas.TextWidth(Text);
finally
ReleaseDC(0, Canvas.Handle);
end;
finally
Canvas.Free;
end;
end;
You can also use the Windows API function GetTextExtentPoint32
Do some google to find example on Delphi