I have a TLabel with fixed height and word wrap. The problem is that when the caption text exceeds the label's height, I can't see the last lines of text. I search entire internet for label components that can scroll down and show the last lines of text that exceeds the height of caption.
As you can see in this picture, line 7 is half visible and line 8 is not even shown:
I want line 1 to disappear or go up and line 8 be fully visible.
You can override TLabel's DoDrawText virtual method. something like this (example using interposer class):
TLabel = class(StdCtrls.TLabel)
protected
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
end;
...
procedure TLabel.DoDrawText(var Rect: TRect; Flags: Longint);
var
R: TRect;
TextHeight: Integer;
begin
if (Flags and DT_CALCRECT = 0) then
begin
R := ClientRect;
Canvas.Font := Font;
DrawText(Canvas.Handle, PChar(Text), -1, R, DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK);
TextHeight := R.Bottom - R.Top;
if TextHeight > ClientHeight then
Rect.Top := Rect.Top - (TextHeight - ClientHeight);
end;
inherited DoDrawText(Rect, Flags);
end;
You can use TScrollBox :
Drop a TScrollBox.
Drop a TLabel inside the TScrollBox.
Set Label Align to alTop.
Related
I'm tyring calculate the maximum fontsize in order for at Text to fit into the ClientRect of a TCxLabel. But I cant get it to work probably. (See picture)
The fontsize is to big and the thxt is not drawn the corrent place.
Here how to reproduce:
Place a tcxLabel on an empty Form, and allign the label to client
Add a FormCreate and a FormResize event :
procedure TForm48.FormCreate(Sender: TObject);
begin
CalculateNewFontSize;
end;
procedure TForm48.FormResize(Sender: TObject);
begin
CalculateNewFontSize;
end;
and Finally implement CalculateNewFontSize :
uses
Math;
procedure TForm48.CalculateNewFontSize;
var
ClientSize, TextSize: TSize;
begin
ClientSize.cx := cxLabel1.Width;
ClientSize.cy := cxLabel1.Height;
cxLabel1.Style.Font.Size := 10;
TextSize := cxLabel1.Canvas.TextExtent(Text);
if TextSize.cx * TextSize.cx = 0 then
exit;
cxLabel1.Style.Font.Size := cxLabel1.Style.Font.Size * Trunc(Min(ClientSize.cx / TextSize.cx, ClientSize.cy / TextSize.cy) + 0.5);
end;
Does any one know how to calculate the font size and ho to place the text correctly?
I'd use something along these lines:
function LargestFontSizeToFitWidth(Canvas: TCanvas; Text: string;
Width: Integer): Integer;
var
Font: TFont;
FontRecall: TFontRecall;
InitialTextWidth: Integer;
begin
Font := Canvas.Font;
FontRecall := TFontRecall.Create(Font);
try
InitialTextWidth := Canvas.TextWidth(Text);
Font.Size := MulDiv(Font.Size, Width, InitialTextWidth);
if InitialTextWidth < Width then
begin
while True do
begin
Font.Size := Font.Size + 1;
if Canvas.TextWidth(Text) > Width then
begin
Result := Font.Size - 1;
exit;
end;
end;
end;
if InitialTextWidth > Width then
begin
while True do
begin
Font.Size := Font.Size - 1;
if Canvas.TextWidth(Text) <= Width then
begin
Result := Font.Size;
exit;
end;
end;
end;
finally
FontRecall.Free;
end;
end;
Make an initial estimate, and then fine tune by modifying the size by increments of one at a time. This is easy to understand and verify for correctness, and also quite efficient. In typical use the code will call TextWidth only a handful of times.
Text size doesn't depend linearly on font size. So you would better to increment or decrement font size by one and calculate text sizes, or find needed size with binary search (preferable, if size differs significantly)
I want to put a label inside progress bar. And this label caption is dynamic.
How can I get the label position ALWAYS on center inside the ProgressBar?
What I've tried ;
Label1.Parent := progressBar1;
Label1Top := progressBar1.Height div 2;
Label1.Left := progressBar1.Width div 2
It shows ugly, and not in center like I want.
If I set Label1.Left := progresBar1.Width div 2 - xxx it will be on center only for certain caption. I want to have any caption be placed on center.
Edited
Answer from #KenWhite is working good.
Solution from #DavidHeffernan just great.
Set the label's AutoSize property to False. Change the Alignment property to taCenter and Layout to tlCenter. Size the label to the progressbar's ClientWidth and ClientHeight, and set its Left to 0.
Label1.Parent := progressBar1;
Label1.AutoSize := False;
Label1.Transparent := True;
Label1.Top := 0;
Label1.Left := 0;
Label1.Width := progressBar1.ClientWidth;
Label1.Height := progressBar1.ClientHeight;
Label1.Alignment := taCenter;
Label1.Layout := tlCenter;
Here's an example of the appearance:
You might decide to derive a progress bar control that paints the text itself rather than relying on a separate label. Some sample code to demonstrate:
type
TProgressBarWithText = class(TProgressBar)
private
FProgressText: string;
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
published
property ProgressText: string read FProgressText write FProgressText;
end;
procedure TProgressBarWithText.WMPaint(var Message: TWMPaint);
var
DC: HDC;
prevfont: HGDIOBJ;
prevbkmode: Integer;
R: TRect;
begin
inherited;
if ProgressText <> '' then
begin
R := ClientRect;
DC := GetWindowDC(Handle);
prevbkmode := SetBkMode(DC, TRANSPARENT);
prevfont := SelectObject(DC, Font.Handle);
DrawText(DC, PChar(ProgressText), Length(ProgressText),
R, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
SelectObject(DC, prevfont);
SetBkMode(DC, prevbkmode);
ReleaseDC(Handle, DC);
end;
end;
The advantage of this approach is that your progress bar and text display are self-contained. There's no need for two separate controls that you have to coordinate.
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
Is it possible to add that arrow pointer thing to a String Grind in Delphi 7? You know what I mean, that arrow pointer that you can see at the left in a DBGrid.
Yes, but not automatically. You would need to display a triangle manually. You can override OnDrawCell for your grid. It seems you need to set the FixedCols to 0 since it doesn't appear to redraw the fixed cells again when the row selection changes.
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
aCanvas: TCanvas;
oldColor: TColor;
triangle: array [0..2] of TPoint;
const
spacing = 4;
begin
if (ACol = 0) and (aRow = StringGrid1.Row) then
begin
aCanvas := (Sender as TStringGrid).Canvas; // To avoid with statement
oldColor := aCanvas.Brush.Color;
// Shape the triangle
triangle[0] := TPoint.Create(Rect.Left + spacing, Rect.Top + spacing);
triangle[1] := TPoint.Create(Rect.Left + spacing, Rect.Top + Rect.Height - spacing);
triangle[2] := TPoint.Create(Rect.Left + Rect.Width - spacing, Rect.Top + Rect.Height div 2);
// Draw the triangle
aCanvas.Pen.Color := clBlack;
aCanvas.Brush.Color := clBlack;
aCanvas.Polygon(triangle);
aCanvas.FloodFill(Rect.Left + Rect.Width div 2, Rect.Top + Rect.Height div 2, clBlack, fsSurface);
aCanvas.Brush.Color := oldColor;
end;
end;
This draws a triangle in the box. You should get the general idea.
Not automatically; it's not part of the standard TStringGrid. The "arrow pointer thing" is called the row indicator, and it's a feature added in TDBGrid. It's declared in TDBGridOptions, specifically dgIndicator, as seen below:
TDBGridOption = (dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator,
dgColumnResize, dgColLines, dgRowLines, dgTabs, dgRowSelect,
dgAlwaysShowSelection, dgConfirmDelete, dgCancelOnExit, dgMultiSelect);
Note that this is different from TGridOption declared in the Grids unit, which does not contain anything similar. (There is no goIndicator or equivalent.)
In order to get the indicator, you'd have to draw it yourself in the OnDrawCell event when you receive a ACol value of 0 with ARow equivalent to the Grid.Row value. There's an example of TStringGrid.OnDrawCell in this answer, although it's demonstrating setting a custom row height and not drawing the row indicator.
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.