This question already has answers here:
How to capture the screen and mouse pointer using Windows APIs?
(2 answers)
How can I capture screen under my own window excluding my own window
(4 answers)
How do I capture desktop screenshot behind full screen form?
(1 answer)
Screenshot behind a full screen Form results in a black screen
(1 answer)
Closed 1 year ago.
I'm modifying an open-source Delphi magnifier application to meet my needs. It's very simple and only contains a TImage control to show the zoomed screen.
When I run it, it looks like this:
Basically, when the user moves the cursor, the app copies the corresponding rectangle and draws it on the TImage to give a zooming effect.
However, the problems are:
It doesn't show the zoomed cursor (Windows Magnifier does that)
It can't get the screen portion underneath the Main Form (Windows Magnifier does that).
How can I implement these two features? I have no clues right now.
My final goal is to make it run in full screen and still zoom, just like Windows Magnifier does.
Below is the code I have.
UNIT uZoom;
INTERFACE
USES
ShellApi, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls, ExtCtrls, Buttons, System.Actions, Vcl.ActnList;
TYPE
TMainForm = CLASS(TForm)
img: TImage;
timer: TTimer;
ActionList1: TActionList;
inc_factor: TAction;
dec_factor: TAction;
PROCEDURE FormResize(Sender: TObject);
PROCEDURE FormDestroy(Sender: TObject);
PROCEDURE timerTimer(Sender: TObject);
PROCEDURE inc_factorExecute(Sender: TObject);
PROCEDURE FormCreate(Sender: TObject);
PROCEDURE dec_factorExecute(Sender: TObject);
PRIVATE
PUBLIC
END;
VAR
MainForm: TMainForm;
VAR
factor: integer;
IMPLEMENTATION
{$R *.DFM}
PROCEDURE TMainForm.FormResize(Sender: TObject);
BEGIN
img.Picture := NIL;
END;
PROCEDURE TMainForm.inc_factorExecute(Sender: TObject);
BEGIN
factor := factor + 1;
OutputDebugString(PChar(inttostr(factor)));
Invalidate;
END;
PROCEDURE TMainForm.dec_factorExecute(Sender: TObject);
BEGIN
factor := factor - 1;
IF factor = 0 THEN
factor := 1;
OutputDebugString(PChar(inttostr(factor)));
Invalidate;
END;
PROCEDURE TMainForm.FormCreate(Sender: TObject);
BEGIN
factor := 1;
OutputDebugString(PChar(inttostr(factor)));
Invalidate;
END;
PROCEDURE TMainForm.FormDestroy(Sender: TObject);
BEGIN
timer.Interval := 0;
END;
PROCEDURE TMainForm.timerTimer(Sender: TObject);
VAR
srcRect, destRect, fmrRect: TRect;
iWidth, iHeight, DmX, DmY: integer;
C: TCanvas;
curPos: TPoint;
BEGIN
// Determines whether the specified window is minimized (iconic).
IF IsIconic(Application.Handle) THEN
exit;
// Retrieves a handle to the desktop window. The desktop window covers the entire screen.
// The desktop window is the area on top of which other windows are painted.
VAR
hDesktop: Hwnd := GetDesktopWindow;
// Retrieves the position of the mouse cursor, in screen coordinates.
GetCursorPos(curPos);
fmrRect := Rect(MainForm.Left, MainForm.Top, MainForm.Left + MainForm.Width, MainForm.Top + MainForm.Height);
// The PtInRect function determines whether the specified point lies within the specified rectangle.
// A point is within a rectangle if it lies on the left or top side or is within all four sides.
// A point on the right or bottom side is considered outside the rectangle.
IF NOT PtInRect(fmrRect, curPos) THEN
BEGIN
img.Visible := True;
iWidth := img.Width;
iHeight := img.Height;
destRect := Rect(0, 0, iWidth, iHeight);
VAR dx: real := iWidth / (factor * 4);
VAR dy: real := iHeight / (factor * 4);
srcRect := Rect(curPos.x, curPos.y, curPos.x, curPos.y);
InflateRect(srcRect, Round(dx), Round(dy));
IF srcRect.Left < 0 THEN
OffsetRect(srcRect, -srcRect.Left, 0);
IF srcRect.Top < 0 THEN
OffsetRect(srcRect, 0, -srcRect.Top);
IF srcRect.Right > Screen.DesktopWidth THEN
OffsetRect(srcRect, -(srcRect.Right - Screen.DesktopWidth), 0);
IF srcRect.Bottom > Screen.DesktopHeight THEN
OffsetRect(srcRect, 0, -(srcRect.Bottom - Screen.DesktopHeight));
C := TCanvas.Create;
TRY
C.Handle := GetDC(GetDesktopWindow);
img.Canvas.CopyRect(destRect, C, srcRect);
FINALLY
ReleaseDC(hDesktop, C.Handle);
C.Free;
END;
END;
END;
END.
Related
I Have a Windows Media Player ActiveX control. I want it to be aligned to its parent TPanel.
The problem is that no matter what I try the WMP control is always set to its initial size without the possibility to resize it.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XpMan, ExtCtrls, WMPLib_TLB;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
Panel: TPanel;
MP: TWindowsMediaPlayer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 450;
Height := 260;
Panel := TPanel.Create(Self);
Panel.Parent := Self;
Panel.Align := alClient;
MP := TWindowsMediaPlayer.Create(Self);
// MP.stretchToFit := True;
MP.Parent := Panel;
MP.Align := alClient;
MP.URL := 'https://www.w3schools.com/html/mov_bbb.mp4';
end;
When you open the form the WMP control looks fine:
But when you resize the form, the WMP control wont align to the parent Panel:
This is actually the effect I see when trying to enlarge:
What can I do to make the WMP control behave as expected?
I have tried many stupid things like:
procedure TForm1.FormResize(Sender: TObject);
begin
if not Assigned(MP) then Exit;
MP.Width := Panel.ClientWidth;
MP.Height := Panel.ClientHeight;
Panel.Realign;
end;
But nothing works!
This is a bug in Delphi 7 TOleControl.SetBounds in OleCtrls. it was fixed in newer versions.
procedure TOleControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
LRect: TRect;
begin
if ((AWidth <> Width) and (Width > 0)) or ((AHeight <> Height) and (Height > 0)) then
begin
if (FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) or
((FOleObject.SetExtent(DVASPECT_CONTENT, Point(
MulDiv(AWidth, 2540, Screen.PixelsPerInch),
MulDiv(AHeight, 2540, Screen.PixelsPerInch))) <> S_OK)) then
begin
AWidth := Width;
AHeight := Height;
end;
{ fix start }
if FOleInplaceObject <> nil then
begin
LRect := Rect(Left, Top, AWidth, AHeight);
FOleInplaceObject.SetObjectRects(LRect, LRect);
end;
{ fix end }
end;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
After applying that to a local copy of OleCtrls everything works fine.
Is there a Delphi function to enable or disable mouse clicks for a stringgrid?
I'm using a derivation of stringgrid called Tadvstringgrid which allows coloring cells based on contens
I need to prevent mouse clicks inside a stringgrid while populating control with data from various threads.
Only disabling the control is not enough. If I click in random cells, the info gets screwed up meaning that some strings are placed in the last cell I've clicked.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, StdCtrls;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TThread_populate_stringgrid = class(TThread)
strict private
f_stringgrid_to_populate:Tstringgrid;
f_name:string;
protected
procedure Execute; override;
public
constructor Create(a_name:string;a_stringgrid_to_populate:Tstringgrid);
end;
constructor TThread_populate_stringgrid.Create(a_name:string;a_stringgrid_to_populate:Tstringgrid);
begin
inherited Create(False);
freeonterminate:=true;
priority:=tpNormal ;
f_name:=a_name;
f_stringgrid_to_populate:=a_stringgrid_to_populate;
end;
procedure TThread_populate_stringgrid.Execute;
begin
Synchronize(
procedure
begin
f_stringgrid_to_populate.cells[0,0]:='DATE';
f_stringgrid_to_populate.cells[1,0]:='NAME';
f_stringgrid_to_populate.cells[2,0]:='ADRESS';
f_stringgrid_to_populate.cells[3,0]:='CITY';
f_stringgrid_to_populate.cells[4,0]:='COUNTRY';
f_stringgrid_to_populate.Cols[0].Add(FormatDatetime('dd-mm-yyyy hh:mm:ss', Now));
f_stringgrid_to_populate.Cols[1].Add(f_name);
f_stringgrid_to_populate.Cols[2].Add('58 RED ROAD');
f_stringgrid_to_populate.Cols[3].Add('ENGLAND');
f_stringgrid_to_populate.Cols[3].Add('UK');
end
)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TThread_populate_stringgrid.Create('Andrei',form1.StringGrid1);
TThread_populate_stringgrid.Create('Matei',form1.StringGrid1);
TThread_populate_stringgrid.Create('Iulia',form1.StringGrid1);
TThread_populate_stringgrid.Create('Petru',form1.StringGrid1);
TThread_populate_stringgrid.Create('Gheorghe',form1.StringGrid1);
TThread_populate_stringgrid.Create('Tudor',form1.StringGrid1);
TThread_populate_stringgrid.Create('Cineva',form1.StringGrid1);
TThread_populate_stringgrid.Create('Altcine',form1.StringGrid1);
end;
end.
Thank you!
Here is the solution that works for me:
-In the main form place a "ApplicationEvents" component.
-Go to the Events section of the ApplicationEvents
-double click on "Onmessage" property and add the following procedure
procedure TForm1.deactivate_mouse_in_advstringgrid(var Msg: tagMSG;
var Handled: Boolean);
var
pnt: TPoint;
ctrl: TWinControl;
begin
if (
(Msg.message = SB_VERT) OR
(Msg.message = SB_HORZ) OR
(Msg.message = WS_HSCROLL) OR
(Msg.message = WS_VSCROLL) OR
(Msg.message = WM_VSCROLL) OR
(Msg.message = WM_MOUSEWHEEL) OR
(Msg.message = WM_LBUTTONDOWN) OR
(Msg.message = WM_LBUTTONUP) OR
(Msg.message = WM_LBUTTONDBLCLK) OR
(Msg.message = WM_MBUTTONDOWN) OR
(Msg.message = WM_MBUTTONUP) OR
(Msg.message = WM_MBUTTONDBLCLK) OR
(Msg.message = WM_RBUTTONDOWN) OR
(Msg.message = WM_RBUTTONUP) OR
(Msg.message = WM_RBUTTONDBLCLK) OR
(Msg.message = WM_KEYUP) OR
(Msg.message = WM_KEYDOWN)
)
then
begin
if not GetCursorPos(pnt) then Exit;
ctrl := FindVCLWindow(pnt);
if Assigned(CTRL) then
begin
if Ctrl is TAdvstringgrid then
begin
// Msg.hwnd:=ctrl.Handle;
//Msg.hwnd := advsg1.Handle;
if thread_activ>0 then
begin
Msg.hwnd := 0;
Exit;
end
else
begin
Msg.hwnd:=ctrl.Handle;
end;
end;
end;
end;
end;
If you use a Tadvstringgrid component change this code to "if Ctrl is TAdvstringgrid".
If you use a Stringgrid change this to "if Ctrl is TStringgrid".
The above procedure uses a global variable called "thread_activ" that contains the number of active threads. So if there are active threads using the Advstringgrid component the mouse clicks, mouse wheel, scroll bars, and key presses are supressed.
The thread is stored in a second unit having the following code:
unit thread_stringgrid;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, StdCtrls;
type
TThread_populate_stringgrid = class(TThread)
strict private
f_stringgrid_to_populate:Tstringgrid;
f_name:string;
protected
procedure Execute; override;
public
CriticalSection: TRTLCriticalSection;
constructor Create(a_name:string;a_stringgrid_to_populate:Tstringgrid);
end;
implementation
{use the unit that holds the global vaiable "thread_activ"}
uses unit1;
constructor TThread_populate_stringgrid.Create(a_name:string;a_stringgrid_to_populate:Tstringgrid);
begin
inherited Create(False);
freeonterminate:=true;
priority:=tpNormal ;
f_name:=a_name;
f_stringgrid_to_populate:=a_stringgrid_to_populate;
end;
procedure TThread_populate_stringgrid.Execute;
begin
//before the threads starts
InitializeCriticalSection(CriticalSection);
//in the thread
EnterCriticalSection(CriticalSection);
//From now on, you can safely make
//changes to the variables.
{increment variable from main unit1}
inc(unit1.thread_activ);
//End of safe block
LeaveCriticalSection(CriticalSection);
Synchronize(
procedure
begin
f_stringgrid_to_populate.cells[0,0]:='DATE';
f_stringgrid_to_populate.cells[1,0]:='NAME';
f_stringgrid_to_populate.cells[2,0]:='ADRESS';
f_stringgrid_to_populate.cells[3,0]:='CITY';
f_stringgrid_to_populate.cells[4,0]:='COUNTRY';
f_stringgrid_to_populate.Cols[0].Add(FormatDatetime('dd-mm-yyyy hh:mm:ss', Now));
f_stringgrid_to_populate.Cols[1].Add(f_name);
f_stringgrid_to_populate.Cols[2].Add('58 RED ROAD');
f_stringgrid_to_populate.Cols[3].Add('ENGLAND');
f_stringgrid_to_populate.Cols[3].Add('UK');
end
);
{eliminate thread counter from global variable "thread_activ"}
EnterCriticalSection(CriticalSection);
try
{decrement variable from main unit1}
dec(unit1.thread_activ);
finally
LeaveCriticalSection(CriticalSection);
end;
end;
(*
procedure TForm1.Button1Click(Sender: TObject);
begin
TThread_populate_stringgrid.Create('Andrei',form1.StringGrid1);
TThread_populate_stringgrid.Create('Matei',form1.StringGrid1);
TThread_populate_stringgrid.Create('Iulia',form1.StringGrid1);
TThread_populate_stringgrid.Create('Petru',form1.StringGrid1);
TThread_populate_stringgrid.Create('Gheorghe',form1.StringGrid1);
TThread_populate_stringgrid.Create('Tudor',form1.StringGrid1);
TThread_populate_stringgrid.Create('Cineva',form1.StringGrid1);
TThread_populate_stringgrid.Create('Altcine',form1.StringGrid1);
end;
*)
(*
procedure TForm1.GridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
S: string;
RectForText: TRect;
begin
// Check for your cell here (in this case the cell in column 4 and row 2 will be colored)
//if (ACol = 1) and (ARow = 1) then
if ((ACol = 1) and (ARow>0)) then
begin
S := form1.StringGrid1.Cells[ACol, ARow];
if (s='Andrei') then
begin
// Fill rectangle with colour
//form1.StringGrid1.Canvas.Brush.Color := clBlack;
form1.StringGrid1.Canvas.FillRect(Rect);
// Next, draw the text in the rectangle
form1.StringGrid1.Canvas.Font.Color := clGreen;
RectForText := Rect;
// Make the rectangle where the text will be displayed a bit smaller than the cell
// so the text is not "glued" to the grid lines
InflateRect(RectForText, -2, -2);
// Edit: using TextRect instead of TextOut to prevent overflowing of text
form1.StringGrid1.Canvas.TextRect(RectForText, S);
end;
end;
// if (ACol = 2) and (ARow = 1) then
if ((ACol = 2)and (ARow>0)) then
begin
S := form1.StringGrid1.Cells[ACol, ARow];
if (s='58 RED ROAD') then
begin
// Fill rectangle with colour
//form1.StringGrid1.Canvas.Brush.Color := clwhite;
form1.StringGrid1.Canvas.FillRect(Rect);
// Next, draw the text in the rectangle
form1.StringGrid1.Canvas.Font.Color := clRed;
RectForText := Rect;
// Make the rectangle where the text will be displayed a bit smaller than the cell
// so the text is not "glued" to the grid lines
InflateRect(RectForText, -2, -2);
// Edit: using TextRect instead of TextOut to prevent overflowing of text
form1.StringGrid1.Canvas.TextRect(RectForText, S);
end
else
begin
// Fill rectangle with colour
//form1.StringGrid1.Canvas.Brush.Color := clwhite;
form1.StringGrid1.Canvas.FillRect(Rect);
// Next, draw the text in the rectangle
form1.StringGrid1.Canvas.Font.Color := clBlue;
RectForText := Rect;
// Make the rectangle where the text will be displayed a bit smaller than the cell
// so the text is not "glued" to the grid lines
InflateRect(RectForText, -2, -2);
// Edit: using TextRect instead of TextOut to prevent overflowing of text
form1.StringGrid1.Canvas.TextRect(RectForText, S);
end;
end;
//if (ACol = 3) and (ARow = 1) then
if ((ACol = 3)and (ARow>0)) then
begin
S := form1.StringGrid1.Cells[ACol, ARow];
if s='Altcine' then
begin
// Fill rectangle with colour
//form1.StringGrid1.Canvas.Brush.Color := clwhite;
form1.StringGrid1.Canvas.FillRect(Rect);
// Next, draw the text in the rectangle
form1.StringGrid1.Canvas.Font.Color := clYellow;
RectForText := Rect;
// Make the rectangle where the text will be displayed a bit smaller than the cell
// so the text is not "glued" to the grid lines
InflateRect(RectForText, -2, -2);
// Edit: using TextRect instead of TextOut to prevent overflowing of text
form1.StringGrid1.Canvas.TextRect(RectForText, S);
end;
end;
*)
end.
I hope that this helps others. Have a great day!
I'm having issues getting a TCustomControl to work with transparency in Delphi 2007. I've currently reduced the problem to the code below. The issue is that when the form is initially created the controls are drawing in the reverse order they are added to the form. When the form is resized, they paint in the correct order. What am I doing wrong? Excluding 3rd party solutions is there a more appropriate path to follow?
Here's my sample project demonstrating the issue in Delphi 2007.
unit Main;
interface
uses
Forms, Classes, Controls, StdCtrls, Messages,
ExtCtrls;
type
// Example of a TWinControl derived control
TMyCustomControl = class(TCustomControl)
protected
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
procedure Paint; override;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
YellowBox: TMyCustomControl;
GreenBox: TMyCustomControl;
end;
var
Form1: TForm1;
implementation
uses
Windows, Graphics;
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
self.OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(10,10,200,200);
GreenBox.color := clGreen;
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(100,100,200,200);
YellowBox.color := clYellow;
end;
// Paint bars on form background
procedure TForm1.FormPaint(Sender: TObject);
var
Idx: Integer;
begin
for Idx := 0 to ClientHeight div 8 do
begin
if Odd(Idx) then
Canvas.Brush.Color := clWhite
else
Canvas.Brush.Color := clSilver; // pale yellow
Canvas.FillRect(Rect(0, Idx * 8, ClientWidth, Idx * 8 + 8));
end;
end;
{ TMyCustomControl }
procedure TMyCustomControl.CreateParams(var params: TCreateParams);
begin
inherited;
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TMyCustomControl.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
SetBkMode (msg.DC, TRANSPARENT);
msg.result := 1;
end;
procedure TMyCustomControl.Paint;
begin
Canvas.Brush.Color := color;
Canvas.RoundRect(0,0,width,height,50,50);
end;
end.
What is wrong is your expectancy of the order of painting of your controls. The order of controls receiving WM_PAINT messages is documented to be actually in the exact opposite order, the top-most control receives the message first. More on the documentation later, since having WS_EX_TRANSPARENT styled siblings leaves us in undocumented territory. As you have already noted, you have a case where the order of the controls receiving WM_PAINT messages is not deterministic - when resizing the window the order changes.
I've modified a bit of your reproduction case to see what is happening. The modifications are the inclusion of two panels and a debug output when they receive WM_PAINT.
unit Unit1;
interface
uses
Forms, Classes, Controls, StdCtrls, Messages, ExtCtrls;
type
TMyCustomControl = class(TCustomControl)
protected
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
procedure Paint; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
TPanel = class(extctrls.TPanel)
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
YellowBox: TMyCustomControl;
GreenBox: TMyCustomControl;
Panel1, Panel2: TPanel;
end;
var
Form1: TForm1;
implementation
uses
sysutils, windows, graphics;
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 590;
Height := 270;
OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(20, 20, 140, 140);
GreenBox.color := clGreen;
GreenBox.Name := 'GreenBox';
//{
Panel1 := TPanel.Create(Self);
Panel1.Parent := Self;
Panel1.SetBounds(240, 40, 140, 140);
Panel1.ParentBackground := False;
Panel1.Color := clMoneyGreen;
Panel1.Name := 'Panel1';
Panel2 := TPanel.Create(Self);
Panel2.Parent := Self;
Panel2.SetBounds(260, 60, 140, 140);
Panel2.ParentBackground := False;
Panel2.Color := clCream;
Panel2.Name := 'Panel2';
//}
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(80, 80, 140, 140);
YellowBox.color := clYellow;
YellowBox.Name := 'YellowBox';
YellowBox.BringToFront;
end;
// Paint bars on form background
procedure TForm1.FormPaint(Sender: TObject);
var
Idx: Integer;
begin
for Idx := 0 to ClientHeight div 8 do
begin
if Odd(Idx) then
Canvas.Brush.Color := clWhite
else
Canvas.Brush.Color := clSilver; // pale yellow
Canvas.FillRect(Rect(0, Idx * 8, ClientWidth, Idx * 8 + 8));
end;
end;
{ TPanel }
procedure TPanel.WMPaint(var Message: TWMPaint);
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
inherited;
end;
{ TMyCustomControl }
procedure TMyCustomControl.CreateParams(var params: TCreateParams);
begin
inherited;
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TMyCustomControl.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
msg.Result := 1;
end;
procedure TMyCustomControl.WMPaint(var Message: TWMPaint);
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
inherited;
end;
procedure TMyCustomControl.Paint;
begin
Canvas.Brush.Color := Color;
Canvas.RoundRect(0, 0, Width, Height, 50, 50);
end;
end.
Which produces this form:
As determined by order of creation, the z-order is, from bottom to top,
GreenBox,
Panel1,
Panel2,
YellowBox.
The debug output for the WM_PAINT messages is this:
Debug Output: Panel2 painting.. Process Project1.exe (12548)
Debug Output: Panel1 painting.. Process Project1.exe (12548)
Debug Output: YellowBox painting.. Process Project1.exe (12548)
Debug Output: GreenBox painting.. Process Project1.exe (12548)
There are two things worth to note in this order.
First, Panel2 receives the paint message before Panel1, although Panel2 is higher in the z-order.
So how is it that while we see Panel2 as a whole, but we see only part of Panel1 even though it is painted later? This is where update regions come into play. The WS_CLIPSIBLINGS style flags in controls tell the OS that part of a control occupied by a sibling higher in the z-order is not going to be painted.
Clips child windows relative to each other; that is, when a particular
child window receives a WM_PAINT message, the WS_CLIPSIBLINGS
style clips all other overlapping child windows out of the region of
the child window to be updated.
Let's dig into a bit more in the WM_PAINT handler of Panel1 and see how the OS' update region looks like.
{ TPanel }
// not declared in D2007
function GetRandomRgn(hdc: HDC; hrgn: HRGN; iNum: Integer): Integer; stdcall;
external gdi32;
const
SYSRGN = 4;
procedure TPanel.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
Rgn: HRGN;
TestDC: HDC;
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
Message.DC := BeginPaint(Handle, PS);
Rgn := CreateRectRgn(0, 0, 0, 0);
if (Name = 'Panel1') and (GetRandomRgn(Message.DC, Rgn, SYSRGN) = 1) then begin
OffsetRgn(Rgn, - Form1.ClientOrigin.X + Width + 40, - Form1.ClientOrigin.Y);
TestDC := GetDC(Form1.Handle);
SelectObject(TestDC, GetStockObject(BLACK_BRUSH));
PaintRgn(TestDC, Rgn);
ReleaseDC(Form1.Handle, TestDC);
DeleteObject(Rgn);
end;
inherited;
EndPaint(Handle, PS);
end;
The BeginPaint will clip the update region with the system update region which you can then retrieve with GetRandomRgn. I've dumped the clipped update region to the right of the form. Don't mind the Form1 references or missing error checks, we are only debugging. Anyway, this produces the below form:
So, whatever you draw in the client area of Panel1, it will get clipped into the black shape, hence it cannot be visually come into front of Panel2.
Second, remember that the green box is created first, then the panels and then the yellow last. So why is it that the two transparent controls are painted after the two panels?
First, remember that controls are painted from top to bottom. Now, how can it be possible for a transparent control to draw onto something which is drawn after it? Obviously it is not possible. So the entire painting algorithm have to change. There is no documentation on this and the best explanation I've found is from a blog entry of Raymond Chen:
... The WS_EX_TRANSPARENT extended window style alters the painting
algorithm as follows: If a WS_EX_TRANSPARENT window needs to be
painted, and it has any non-WS_EX_TRANSPARENT windows siblings (which
belong to the same process) which also need to be painted, then the
window manager will paint the non-WS_EX_TRANSPARENT windows first.
The top to bottom painting order makes it a difficult one when you have transparent controls. Then there is the case of overlapping transparent controls - which is more transparent than the other? Just accept the fact that overlapping transparent controls produce undetermined behavior.
If you investigate the system update regions of the transparent boxes in the above test case, you'll find both to be exact squares.
Let's shift the panels to in-between the boxes.
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 590;
Height := 270;
OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(20, 20, 140, 140);
GreenBox.color := clGreen;
GreenBox.Name := 'GreenBox';
//{
Panel1 := TPanel.Create(Self);
Panel1.Parent := Self;
Panel1.SetBounds(40, 40, 140, 140);
Panel1.ParentBackground := False;
Panel1.Color := clMoneyGreen;
Panel1.Name := 'Panel1';
Panel2 := TPanel.Create(Self);
Panel2.Parent := Self;
Panel2.SetBounds(60, 60, 140, 140);
Panel2.ParentBackground := False;
Panel2.Color := clCream;
Panel2.Name := 'Panel2';
//}
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(80, 80, 140, 140);
YellowBox.color := clYellow;
YellowBox.Name := 'YellowBox';
YellowBox.BringToFront;
end;
...
procedure TMyCustomControl.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
Rgn: HRGN;
TestDC: HDC;
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
Message.DC := BeginPaint(Handle, PS);
Rgn := CreateRectRgn(0, 0, 0, 0);
if (Name = 'GreenBox') and (GetRandomRgn(Message.DC, Rgn, SYSRGN) = 1) then begin
OffsetRgn(Rgn, - Form1.ClientOrigin.X + Width + 260, - Form1.ClientOrigin.Y);
TestDC := GetDC(Form1.Handle);
SelectObject(TestDC, GetStockObject(BLACK_BRUSH));
PaintRgn(TestDC, Rgn);
ReleaseDC(Form1.Handle, TestDC);
DeleteObject(Rgn);
end;
inherited;
EndPaint(Handle, PS);
end;
The right-most black shape is the system update region for the GreenBox. After all the system can apply clipping to a transparent control. I think it would suffice to conclude that the painting algorithm is not perfect when you've got a bunch of transparent controls.
As promised, the documentation quote for the WM_PAINT order. One reason I've left this to last is that it includes a possible solution (of course we already found one solution, scatter some non-transparent controls in-between your transparent controls):
... If a window in the parent chain is composited (a window with
WX_EX_COMPOSITED), sibling windows receive WM_PAINT messages in the
reverse order of their position in the Z order. Given this, the window
highest in the Z order (on the top) receives its WM_PAINT message
last, and vice versa. If a window in the parent chain is not
composited, sibling windows receive WM_PAINT messages in Z order.
For as little as I tested, setting WS_EX_COMPOSITED on the parent form seems to work. But I don't know if it is applicable in your case.
I am creating my own OnAdvancedDrawItem to change the color of the MainMenu. It works well but I get an annoying white line at the bottom.
It disappears when running the mouse over the menu but comes back when another application is selected. How can I get rid of it?
Here is my basic code for the background coloring.
unit MenMain;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,Dialogs, Menus, ImgList, StdCtrls;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File2: TMenuItem;
Edit1: TMenuItem;
Window1: TMenuItem;
procedure Window1AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Window1AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
begin
with TMenuItem(Sender) do
begin
with ACanvas do
begin
Brush.Color := clMoneyGreen;
Inc(ARect.Bottom,1);
FillRect(ARect);
Font.Color := clBlue;
DrawText(ACanvas.Handle, PChar(Caption),Length(Caption),ARect, DT_SINGLELINE or DT_VCENTER);
end;
end;
end;
end.
The ARect parameter of the OnAdvancedDrawItem event handler is the rcItem of the DRAWITEMSTRUCT that's passed to the WM_DRAWITEM message. The documentation has this to say about the rectangle:
A rectangle that defines the boundaries of the control to be drawn.
This rectangle is in the device context specified by the hDC member.
The system automatically clips anything that the owner window draws in
the device context for combo boxes, list boxes, and buttons, but does
not clip menu items. When drawing menu items, the owner window must
not draw outside the boundaries of the rectangle defined by the rcItem
member.
So although the device context is not clipped to the rectangle, you're responsible for not drawing outside of it. That happens when you execute Inc(ARect.Bottom,1); before filling the rectangle.
You can change the color of the grey area. Use this in OnCreate and OnCanResize
global var - fMenuBrushHandle: THandle;
var
lMenuInfo: TMenuInfo;
lMenuColor: TColor;
begin
lMenuColor := clRed;
DeleteObject(fMenuBrushHandle);
fMenuBrushHandle := CreateSolidBrush(ColorToRGB(lMenuColor));
FillChar(lMenuInfo, SizeOf(lMenuInfo), 0);
lMenuInfo.cbSize := SizeOf(lMenuInfo);
lMenuInfo.hbrBack := fMenuBrushHandle;
lMenuInfo.fMask := MIM_BACKGROUND;
SetMenuInfo(MainMenu1.Handle, lMenuInfo);
end;
or
global var - FBrush: TBrush;
var
lMenuInfo: TMenuInfo;
begin
if not Assigned(FBrush) then
FBrush := TBrush.Create;
FBrush.Color := clRed;
FBrush.Style := bsSolid;
lMenuInfo.cbSize := SizeOf(lMenuInfo);
lMenuInfo.fMask := MIM_BACKGROUND;
lMenuInfo.hbrBack := FBrush.Handle;
SetMenuInfo(MainMenu1.Handle, lMenuInfo);
end;
or even draw bitmap
global var
fMenuHandle:THandle;
fBitmap:Tbitmap;
var
lMenuInfo:TMenuInfo;
begin
if Assigned(fBitmap) then
fBitmap.Free;
fBitmap:=TBitmap.Create;
fBitmap.Width:=21;
fBitmap.Height:=Form1.Width;
DeleteObject(fMenuHandle);
fMenuHandle:=CreatePatternBrush(fBitmap.Handle);
Fillchar(lMenuInfo,SizeOf(lMenuInfo),0);
lMenuInfo.cbSize:=SizeOf(lMenuInfo);
lMenuInfo.fMask:=MIM_BACKGROUND;
lMenuInfo.hbrBack:=fMenuHandle;
SetMenuInfo(MainMenu1.Handle,lMenuInfo);
end;
I have an object consisting of a TFrame, on it a TPanel and on that a TImage. A bitmap is assigned to the TImage containing a piano roll. This frame-object is put on a TImage, containing an image that contains a grid. See the image for an example.
Question: Is it possible to make the frame partially transparent, so that the background image containing the grid (on the main form) is vaguely visible? Ideally the amount of transparency can be set by the user. The bitmap is 32 bit deep but experimenting with the alpha channel did not help. The panel is not strictly necessary. It is used to quickly have a border around the object. I could draw that on the image.
Update 1 A small code example is added. The main unit draws a background with vertical lines. The second unit contains a TFrame and a TImage upon it that draws a horizontal line. What I would like to see is that the vertical lines partially shine thru the TFrame Image.
Update 2 What I did not specify in my original question: the TFrame is part of a much bigger application and behaves independently. It would help if the transparency issue could be handled by the TFrame itself.
///////////////// Main unit, on mouse click draw lines and plot TFrame
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls,
Unit2;
type
TForm1 = class(TForm)
Image1: TImage;
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var background: TBitmap;
f: TFrame2;
i, c: Int32;
begin
background := TBitmap.Create;
background.Height := Image1.Height;
background.Width := Image1.Width;
background.Canvas.Pen.Color := clBlack;
for i := 0 to 10 do
begin
c := i * background.Width div 10;
background.Canvas.MoveTo (c, 0);
background.Canvas.LineTo (c, background.Height);
end;
Image1.Picture.Assign (background);
Application.ProcessMessages;
f := TFrame2.Create (Self);
f.Parent := Self;
f.Top := 10;
f.Left := 10;
f.plot;
end;
end.
///////////////////Unit containing the TFrame
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TFrame2 = class(TFrame)
Image1: TImage;
procedure plot;
end;
implementation
{$R *.dfm}
procedure TFrame2.plot;
var bitmap: TBitmap;
begin
bitmap := TBitmap.Create;
bitmap.Height := Image1.Height;
bitmap.Width := Image1.Width;
bitmap.PixelFormat := pf32Bit;
bitmap.Canvas.MoveTo (0, bitmap.Height div 2);
bitmap.Canvas.LineTo (bitmap.Width, bitmap.Height div 2);
Image1.Picture.Assign (bitmap);
end;
end.
Update 3 I had hoped for that there would be some message or API call that would result in a solution that the control could make itself partially transparent, like the WMEraseBkGnd message does for complete transparency. In their solutions both Sertac and NGLN both point at simulating transparency with the AlphaBlend function. This function merges two bitmaps and thus requires a knowledge of the background image. Now my TFrame has an extra property: BackGround: TImage that is assigned by the parent control. That gives the desired result (it's sooo professional to see it working :-)
RRUZ points to the Graphics32 library. What I've seen it produces fantastic results, for me the learning curve is too steep.
Thank you all for your help!
Here's another solution that copies the background image to the top image and AlphaBlends the bitmap over it while preserving opacity of black dots:
unit1:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Unit2, ExtCtrls, ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
Clip_View1: TClip_View;
TrackBar1: TTrackBar;
Label1: TLabel;
procedure TrackBar1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
TrackBar1.Min := 0;
TrackBar1.Max := 255;
TrackBar1.Position := 255;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Label1.Caption := IntToStr(TrackBar1.Position);
Clip_View1.Transparency := TrackBar1.Position;
end;
end.
unit2:
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TClip_View = class(TFrame)
Image1: TImage;
Panel1: TPanel;
Image2: TImage;
protected
procedure SetTransparency(Value: Byte);
private
FTopBmp: TBitmap;
FTransparency: Byte;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Transparency: Byte read FTransparency write SetTransparency;
end;
implementation
{$R *.dfm}
{ TClip_View }
constructor TClip_View.Create(AOwner: TComponent);
begin
inherited;
Image1.Left := 0;
Image1.Top := 0;
Image1.Picture.LoadFromFile(ExtractFilePath(Application.ExeName) + '..\..\back.bmp');
Image1.Picture.Bitmap.PixelFormat := pf32bit;
Image1.Width := Image1.Picture.Bitmap.Width;
Image1.Height := Image1.Picture.Bitmap.Height;
FTopBmp := TBitmap.Create;
FTopBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + '..\..\top.bmp');
FTopBmp.PixelFormat := pf32bit;
Image2.SetBounds(1, 1, FTopBmp.Width, FTopBmp.Height);
Panel1.SetBounds(20, 20, Image2.Width + 2, Image2.Height + 2);
Image2.Picture.Bitmap.SetSize(Image2.Width, Image2.Height);
Image2.Picture.Bitmap.Canvas.Draw(0, 0, FTopBmp);
end;
destructor TClip_View.Destroy;
begin
FTopBmp.Free;
inherited;
end;
procedure TClip_View.SetTransparency(Value: Byte);
var
Bmp: TBitmap;
R: TRect;
X, Y: Integer;
Pixel: PRGBQuad;
BlendFunction: TBlendFunction;
begin
if Value <> FTransparency then begin
FTransparency := Value;
R := Image2.BoundsRect;
OffsetRect(R, Panel1.Left, + Panel1.Top);
Image2.Picture.Bitmap.Canvas.CopyRect(Image2.ClientRect,
Image1.Picture.Bitmap.Canvas, R);
Bmp := TBitmap.Create;
Bmp.SetSize(FTopBmp.Width, FTopBmp.Height);
Bmp.PixelFormat := pf32bit;
Bmp.Assign(FTopBmp);
try
for Y := 0 to Bmp.Height - 1 do begin
Pixel := Bmp.ScanLine[Y];
for X := 0 to Bmp.Width - 1 do begin
if (Pixel.rgbBlue <> 0) and (Pixel.rgbGreen <> 0) and
(Pixel.rgbRed <> 0) then begin
Pixel.rgbBlue := MulDiv(Pixel.rgbBlue, Value, $FF);
Pixel.rgbGreen := MulDiv(Pixel.rgbGreen, Value, $FF);
Pixel.rgbRed := MulDiv(Pixel.rgbRed, Value, $FF);
Pixel.rgbReserved := Value;
end else // don't touch black pixels
Pixel.rgbReserved := $FF;
Inc(Pixel);
end;
end;
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
AlphaBlend(Image2.Picture.Bitmap.Canvas.Handle,
0, 0, Image2.Picture.Bitmap.Width, Image2.Picture.Bitmap.Height,
Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
BlendFunction);
finally
Bmp.Free;
end;
end;
end;
end.
At launch time:
Apply transparency:
Hide the frame and use Frame.PaintTo. For example, as follows:
unit Unit1;
interface
uses
Windows, Classes, Graphics, Controls, Forms, Unit2, JPEG, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage; //Align = alClient, Visible = False
Frame21: TFrame2; //Visible = False
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FBlendFunc: TBlendFunction;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormPaint(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.Width := Frame21.Width;
Bmp.Height := Frame21.Height;
Frame21.PaintTo(Bmp.Canvas, 0, 0);
Canvas.StretchDraw(ClientRect, Image1.Picture.Graphic);
with Frame21 do
Windows.AlphaBlend(Canvas.Handle, Left, Top, Left + Width, Top + Height,
Bmp.Canvas.Handle, 0, 0, Width, Height, FBlendFunc);
finally
Bmp.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FBlendFunc.BlendOp := AC_SRC_OVER;
FBlendFunc.BlendFlags := 0;
FBlendFunc.SourceConstantAlpha := 255 div 2;
FBlendFunc.AlphaFormat := 0;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Invalidate;
end;
end.
The frame unit:
unit Unit2;
interface
uses
Windows, Classes, Controls, Forms, JPEG, ExtCtrls;
type
TFrame2 = class(TFrame)
Image1: TImage; //Align = alClient
Panel1: TPanel; //Align = alClient, BevelWidth = 5
end;
implementation
{$R *.dfm}
end.
Result:
Rewrite the above for your specific situation, ideally painting on a TPaintBox getting rid of the image component on the main form. But when the only significant element of the frame is the image, then I would stop using that too, and begin painting everything myself.
I would use a TPaintBox instead. In its OnPaint event, draw your grid first, then alpha-blend your roll image on top. No need to use any TImage, TPanel, or TFrame components at all.