Delphi 2010 differs in Canvas transparency compared to Delphi 7? - delphi

I'm porting some very old code from Delph7 to Delphi2010 with a few changes as possible to the existing code base for the usual reasons.
First: the good news for anyone who hasn't jumped yet: it's not as daunting as it may look! I'm actually pleased (& surprised) at how easy 1,000,000+ lines of code have moved across. And what a relief to be back on the leading edge! Delphi 2010 has so many great enhancements.
However, I'm having a cosmetic problem with some TStringGrids and TDbGrids descendants.
In the last century (literally!) someone wrote the two methods below.
The first method is used to justify text. When run in Delphi 2010, the new text and the unjustified text to both appear in the cells written to. Of course it's a mess visually, almost illegible. Sometimes, as a result of the second method is use, the grid cells are actually semi-transparent, with text from the window below showing through. (Again, not pretty!)
It appears to me that Delphi 2010's TDbGrid and TStringGrid have some differences in the way they handle transparency?
I haven't much experience in this area of Delphi (in fact, I have no idea what the 2nd method is actually doing!) and was hoping someone could give me some pointers on what's going on and how to fix it.
TIA!
Method 1
procedure TForm1.gridDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
{Used to align text in cells.}
var
x: integer;
begin
if (Row > 0) AND (Col > 0) then
begin
SetTextAlign(grdTotals.Canvas.Handle, TA_RIGHT);
x := Rect.Right - 2;
end
else
begin
SetTextAlign(grdTotals.Canvas.Handle, TA_CENTER);
x := (Rect.Left + Rect.Right) div 2;
end;
grdTotals.Canvas.TextRect(Rect, x, Rect.Top+2, grdTotals.Cells[Col,Row]);
end;
Method 2
procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text: string;
TitleBreak: TTitleBreak; Alignment: TAlignment);
const
AlignFlags: array [TAlignment] of Integer = (DT_LEFT or
{ DT_WORDBREAK or } DT_EXPANDTABS or DT_NOPREFIX, DT_RIGHT or
{ DT_WORDBREAK or } DT_EXPANDTABS or DT_NOPREFIX, DT_CENTER or
{ DT_WORDBREAK or } DT_EXPANDTABS or DT_NOPREFIX);
var
ABitmap: TBitmap;
AdjustBy: Integer;
B, R: TRect;
WordBreak: Integer;
begin
WordBreak := 0;
if (TitleBreak = tbAlways) or ((TitleBreak = tbDetect) and (Pos(Chr(13) + Chr(10), Text) = 0))
then
WordBreak := DT_WORDBREAK;
ABitmap := TBitmap.Create;
try
ABitmap.Canvas.Lock;
try
AdjustBy := 1;
if (Alignment = taRightJustify) then
Inc(AdjustBy);
with ABitmap, ARect do
begin
Width := Max(Width, Right - Left);
Height := Max(Height, Bottom - Top);
R := Rect(DX, DY, Right - Left - AdjustBy, Bottom - Top - 1); { ### }
B := Rect(0, 0, Right - Left, Bottom - Top);
end;
with ABitmap.Canvas do
begin
Font := ACanvas.Font;
Brush := ACanvas.Brush;
Brush.Style := bsSolid;
FillRect(B);
SetBkMode(Handle, TRANSPARENT);
DrawText(Handle, PChar(Text), Length(Text), R, AlignFlags[Alignment] or WordBreak);
end;
ACanvas.CopyRect(ARect, ABitmap.Canvas, B);
finally
ABitmap.Canvas.Unlock;
end;
finally
ABitmap.Free;
end;
end;

In Method 2, I would try with SetBkMode(Handle, OPAQUE);
Update: and I would put it before FillRect(B)

We always use the DrawText function that gives us control on alignment (vert and hor).
You have to use a FillRect(Rect) before to clean up the content.
I've never used SetBkMode() but my guess is you can go without that.

I'm posting this as an answer (which it's not) so I can include an image.
Thanks for your suggestion. Using OPAQUE helped with initial writing to the TDbGrid. Backgrounds don't bleed through anymore! I'm a bit embarrassed I hadn't spotted the "TRANSPARENT" term before.
However, changes to cells are still failing to erase previous contents, so they look like the screen below. Darn!
The grid contents were moved down one row, but the also remain in the cell above in which they were previously.

Related

Double buffering in delphi not enough

