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).
Related
I have a procedure which takes a screenshot of a monitor and optionally includes the mouse cursor in the snapshot. The original function was only for one monitor. When drawing the mouse cursor, it currently shows properly only on the Main Monitor. But, I can't figure out how to position it on any other monitor. See the comments towards the end of this procedure.
procedure ScreenShot(var Bitmap: TBitmap; const MonitorNum: Integer;
const DrawCursor: Boolean; const Quality: TPixelFormat);
var
DC: HDC;
C: TCanvas;
R: TRect;
CursorInfo: TCursorInfo;
Icon: TIcon;
IconInfo: TIconInfo;
M: TMonitor;
CP: TPoint;
begin
M:= Screen.Monitors[MonitorNum];
DC:= GetDC(GetDesktopWindow);
try
C:= TCanvas.Create;
try
C.Handle:= DC;
R:= M.BoundsRect;
Bitmap.Width:= R.Width;
Bitmap.Height:= R.Height;
Bitmap.PixelFormat:= Quality;
Bitmap.Canvas.CopyRect(Rect(0,0,R.Width,R.Height), C, R);
finally
C.Free;
end;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
if DrawCursor then begin
R:= Bitmap.Canvas.ClipRect;
Icon:= TIcon.Create;
try
CursorInfo.cbSize:= SizeOf(CursorInfo);
if GetCursorInfo(CursorInfo) then
if CursorInfo.Flags = CURSOR_SHOWING then
begin
Icon.Handle:= CopyIcon(CursorInfo.hCursor);
if GetIconInfo(Icon.Handle, IconInfo) then
begin
CP:= CursorInfo.ptScreenPos;
//Transition mouse position...?
CP.X:= CP.X + M.Left;
CP.Y:= CP.Y + M.Top; //No difference?
Bitmap.Canvas.Draw(
CP.X - Integer(IconInfo.xHotspot) - R.Left,
CP.Y - Integer(IconInfo.yHotspot) - R.Top,
Icon);
end;
end;
finally
Icon.Free;
end;
end;
end;
How do I transition the mouse position properly depending on which monitor I'm using?
You are mapping screen coord MonitorRect.Left to bitmap coord 0. And likewise, MonitorRect.Top to 0. So, if the cursor's screen position is CursorPos then you map that to CursorPos.X - MonitorRect.Left and CursorPos.Y - MonitorRect.Top. And then you also need to account for the hot spot, but you already seem to know how to do that.
The mapping above applies equally to all monitors.
Note that I used my own notation because I found your single letter variables mis-leading. Not to mention that fact that the meaning of these variables changes during the function. I'm look at you, R. That's always a recipe for pain.
Also, don't you need to delete the bitmap handles that are handed to you when you call GetIconInfo? And some error checking wouldn't go amiss.
Using: Delphi XE2, VCL 32-bit application, Windows 8
I'm trying to paint the background of my frame onto a panel (I'm using TJvPanel, because it exposes the OnPaint event) which is a child control of the frame.
After reading this post and adding a canvas as a field, I am still not successful.
After calling ShowAddReceiptPanel, it should draw the frame's (TfrmMyFrame) window contents with all the controls already on it (which include a grid and a pagecontrol) on the foreground panel, grayscaled, after being processed by the ProEffectImage method, but instead it shows an opaque white background. Am I missing something?
Here's my code:
type
TfrmMyFrame = class(TFrame)
pnlHdr: TPanel;
pnlAddNewBG: TJvPanel;
procedure pnlAddNewBGPaint(Sender: TObject);
private
{ Private declarations }
FBGImg: TProEffectImage;
Fcnvs: TCanvas;
procedure PaintWindow(DC: HDC); override;
procedure ShowAddReceiptPanel;
procedure HideAddReceiptPanel;
procedure ResizePanel_pnlAddNewBG;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
constructor TfrmMyFrame.Create(AOwner: TComponent);
begin
inherited;
FBGImg := TProEffectImage.Create(nil);
Fcnvs := TCanvas.Create;
end;
destructor TfrmMyFrame.Destroy;
begin
if Assigned(FBGImg) then
FBGImg.Free;
if Assigned(Fcnvs) then
Fcnvs.Free;
inherited;
end;
procedure TfrmMyFrame.ShowAddReceiptPanel;
begin
ResizePanel_pnlAddNewBG;
pnlAddNewBG.Visible := True;
end;
procedure TfrmMyFrame.PaintWindow(DC: HDC);
begin
inherited;
Fcnvs.Handle := DC;
end;
procedure TfrmMyFrame.pnlAddNewBGPaint(Sender: TObject);
var
l, t, w, h: Integer;
srct, drct: TRect;
begin
// Copy Frame canvas to BGImg bitmap
l := 0;
t := pnlHdr.Height;
w := ClientWidth;
h := ClientHeight - t;
srct := TRect.Create(l, t, w, h);
FBGImg.Width := w;
FBGImg.Height := h;
drct := TRect.Create(l, t, w, h);
FBGImg.Canvas.CopyMode := cmSrcCopy;
FBGImg.Canvas.CopyRect(drct, Fcnvs, srct);
// FBGImg.Picture.SaveToFile('c:\tmp\a.bmp');
FBGImg.Effect_AntiAlias;
FBGImg.Effect_GrayScale;
// Draw BGImg onto Option panel
TJvPanel(Sender).Canvas.CopyMode := cmSrcCopy;
TJvPanel(Sender).Canvas.Draw(0, 0, FBGImg.Picture.Graphic);
end;
procedure TfrmMyFrame.ResizePanel_pnlAddNewBG;
var
x1, y1, x2, y2: Integer;
bmp: TBitmap;
begin
x1 := 0;
y1 := pnlHdr.Height;
x2 := ClientWidth;
y2 := ClientHeight - y1;
pnlAddNewBG.SetBounds(x1, y1, x2, y2);
end;
The DC that you assign to your canvas handle is only valid during the PaintWindow call. You use it outside that function when it is not valid and hence the behaviour that you observe.
I think that you should be able to solve your problem by calling the PaintTo method. Create a bitmap of the right size and pass its canvas to PaintTo.
A TFrame does not have a canvas. You could create/add one, as TCustomControl does, but you do not have to. A canvas is just a handy wrapper around a Windows device context. The PaintWindow routine is called whenever the frame has to be (partially) redrawn. The parameter exhibits the DC, or you could obtain one with GetDC.
Then pseudo-code would be as follows:
procedure TfrmMyFrame.PaintWindow(DC: HDC);
begin
- Resize BG image and hide it (otherwise image itself will be copied too)
- Paint the frame's contents to the image with:
Self.PaintTo(FBGImg.Canvas.Handle, 0, 0)
- Process the special effects on FBGImg
- Paint the image onto DC with:
BitBlt(DC, 0, 0, ClientWidth, ClientHeight, FBGImage.Canvas.Handle, 0, 0, SRCCOPY);
end;
An easy way to get access to a Canvas on a TFrame is to add a TPaintBox on top of it with Align := alClient and using its Canvas property.
I expect this method to work with any version of Delphi, also in the future, and therefore use it instead of the PaintWindow method, which seems to be tricky.
If I wanted to move / shift the pixels of a bitmap how could I do so?
procedure MovePixels(Bitmap: TBitmap; Horizontal, Vertical: Integer);
begin
{ move the Bitmap pixels to new position }
end;
Example:
By calling MovePixels(Image1.Picture.Bitmap, 20, 20) for example would output like so:
It would be useful to also specify / change the color of the canvas that is left showing after moving the pixels. So in this example that gray / brown color could be blue etc.
I noticed there is Bitmap.Canvas.Pixels and Bitmap.Canvas.MoveTo properties, is this what I would need to do this?
I really don't know and I bet it is so simple..
You can't easily move pixels, but you can make a copy.
var
Source, Dest: TRect;
....
Source := Rect(0, 0, Bitmap.Width, Bitmap.Height);
Dest := Source;
Dest.Offset(X, Y);
Bitmap.Canvas.CopyRect(Dest, Bitmap.Canvas, Source);
What remains is to fill in the space with the colour of your choice which I am sure you can do easily enough with a couple of calls to FillRect.
However, I think that it would be simpler not to attempt this in-place. Instead I would create a new bitmap. Perhaps like this:
function CreateMovedImage(Bitmap: TBitmap; X, Y: Integer; BackColor: TColor): TBitmap;
var
Source, Dest: TRect;
begin
Source := Rect(0, 0, Bitmap.Width, Bitmap.Height);
Dest := Source;
Dest.Offset(X, Y);
Result := TBitmap.Create;
Try
Result.SetSize(Bitmap.Width, Bitmap.Height);
Result.Canvas.Brush.Style := bsSolid;
Result.Canvas.Brush.Color := BackColor;
Result.Canvas.FillRect(Source);
Result.Canvas.CopyRect(Dest, Bitmap.Canvas, Source);
Except
Result.Free;
raise;
End;
end;
In Delphi i wish to draw text inside a TRect. I am hoping for the following functionality:
Draw the text centred vertically within the TRect
Draw the text centred horizontally within the TRect
If there is space for more than 1 line of text (using TRect's height), draw the text multiline
If the text does not fit in the TRect (either on a single or mult line) then append ellipsis to the text.
I can see the Windows.DrawText() function almost covers this functionality, however when writing text, multiline and vertically centred are mutually exclusive.
I was wondering if this functionality is built into windows (2000+)? If not is there a way to do this without writing my own function?
Sorry, this is a combination of all previous answers and comments. But it seems OP needs more assistance.
function DrawTextCentered(Canvas: TCanvas; const R: TRect; S: String): Integer;
var
DrawRect: TRect;
DrawFlags: Cardinal;
DrawParams: TDrawTextParams;
begin
DrawRect := R;
DrawFlags := DT_END_ELLIPSIS or DT_NOPREFIX or DT_WORDBREAK or
DT_EDITCONTROL or DT_CENTER;
DrawText(Canvas.Handle, PChar(S), -1, DrawRect, DrawFlags or DT_CALCRECT);
DrawRect.Right := R.Right;
if DrawRect.Bottom < R.Bottom then
OffsetRect(DrawRect, 0, (R.Bottom - DrawRect.Bottom) div 2)
else
DrawRect.Bottom := R.Bottom;
ZeroMemory(#DrawParams, SizeOf(DrawParams));
DrawParams.cbSize := SizeOf(DrawParams);
DrawTextEx(Canvas.Handle, PChar(S), -1, DrawRect, DrawFlags, #DrawParams);
Result := DrawParams.uiLengthDrawn;
end;
procedure TForm1.FormPaint(Sender: TObject);
const
S = 'This is a very long text as test case for my paint routine.';
var
R: TRect;
begin
SetRect(R, 100, 100, 200, 140);
Canvas.Rectangle(R);
InflateRect(R, -1, -1);
Caption := Format('%d characters drawn', [DrawTextCentered(Canvas, R, S)]);
end;
Measure the text first using DT_CALCRECT. Pass DT_WORDBREAK to specify that word wrapping is enabled. This will allow you to find the required height for your text. Then you can, in your code, calculate the vertical offset that gives you vertically centred text, and draw to that offset.
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.