I am trying to build an avionic attitude indicator with Delphi XE2.
I am using tRotateimage for the horizon
http://www.delphiarea.com/products/delphi-components/rotateimage/
This is behind a regular image which has transparent section in the middle.
Being able to rotate the image for roll and move the tRotateimage.top for pitch works well but I am getting a lot of flickering event with double buffered turned on my form. It flickers when I rotate the image or when I move it up via .top
Is there something else I can do to eliminate this flickering?
if tryStrToFloat(GetHashtag('#ROLL',',',Memo1.Lines.Text),MyDouble) then
Begin
rtAttitudeNeedle.Angle := 0- MyDouble;
rtAttitude.Angle :=0- MyDouble;
end;
if tryStrToFloat(GetHashtag('#PITCH',',',Memo1.Lines.Text),MyDouble) then
Begin
rtAttitude.Top := Round(iAttitudeTop + MyDouble);
end;
Double buffering a form is not always the magic trick to solve all your flicker problems.
you need to understand why you are having that flicker in the first place.
if you use the canvas object directly a lot in the paint routine, then you are doing nothing.
Most the time to solve this problem and reduce the flicker, you need to draw on a memory bitmap then at last CopyRect that to your canvas object.
Something like this for your component (Replace the Paint procedure with this code)
procedure TRotateImage.Paint;
var
SavedDC: Integer;
PaintBmp: TBitmap;
begin
PaintBmp := TBitmap.Create;
try
PaintBmp.SetSize(Width, Height);
if not RotatedBitmap.Empty then
begin
if RotatedBitmap.Transparent then
begin
PaintBmp.Canvas.StretchDraw(ImageRect, RotatedBitmap);
end
else
begin
SavedDC := SaveDC(PaintBmp.Canvas.Handle);
try
SelectClipRgn(PaintBmp.Canvas.Handle, ImageRgn);
IntersectClipRect(PaintBmp.Canvas.Handle, 0, 0, Width, Height);
PaintBmp.Canvas.StretchDraw(ImageRect, RotatedBitmap);
finally
RestoreDC(PaintBmp.Canvas.Handle, SavedDC);
end;
end;
end;
if csDesigning in ComponentState then
begin
PaintBmp.Canvas.Pen.Style := psDash;
PaintBmp.Canvas.Brush.Style := bsClear;
PaintBmp.Canvas.Rectangle(0, 0, Width, Height);
end;
Canvas.CopyRect(ClientRect, PaintBmp.Canvas, PaintBmp.Canvas.ClipRect);
finally
PaintBmp.Free;
end;
end;
if this does not solve the problem entirely then you could take a look at this flicker free set of components and try to adapt the rotating code you have on one of his components or inherit from it (I'm not the author and he is the one claiming flicker free functionality).
the FreeEsVclComponents GitHub repository
Edit: after debugging I found a lot of problems with that control, so I decided to go with my recommendation to you.
I created the following control for you
All what I did is that inheriting from TEsImage and doing some changes to the way it work. From the old control I used the routine below to do the rotation transformation.
function CreateRotatedBitmap(Bitmap: TBitmap; const Angle: Extended; bgColor: TColor): TBitmap;
As you can see in the gif above the rotation routine is not perfect. I suggest you look for an alternative.
I also forked the repository of FreeEsVclComponents and added the TAttitudeControl to the Es.Images unit, so you have all what you need to install the control in your system. Click here
At last I tested this on Tokyo and from the readme of the repository it should work on XE2 without problems.
Edit2: I changed the CreateRotatedBitmap with a better one (based on the GDI+), this is the result:
I already pushed the changes to Github so you can git the code from there.
I'm adding the code here as well in case Github goes down (highly unlikely :))
uses
WinApi.Windows, WinApi.GDIPApi, WinApi.GDIPObj, Vcl.Graphics, System.Types;
function RotateImage(Source: TBitmap; Angle: Extended; AllowClip: Boolean): TBitmap;
var
OutHeight, OutWidth: Integer;
Graphics: TGPGraphics;
GdiPBitmap: TGPBitmap;
begin
if AllowClip then
begin
OutHeight := Source.Height;
OutWidth := Source.Width;
end
else
begin
if (Source.Height > Source.Width) then
begin
OutHeight := Source.Height + 5;
OutWidth := Source.Height + 5;
end
else
begin
OutHeight := Source.Width + 5;
OutWidth := Source.Width + 5;
end;
end;
Result := TBitmap.Create;
Result.SetSize(OutWidth, OutHeight);
GdiPBitmap := nil;
Graphics := TGPGraphics.Create(Result.Canvas.Handle);
try
Graphics.SetSmoothingMode(SmoothingModeDefault);
Graphics.SetPixelOffsetMode(PixelOffsetModeHalf);
Graphics.SetInterpolationMode(InterpolationModeLowQuality);
Graphics.TranslateTransform(OutWidth / 2, OutHeight / 2);
Graphics.RotateTransform(Angle);
Graphics.TranslateTransform(-OutWidth / 2, -OutHeight / 2);
GdiPBitmap := TGPBitmap.Create(Source.Handle, Source.Palette);
try
Graphics.DrawImage(GdiPBitmap, 0, 0);
finally
GdiPBitmap.Free;
end;
finally
Graphics.Free;
end;
end;

Graphics32 layers performance issues

I developed an application in Delphi using graphics32 library. It involves adding layers to a ImgView32 control. It does all I want now, except that when the user adds more that 25-30 layers to the ImgView, the selected layer starts behaving badly. I mean,
- when there are 30+ layers on the ImgView32 and I click on a layer, it takes about 2.5-2 seconds to actually select it.
- Also when I try to move the layer, it moves abruptly
It appears that ImgViewChange is called way too many times when there are more layers. Same goes to PaintLayer. It gets called way too many times.
How can I stop that from happening? How can I make the layers move graciously even when there are more that 30 layers added?
My code is as follows:
procedure TMainForm.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
cronstart:=now;
if Sender <> nil then
begin
Selection := TPositionedLayer(Sender);
end
else
begin
end;
cronstop:=now;
Memo1.Lines.Add('LayerMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.AddSpecialLineLayer(tip:string);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,100);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
B.OnPaint := PaintGeamOrizHandler
except
Free;
raise;
end;
Selection := B;
end;
procedure TMainForm.PaintGeamOrizHandler(Sender: TObject;Buffer: TBitmap32);
var
bmp32:TBitmap32;
R:TRect;
usa2:single;
latime,inaltime,usa:Single;
inaltime2, latime2:single;
begin
cronstart:=now;
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
bmp32:=TBitmap32.Create;
try
R := MakeRect(TBitmapLayer(Sender).GetAdjustedLocation);
bmp32.DrawMode:=dmblend;
bmp32.SetSize(Round(Right-Left), Round(Bottom-Top));
latime:=Round((Right-Left));
inaltime:=Round((Bottom-Top));
usa:=60;
usa2:=usa / 2;
with TLine32.Create do
try
EndStyle := esClosed;
JoinStyle := jsMitered;
inaltime2:=inaltime / 2;
latime2:=latime / 2;
SetPoints([FixedPoint(latime2-usa2,inaltime2), FixedPoint(latime2+usa2,inaltime2)]);
Draw(bmp32, 13, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
SetPoints([FixedPoint(latime2-usa2-3,inaltime2), FixedPoint(latime2-usa2,inaltime2)]);
Draw(bmp32, 5, clBlack32);
SetPoints([FixedPoint(latime2-usa2-3-7,inaltime2), FixedPoint(latime2-usa2-3,inaltime2)]);
Draw(bmp32, 7, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
SetPoints([FixedPoint(latime2+usa2,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
Draw(bmp32, 5, clBlack32);
SetPoints([FixedPoint(latime2+usa2+3+7,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
Draw(bmp32, 7, clWhite32);
SetPoints(GetOuterEdge);
Draw(bmp32, 1.5, clBlack32);
finally
Free;
end;
(Sender as TBitmapLayer).Bitmap.Assign(bmp32);
finally
bmp32.Free;
end;
end;
cronstop:=now;
Memo1.Lines.Add('PaintLayer:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.SetSelection(Value: TPositionedLayer);
begin
if Value<>nil then
begin
if Value <> FSelection then
begin
if RBLayer <> nil then
begin
RBLayer.ChildLayer := nil;
RBLayer.LayerOptions := LOB_NO_UPDATE;
end;
FSelection := Value;
if Value <> nil then
begin
if RBLayer = nil then
begin
RBLayer := TRubberBandLayer.Create(ImgView.Layers);
RBLayer.MinHeight := 1;
RBLayer.MinWidth := 1;
end
else
RBLayer.BringToFront;
RBLayer.ChildLayer := Value;
RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
RBLayer.OnResizing := RBResizing;
end;
end;
end;
end;
procedure TMainForm.RBResizing(Sender: TObject;
const OldLocation: TFloatRect; var NewLocation: TFloatRect;
DragState: TRBDragState; Shift: TShiftState);
var
w, h, cx, cy: Single;
nw, nh: Single;
begin
cronstart:=now;
if DragState = dsMove then Exit; // we are interested only in scale operations
if Shift = [] then Exit; // special processing is not required
if ssCtrl in Shift then
begin
{ make changes symmetrical }
with OldLocation do
begin
cx := (Left + Right) / 2;
cy := (Top + Bottom) / 2;
w := Right - Left;
h := Bottom - Top;
end;
with NewLocation do
begin
nw := w / 2;
nh := h / 2;
case DragState of
dsSizeL: nw := cx - Left;
dsSizeT: nh := cy - Top;
dsSizeR: nw := Right - cx;
dsSizeB: nh := Bottom - cy;
dsSizeTL: begin nw := cx - Left; nh := cy - Top; end;
dsSizeTR: begin nw := Right - cx; nh := cy - Top; end;
dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end;
dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end;
end;
if nw < 2 then nw := 2;
if nh < 2 then nh := 2;
Left := cx - nw;
Right := cx + nw;
Top := cy - nh;
Bottom := cy + nh;
end;
end;
cronstop:=now;
Memo1.Lines.Add('RBResizing:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewChange(Sender: TObject);
var
wid,hei:Integer;
begin
Edit1.Text:=IntToStr(StrToInt(Edit1.Text)+1);
cronstart:=now;
if Selection = nil then
begin
end
else
begin
wid:=Round(Selection.Location.Right-Selection.Location.Left);
hei:=Round(Selection.Location.Bottom-Selection.Location.Top);
// SelectLayerPan(Selection.Index);
end;
cronstop:=now;
Memo1.Lines.Add('ImgViewChange:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
Edit1.Text:='0';
cronstart:=now;
if Layer = nil then
begin
if Assigned(FSelection) then
begin
Selection := nil;
RBLayer.Visible:=false;
end;
end
else
begin
// SelectLayerPan(layer.Index);
end;
cronstop:=now;
Memo1.Lines.Add('imgViewMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;
procedure TMainForm.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
const //0..1
Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
R: TRect;
I, J: Integer;
OddY: Integer;
TilesHorz, TilesVert: Integer;
TileX, TileY: Integer;
TileHeight, TileWidth: Integer;
begin
TileHeight := 13;
TileWidth := 13;
TilesHorz := Buffer.Width div TileWidth;
TilesVert := Buffer.Height div TileHeight;
TileY := 0;
for J := 0 to TilesVert do
begin
TileX := 0;
OddY := J and $1;
for I := 0 to TilesHorz do
begin
R.Left := TileX;
R.Top := TileY;
R.Right := TileX + TileWidth;
R.Bottom := TileY + TileHeight;
Buffer.FillRectS(R, Colors[I and $1 = OddY]);
Inc(TileX, TileWidth);
end;
Inc(TileY, TileHeight);
end;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
Edit1.Text:='0';
MainForm.AddSpecialLineLayer('geams'); //orizontal
end;
So just click the button multiple times (30 times) and you will notice the eratic behaviour once you get to have 25-30 layers added.
(Of course use the base code from the layers example of the library and add the above procedures)
Maybe a solution would be to disable somewhere the ImgViewChange event from firing. But I do not know where to do that... Or maybe I'm wrong.
Please give me a solution for this problem... because I can't think of anything...
EDIT
Here is a screenshot that will explain better:
As you can see in the right side of the imgView, there are 3 editboxes. The first tells us that there are 25 layers added already. The other two are also self-explanatory.
In the left side of the picture you can see the layers drawn there. They are all the same, drawn with the paintHandler from the code. So all the layers are identical
Now consider this scenario: no layer is selected, then I start clicking layers, the first 3 clicks, show me ImgViewChange=52 and Paint=26, for each of them. Then on my fourth click on a layer the values are those in the image displayed here. This does not make any sense.
So ImgViewChanged is called 1952 times and the PaintHandler is called 976 times. There must be a bug somewhere...
Please help me figure this out. take into consideration that those editboxes get filled in the code above. Also in this test project there is no other code that might do this crazy behavior. I wrote this test project with only the code that was neccessary to make it work. So the code is above, the behavior is in the picture.
EDIT
After I added bmp32.BeginUpdate and bmp32.EndUpdate in the PaintHandler method, the number of repaints and imgViewChanges seem to have decreased, but not by much. Now I get ImgViewChange=1552 and PaintHandler=776.
I'm not even sure that it's because my change, because these numbers seem almost random. I mean I have no idea why it happens, who triggers those events for regular number of times, and what happens when they are triggered so many more times?
When I add the layers to the imgView, all 25 of them, I leave them where they are added: in the center of the View. After they are all added, I start click-in on each and I drag them away from the center so they would all be visible.
Now, the first 15-20 layers that I click on and drag from the center, the 2 numbers that I monitor (number of times those two events get fired) is a lot lower that the numbers I get after the 20th layer that I want to drag from the center. And after they are all dispersed in the view, it begins: some layers are click-able in real-time, others take a while to get selected and my count of event-fires are through the roof.
EDIT
I found my problem.
With this I reduced the number of events that get fired to the normal amount. So the solution was to add BeginUpdate and EndUpdate for the Assignment of the layer's bitmap...
So in the PaintHandler I changed the code to:
(Sender as TBitmapLayer).BeginUpdate;
(Sender as TBitmapLayer).Bitmap.Assign(bmp32);
(Sender as TBitmapLayer).EndUpdate;
And now my layers behave like they should. Thank you SilverWarrior for pointing me into the right direction. Please convert your comment into an answer so I can accept it.
The BeginUpdate/EndUpdate are beneficial to reduce the number of ImgViewChange events as documented here
OnChange is an abstract change notification event, which is called by
some of the descendants of TCustomPaintBox32 immediately after changes
have been made to their contents. In TCustomImage32, for example, this
includes redirection of change notification events from the contained
bitmap and from layers. This event, however, is not called by
TCustomPaintBox32 control itself, unless you call the Changed method
explicitly. Change notification may be disabled with BeginUpdate call
and re-enabled with EndUpdate call.
However, there are other problems in your code:
In AddSpecialLineLayer() you create a new TBitmapLayer, set the size and location of its Bitmap and set its OnPaint handler to PaintGeamOrizHandler(). This is not a problem in itself, but it's the first step towards the real problem.
In PaintGeamOrizHandler() the main idea seems to be to draw some shapes, but the way it is done is very time consuming for no benefit.
First you create a new TBitmap32. Then you draw the shapes on this bitmap. Then you assign it to the layers bitmap. Finally you free the bitmap just created.
All of the shape drawing could instead have been done directly to the layers bitmap. The "temporary" bitmap is just a waist of CPU resources.
But another question is, why are the shapes drawn every time the layer needs to be painted? The bitmap of the TBitmapLayer is perfectly capable of retaining the shapes until you specifically need to change them. Instead you could have drawn the shapes in a separate procedure as a one time effort when you created the layer (and/or when you need to change the shapes).
You may also want to explore the documentation for paint stages and perhaps repaint optimizer

Stop TCustomHint from centering itself around my point

I'm trying to use TCustomHint to show a message to my user that fades in and out nicely, to not be too distracting. However when I call ShowHint on my object with a point, the hint box appears to center itself around the point I give. What I would like is to have my box appear such that its top-left coordinate is the point given.
Here's the code I'm using so show the hint:
procedure ShowNotification(ATitle: UnicodeString; AMsg: UnicodeString);
var
Box: TCustomHint;
P: TPoint;
begin
Box := TCustomHint.Create(MyForm);
Box.Title := ATitle;
Box.Description := AMsg;
Box.Delay := 0;
Box.HideAfter := 5000;
Box.Style := bhsStandard;
P.X := 0;
P.Y := 0;
Box.ShowHint(P);
end;
I know that my point's X/Y coordinates are not relative to the form, and that's not the issue.
I've traced through what happens when I call ShowHint and it appears that if I can somehow control the final width of the underlying TCustomHintWindow inside of TCustomHint.ShowHint(Rect: TRect) then I may be in business.
So my question is: is there an obvious way to stop a TCustomHint from centering itself at my point? Or will I have to go through the process of inheriting, overriding the draw method, etc etc? I hope I'm just missing something simple.
There's no particularly easy way to do what you want. The TCustomHint class is designed to serve a very specific purpose. It was designed to be used by the TControl.CustomHint property. You can see how it is called by looking at the code for TCustomHint.ShowHint. The pertinent excerpts are:
if Control.CustomHint = Self then
begin
....
GetCursorPos(Pos);
end
else
Pos := Control.ClientToScreen(Point(Control.Width div 2, Control.Height));
ShowHint(Pos);
So, either the control is shown centred horizontally around the current cursor position, or centred horizontally around the middle of the associated control.
I think the bottom line here is that TCustomHint is not designed to be used the way you are using it.
Anyway, there is a rather gruesome way to make your code do what you want. You can create a temporary TCustomHintWindow that you never show and use it to work out the width of the hint window that you want to show. And then use that to shift the point that you pass to the real hint window. In order to make it fly you need to crack the private members of TCustomHintWindow.
type
TCustomHintWindowCracker = class helper for TCustomHintWindow
private
procedure SetTitleDescription(const Title, Description: string);
end;
procedure TCustomHintWindowCracker.SetTitleDescription(const Title, Description: string);
begin
Self.FTitle := Title;
Self.FDescription := Description;
end;
procedure ShowNotification(ATitle: UnicodeString; AMsg: UnicodeString);
var
Box: TCustomHint;
SizingWindow: TCustomHintWindow;
P: TPoint;
begin
Box := TCustomHint.Create(Form5);
Box.Title := ATitle;
Box.Description := AMsg;
Box.Delay := 0;
Box.HideAfter := 5000;
Box.Style := bhsStandard;
P := Point(0, 0);
SizingWindow := TCustomHintWindow.Create(nil);
try
SizingWindow.HintParent := Box;
SizingWindow.HandleNeeded;
SizingWindow.SetTitleDescription(ATitle, AMsg);
SizingWindow.AutoSize;
inc(P.X, SizingWindow.Width div 2);
finally
SizingWindow.Free;
end;
Box.ShowHint(P);
end;
This does what you asked, but honestly, it makes me feel rather queasy.

Fill custom area with color

How can I fill a selected area with color?
var Rect: TRect;
Color: TColor;
begin
//fill area with color
end;
You have not stated what you mean by custom area and you talk about a "selected area". I don't know what you mean.
For a simple rectangle then you typically would fill the rectangle with TCanvas.FillRect.
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
Canvas.FillRect(R);
where R is a TRect specifying the rectangle.
For a more complex region then you need to fall back on the Windows GDI function FillRgn. This function is not wrapped by TCanvas but you can simply call it passing TCanvas.Handle as the HDC.
You need to be a LOT more specific, but this should get you going in the right direction:
procedure DoMyDrawing(Canvas: TCanvas; L, T, R, B: Integer; Color: TColor);
var
Rec: TRect;
begin
Rec.Left:= L;
Rec.Top:= T;
Rec.Right:= R;
Rec.Bottom:= B;
//SAME AS Rec:= Rect(L, T, R, B);
Canvas.Brush.Color:= Color;
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Style:= psClear;
Canvas.FillRect(Rec);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DoMyDrawing(Self.Canvas, 10, 10, 50, 50, clNavy);
end;
EDIT:
I would more-so recommend using a TRect instead of the 4 coordinates (Left, Top, Right, and Bottom) because a TRect includes all 4 of those already. You can also read a TRect with a TopLeft TPoint and a BottomRight TPoint.
(I also fixed a typo above - Canvas.FillRect(R); was supposed to be Canvas.FillRect(Rec);)
Here's another version of the same procedure:
procedure DoMyDrawing(Canvas: TCanvas; const R: TRect; const Color: TColor);
begin
Canvas.Brush.Color:= Color;
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Style:= psClear;
Canvas.FillRect(R);
end;
Much easier, isn't it?
ANOTHER EDIT:
Also note the function I'm using Rect(Left, Top, Right, Bottom) - This makes things simple too. Unfortunately I've seen some standard VCL controls which have events with parameters named Rect: TRect; which messes up the ability to use the original function in the classes unit. So also avoid using a variable with the name Rect because it will prevent you from being able to use the Rect function (which turns 4 lines of code into just 1).

Painting TRichEdit to a canvas

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;

Resources