How to correctly Render OpenGL in a Control? - delphi

I am trying to create a custom control that will essentially be a OpenGL Window.
I have it all setup and working (at least it seems to be) with the help of some guides to setup the pixel format etc, however I notice when I resize the parent Form the OpenGL graphics become scaled / stretched.
To illustrate this, the following image is how it should appear:
After the Form has been resized, it now appears as below for example:
Disregard the OSD at the top as this is part of the screen recorder Software I use which also distorts.
Here I have added a Gif to better demonstrate what it happening when the Form is resized:
Here is the unit for my custom control:
unit OpenGLControl;
interface
uses
Winapi.Windows,
System.SysUtils,
System.Classes,
Vcl.Controls;
type
TOpenGLControl = class(TCustomControl)
private
FDC: HDC;
FRC: HGLRC;
FOnPaint: TNotifyEvent;
protected
procedure SetupPixelFormat;
procedure GLInit;
procedure GLRelease;
procedure CreateHandle; override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
end;
implementation
uses
OpenGL;
{ TOpenGLControl }
constructor TOpenGLControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TOpenGLControl.Destroy;
begin
GLRelease;
inherited Destroy;
end;
procedure TOpenGLControl.CreateHandle;
begin
inherited;
GLInit;
end;
procedure TOpenGLControl.SetupPixelFormat;
var
PixelFormatDescriptor: TPixelFormatDescriptor;
pfIndex: Integer;
begin
with PixelFormatDescriptor do
begin
nSize := SizeOf(TPixelFormatDescriptor);
nVersion := 1;
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 32;
cRedBits := 0;
cRedShift := 0;
cGreenBits := 0;
cGreenShift := 0;
cBlueBits := 0;
cBlueShift := 0;
cAlphaBits := 0;
cAlphaShift := 0;
cAccumBits := 0;
cAccumRedBits := 0;
cAccumGreenBits := 0;
cAccumBlueBits := 0;
cAccumAlphaBits := 0;
cDepthBits := 16;
cStencilBits := 0;
cAuxBuffers := 0;
iLayerType := PFD_MAIN_PLANE;
bReserved := 0;
dwLayerMask := 0;
dwVisibleMask := 0;
dwDamageMask := 0;
end;
pfIndex := ChoosePixelFormat(FDC, #PixelFormatDescriptor);
if pfIndex = 0 then Exit;
if not SetPixelFormat(FDC, pfIndex, #PixelFormatDescriptor) then
raise Exception.Create('Unable to set pixel format.');
end;
procedure TOpenGLControl.GLInit;
begin
FDC := GetDC(Handle);
if FDC = 0 then Exit;
SetupPixelFormat;
FRC := wglCreateContext(FDC);
if FRC = 0 then Exit;
if not wglMakeCurrent(FDC, FRC) then
raise Exception.Create('Unable to initialize.');
end;
procedure TOpenGLControl.GLRelease;
begin
wglMakeCurrent(FDC, 0);
wglDeleteContext(FRC);
ReleaseDC(Handle, FDC);
end;
procedure TOpenGLControl.Paint;
begin
inherited;
if Assigned(FOnPaint) then
begin
FOnPaint(Self);
end;
end;
end.
To test, create a new Application and add a TPanel to the Form, also create the Forms OnCreate and OnDestroy event handlers then use the following:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, OpenGLControl;
type
TForm1 = class(TForm)
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure OpenGLControlPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
FOpenGLControl: TOpenGLControl;
implementation
uses
OpenGL;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FOpenGLControl := TOpenGLControl.Create(nil);
FOpenGLControl.Parent := Panel1;
FOpenGLControl.Align := alClient;
FOpenGLControl.Visible := True;
FOpenGLControl.OnPaint := OpenGLControlPaint;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FOpenGLControl.Free;
end;
procedure TForm1.OpenGLControlPaint(Sender: TObject);
begin
glViewPort(0, 0, FOpenGLControl.Width, FOpenGLControl.Height);
glMatrixMode(GL_PROJECTION);
glLoadIdentity();
glBegin(GL_TRIANGLES);
glColor3f(0.60, 0.10, 0.35);
glVertex3f( 0.0, 1.0, 0.0);
glVertex3f(-1.0,-1.0, 0.0);
glVertex3f( 1.0,-1.0, 0.0);
glEnd;
SwapBuffers(wglGetCurrentDC);
end;
end.
Interestingly setting the parent of FOpenGLControl to the Form seems to work as expected, eg:
procedure TForm1.FormCreate(Sender: TObject);
begin
FOpenGLControl := TOpenGLControl.Create(nil);
FOpenGLControl.Parent := Form1;
FOpenGLControl.Align := alClient;
FOpenGLControl.Visible := True;
FOpenGLControl.OnPaint := OpenGLControlPaint;
end;
It's important to know I have limited knowledge with OpenGL and most of this is new to me, I am unsure if this is something to do with setting the view port of the window which I thought I had done but maybe the issue lies elsewhere or I did something incorrectly.
So my question is, How do I correctly render OpenGL inside a control without it stretching / distorting when the parent windows resizes?
Thank you.
Update 1
procedure TForm1.FormResize(Sender: TObject);
var
Aspect: Single;
begin
glViewPort(0, 0, FOpenGLControl.Width, FOpenGLControl.Height);
glMatrixMode(GL_PROJECTION);
glLoadIdentity();
Aspect := Real(FOpenGLControl.Width) / Real(FOpenGLControl.Height);
glOrtho(-Aspect, Aspect, -1.0, 1.0, -1.0, 1.0);
end;
procedure TForm1.OpenGLControlPaint(Sender: TObject);
begin
glBegin(GL_TRIANGLES);
glColor3f(0.60, 0.10, 0.35);
glVertex3f(0.0, 1.0, 0.0);
glVertex3f(-1.0,-1.0, 0.0);
glVertex3f( 1.0,-1.0, 0.0);
glEnd;
SwapBuffers(wglGetCurrentDC);
end;
The above works but only when the parent is aligned to client, in this example when Panel1 is aligned to client. When the Panel is not aligned it distorts when the window is resized.

If the viewport is rectangular, then this has to be considered by mapping the coordinates of the scene to the viewport.
You have to use an orthographic projection matrix. The projection matrix transforms all vertex data from the eye coordinates to the clip coordinates. Then, these clip coordinates are also transformed to the normalized device coordinates (NDC) by dividing with w component of the clip coordinates. The normalized device coordinates is in range (-1, -1, -1) to (1, 1, 1).
If you use an orthographic projection matrix, then the eye space coordinates are linearly mapped to the NDC. An orthographic matrix can be setup by glOrtho.
To solve your issue, you have to calculate the Aspect of the viewport, which is a floating point value, representing the relation between the width and the height of the viewport and you have to init the orthographic projection matrix.
According to the documentation of TCustomControl, is Width and Height the the vertical and horizontal size of the control in pixels. But this is not equal the size of the control's client area. Use ClientWidth and ClientHeight instead, which gives the width and the height of the control's client area in pixels.
procedure TForm1.FormResize(Sender: TObject);
var
Aspect: Single;
begin
glViewPort(0, 0, FOpenGLControl.ClientWidth, FOpenGLControl.ClientHeight);
glMatrixMode(GL_PROJECTION);
glLoadIdentity();
Aspect := Real(FOpenGLControl.ClientWidth) / Real(FOpenGLControl.ClientHeight);
glOrtho(-Aspect, Aspect, -1.0, 1.0, -1.0, 1.0);
end;

Related

How to get a windows 10 style transparent border

I've been experimenting to see if I can get the same effect with a custom control with no luck.
The issue is, I'm wanting to make a resizable panel like component derived from Tcustomcontrol.
I can create a single pixel border with WS_BORDER and then use WMNCHitTest to detect the edges. But if the control contains another control aligned to alclient, then the mouse messages go to that contained component rather than the containing panel. So at best, the resizing cursors only work when they are precisely over the single pixel border.
Changing to WS_THICKFRAME obviously works but makes an ugly visible border.
I noticed that WIN10 forms have an invisible thick border with just a single pixel line on the inner edges. So the resizing cursors work outside the visible frame for about 6 to 8 pixels making it much easier to select.
Any ideas on how they are achieving that effect and can it be easily duplicated in delphi vcl controls?
You don't need borders that are meant to be used with top-level windows, handle WM_NCCALCSIZE to deflate your client area:
procedure TSomeControl.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
inherited;
InflateRect(Message.CalcSize_Params.rgrc0, -FBorderWidth, -FBorderWidth);
end;
where FBorderWidth is the supposed padding around the control.
Handle WM_NCHITTEST to resize with the mouse from borders.
procedure TSomeControl.WMNCHitTest(var Message: TWMNCHitTest);
var
Pt: TPoint;
begin
inherited;
Pt := ScreenToClient(Point(Message.XPos, Message.YPos));
if Pt.X < 0 then
Message.Result := HTLEFT;
...
Of course you have to paint the borders to your liking.
Here's my full test unit:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
extctrls;
type
TSomeControl = class(TCustomControl)
private
FBorderWidth: Integer;
protected
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
public
constructor Create(AOwner: TComponent); override;
end;
{ TSomeControl }
constructor TSomeControl.Create(AOwner: TComponent);
begin
inherited;
FBorderWidth := 5;
ControlStyle := ControlStyle + [csAcceptsControls];
end;
procedure TSomeControl.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
inherited;
InflateRect(Message.CalcSize_Params.rgrc0, -FBorderWidth, -FBorderWidth);
end;
procedure TSomeControl.WMNCHitTest(var Message: TWMNCHitTest);
var
Pt: TPoint;
begin
inherited;
Pt := ScreenToClient(Point(Message.XPos, Message.YPos));
if Pt.X < 0 then
Message.Result := HTLEFT;
if Pt.Y < 0 then
Message.Result := HTTOP;
if Pt.X > ClientWidth then
Message.Result := HTRIGHT;
if Pt.Y > ClientHeight then
Message.Result := HTBOTTOM;
end;
procedure TSomeControl.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
begin
DC := GetWindowDC(Handle);
SelectClipRgn(DC, 0);
SelectObject(DC, GetStockObject(BLACK_PEN));
SelectObject(DC, GetStockObject(GRAY_BRUSH));
Rectangle(DC, 0, 0, Width, Height);
ReleaseDC(Handle, DC);
end;
//---------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var
C: TSomeControl;
P: TPanel;
begin
C := TSomeControl.Create(Self);
C.SetBounds(30, 30, 120, 80);
C.Parent := Self;
P := TPanel.Create(Self);
P.Parent := C;
P.Align := alClient;
end;
end.

Delphi OpenGL resize

I've a question about using OpenGL from Delphi.
My intention is to draw a grid of n rows and n columns in a form. i want the cells in the grid to be square like this image:
This is the code I use to create this grid:
unit Main;
interface
uses
Winapi.Windows, Winapi.Messages, Winapi.OpenGL, System.SysUtils,
System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,
Vcl.Dialogs, Vcl.Menus;
type
TfrmMain = class(TForm)
PopupMenu: TPopupMenu;
mnuDrawGrid: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure mnuDrawGridClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormResize(Sender: TObject);
private
glDC: HDC;
oldW: Integer;
oldH: Integer;
glContext: HGLRC;
errorCode: GLenum;
openGLReady: Boolean;
procedure DisegnaLinea(const aX1, aY1, aX2, aY2: Double; aSpessore,
aOffSet: Integer);
procedure DisegnaTabellone(const aNumRighe, aNumColonne: SmallInt);
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
{ Gestione form -------------------------------------------------------------- }
// OpenGL initialization
procedure TfrmMain.FormCreate(Sender: TObject);
var
pfd: TPixelFormatDescriptor;
formatIndex: Integer;
begin
FillChar(pfd, SizeOf(pfd), 0);
with pfd do
begin
nSize := SizeOf(pfd);
nVersion := 1;
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 24;
cDepthBits := 32;
iLayerType := PFD_MAIN_PLANE;
end;
glDC := GetDC(Handle);
formatIndex := ChoosePixelFormat(glDC, #pfd);
if formatIndex = 0 then
raise Exception.Create('Choose pixel format failed ' + IntToStr(GetLastError));
if not SetPixelFormat(glDC, formatIndex, #pfd) then
raise Exception.Create('Set pixel forma failed ' + IntToStr(GetLastError));
glContext := wglCreateContext(glDC);
if not glContext = 0 then
raise Exception.Create('Create context failed ' + IntToStr(GetLastError));
if not wglMakeCurrent(glDC, glContext) then
raise Exception.Create('Make current failsed ' + IntToStr(GetLastError));
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
glOrtho(0.0, ClientWidth, 0.0, ClientHeight, 0.0, 1.0);
oldW := ClientWidth;
oldH := ClientHeight;
openGLReady := True;
end;
// OpenGL destruction
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
wglMakeCurrent(Canvas.Handle, 0);
wglDeleteContext(glContext);
end;
// Form resize
procedure TfrmMain.FormResize(Sender: TObject);
begin
if not openGLReady then
exit;
glViewport(0, 0, ClientWidth, ClientHeight);
errorCode := glGetError;
if errorCode <> GL_NO_ERROR then
raise Exception.Create('Form resize: ' + gluErrorString(errorCode));
if (ClientWidth <> oldW) and (ClientHeight <> oldH) then
DisegnaTabellone(10, 10);
oldW := ClientWidth;
oldH := ClientHeight;
end;
{ Gestione menu -------------------------------------------------------------- }
// Menu option grid drawing
procedure TfrmMain.mnuDrawGridClick(Sender: TObject);
begin
DisegnaTabellone(10, 10);
end;
{ OpenGL --------------------------------------------------------------------- }
// Draw a line at aX1, aY1 to aX2, aY2 coordinates
procedure TfrmMain.DisegnaLinea(const aX1, aY1, aX2, aY2: Double; aSpessore,
aOffSet: Integer);
begin
glEnable(GL_LINE_SMOOTH);
glLineWidth(aSpessore);
glBegin(GL_LINES);
glVertex2f(aX1, aY1);
glVertex2f(aX2, aY2);
glEnd;
end;
// Grid design
procedure TfrmMain.DisegnaTabellone(const aNumRighe, aNumColonne: SmallInt);
const
vOffSet = 20;
var
idx: SmallInt;
pX: Double;
pY: Double;
incX: Double;
incY: Double;
hPos: Double;
hWidth: Double;
widthArea: Integer;
heightArea: Integer;
aspectRatio: Double;
begin
glClearColor(1.0, 1.0, 1.0, 0.0);
glClear(GL_COLOR_BUFFER_BIT);
glColor3f(0.0, 0.0, 0.0);
widthArea := ClientWidth;
heightArea := ClientHeight;
aspectRatio := widthArea / heightArea;
pY := vOffSet / 2;
incY := (heightArea - vOffSet) / aNumRighe;
pX := (widthArea - aNumColonne * incY) / 2;
hPos := pX;
hWidth := hPos + aNumColonne * incY;
incX := incY;
// Draw vertical lines
for idx := 0 to aNumColonne do begin
DisegnaLinea(pX, vOffSet / 2, pX, heightArea - vOffSet / 2, 3, 0);
pX := pX + incX;
end;
// Draw horizontal lines
for idx := 0 to aNumRighe do begin
DisegnaLinea(hPos, pY, hWidth, pY, 3, 0);
pY := pY + incY;
end;
glFlush;
end;
end.
I initialize the pixel format description in the FormCreate event and Ive created a routine called by a popup menu in order to draw the grid. In this routine I make same calculation because I want the grid cells to be square as I said. So I take the height of the form (ClientHeight) and I divide it for the number of rows I need: in this case 10 plus i'ce a little offset in order to have a margin on the top and bottom of the form. Then I calculate the width of the grid for a perfet square. It works well but the problem come when I resize the form.
My intension is to draw a new grid smaller or larger according to the form dimensions, but this is only my intention because the grid does'nt mantein the correct aspet ratio and is drawn in a bad manner as ou can see in the following picure:
I can't understand where is the error in my code. I'm nwe at OpenGL so can someone help me?
Eros
Although you set the new glViewport() on resize, you still use the old orthographic projection matrix which is no more relevant.
So, all you need is an additional glOrtho() before setting a new viewport.
OpenGL immediate mode (glBegin(), glEnd(), glVertex(), etc.) had been obsolete for nearly twenty years; you really shouldn`t be using it in 2017.

How create a screenshot of a particular area?

I have code that receives a specific area already defined before on server side and creates a hole on Form in client side. Instead of this, i want to get a screen capture of this same area but without appears my Form in final result, like a normal desktop capture, but in this case will be only captured, this small area.
So, how i can adapt this my code below for this?
procedure TForm1.CS1Read(Sender: TObject; Socket: TCustomWinSocket);
var
X1, X2, Y1, Y2: Integer;
List: TStrings;
FormRegion, HoleRegion: HRGN;
StrCommand: String;
begin
StrCommand := Socket.ReceiveText;
if Pos('§', StrCommand) > 0 then
begin
List := TStringList.Create;
try
FormRegion := CreateRectRgn(0, 0, Form12.Width, Form12.Height);
ExtractStrings(['§'], [], PChar(StrCommand), List);
X1 := StrToIntDef(List[0], 0) - Form12.Left - 2;
Y1 := StrToIntDef(List[1], 0) - Form12.Top - 2;
X2 := StrToIntDef(List[2], 0) - Form12.Left - 2;
Y2 := StrToIntDef(List[3], 0) - Form12.Top - 2;
HoleRegion := CreateRectRgn(X1, Y1, X2, Y2);
CombineRgn(FormRegion, FormRegion, HoleRegion, RGN_DIFF);
SetWindowRgn(Form12.Handle, FormRegion, True);
finally
List.Free;
end;
end;
end;
I don't have all of your extraneous information, but I can show you how to capture the contents of a region into a bitmap. You'll need to adjust the coordinates appropriately to suit your needs, of course. You may want to see GetRgnBox to see how to get the total region's bounding rectangle after you've combined them. My example doesn't do so, because I have a single region.
The example requires two TButtons and a TImage on a form. I've sized the form and located the three components in code, so that it's not necessary to include a DFM. You will need to drop the components on a form and connect the event handlers, however. :-)
Clicking Button1 will create a rectangular region on the form, fill it with a grid type pattern of red lines and a bit of text, just to define where the region is located. Clicking the second button will draw a copy of that region's content on a bitmap and assign that bitmap to the image control.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
// Region coords
R: TRect;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
// Create the region (hole)
procedure TForm1.Button1Click(Sender: TObject);
var
Region: HRGN;
begin
Canvas.TextOut(R.Left + 60, R.Top + 60, 'Test text');
Canvas.Brush.Style := bsCross;
Canvas.Brush.Color := clRed;
Region := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);
{
Note: Normally you'd want to check the result of the above API call
and only proceed if it's not NULL (0). You'd also want to use a
try..finally to make sure that the region was deleted properly.
Omitted here because
a) This code was tested to work properly, and
b) It's a demo app for doing something with the region and
nothing else. If the call to create the region fails, the
app is useless, and you'll close it anyway, which means
the region will be automatically destroyed.
}
FillRgn(Canvas.Handle, Region, Canvas.Brush.Handle);
DeleteObject(Region);
Button2.Enabled := True;
end;
// Capture the region (hole) and display in the TImage.
procedure TForm1.Button2Click(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.SetSize(R.Right - R.Left, r.Bottom - R.Top);
Bmp.Canvas.CopyRect(Rect(0, 0, Bmp.Width, Bmp.Height), Canvas, R);
Image1.Picture.Assign(Bmp);
finally
Bmp.Free;
end;
end;
// Set up the coordinates for the region (hole) in the form
procedure TForm1.FormCreate(Sender: TObject);
begin
R := Rect(10, 40, 175, 175);
// Size the image we'll use later to fit the rectangle. We set
// the position below.
Image1.Width := R.Right - R.Left;
Image1.Height := R.Bottom - R.Top;
Self.Height := 375;
Self.Width := 350;
Button1.Left := 238;
Button1.Top := 16;
Button2.Left := 238;
Button2.Top := 48;
Image1.Left := 160;
Image1.Top := 190;
// Disable the second button until the first has been clicked
Button2.Enabled := False;
end;
end.

Making a custom drag image opaque in Delphi

I've implemented custom drag images with no problem.
I inherite a class from TDragControlObject and override its GetDragImages function and
add bitmap to TDragImageList, making the white pixels transparent.
It works, white pixels are invisible (transparent) but the remaining bitmap is not opaque.
Is there a way to change this behavior of dragobject?
You can use ImageList_SetDragCursorImage. This is normally used to provide a merged image of the drag image with a cursor image, and then, normally, you hide the real cursor to prevent confusion (showing two cursors).
The system does not blend the cursor image with the background as it does with the drag image. So, if you provide the same drag image as the cursor image, at the same offset, and do not hide the actual cursor, you'll end up with an opaque drag image with a cursor. (Similarly, an empty drag image could be used but I find the former design easier to implement.)
The below sample code (XE2) is tested with W7x64 and in a VM with XP.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button2StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure Button2EndDrag(Sender, Target: TObject; X, Y: Integer);
private
FDragObject: TDragObject;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
commctrl;
{$R *.dfm}
type
TMyDragObject = class(TDragObjectEx)
private
FDragImages: TDragImageList;
FImageControl: TWinControl;
protected
function GetDragImages: TDragImageList; override;
public
constructor Create(ImageControl: TWinControl);
destructor Destroy; override;
end;
constructor TMyDragObject.Create(ImageControl: TWinControl);
begin
inherited Create;
FImageControl := ImageControl;
end;
destructor TMyDragObject.Destroy;
begin
FDragImages.Free;
inherited;
end;
function TMyDragObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
Pt: TPoint;
begin
if not Assigned(FDragImages) then begin
Bmp := TBitmap.Create;
try
Bmp.PixelFormat := pf32bit;
Bmp.Canvas.Brush.Color := clFuchsia;
// 2px margin at each side just to show image can have transparency.
Bmp.Width := FImageControl.Width + 4;
Bmp.Height := FImageControl.Height + 4;
Bmp.Canvas.Lock;
FImageControl.PaintTo(Bmp.Canvas.Handle, 2, 2);
Bmp.Canvas.Unlock;
FDragImages := TDragImageList.Create(nil);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
Pt := Mouse.CursorPos;
MapWindowPoints(HWND_DESKTOP, FImageControl.Handle, Pt, 1);
FDragImages.DragHotspot := Pt;
FDragImages.Masked := True;
FDragImages.AddMasked(Bmp, clFuchsia);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
//--
procedure TForm1.Button2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
(Sender as TWinControl).BeginDrag(False);
// OnStartDrag is called during the above call so FDragImages is
// assigned now.
// The below is the only difference with a normal drag image implementation.
ImageList_SetDragCursorImage(
(FDragObject as TMyDragObject).GetDragImages.Handle, 0, 0, 0);
end;
procedure TForm1.Button2StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
DragObject := TMyDragObject.Create(Sender as TWinControl);
DragObject.AlwaysShowDragImages := True;
FDragObject := DragObject;
end;
end.
Screen shot for above code:
(Note that the actual cursor was crNoDrop but the capture software used the default one.)
If you want to see what the system really does with the images, change the above ImageList_SetDragCursorImage call to proide a hot spot, e.g.
ImageList_SetDragCursorImage(
(FDragObject as TMyDragObject).GetDragImages.Handle, 0, 15, 15);
// ShowCursor(False); // optional
now you'll be able to see both the semi-transparent and opaque images at the same time.

WM_NCHITTEST not working in WS_EX_LAYERED form

I'm using the code of this article http://melander.dk/articles/alphasplash/ to display a 32 bit bitmap in a form, but when i try to use a solid color bitmap instead of a image the WM_NCHITTEST message is not received and i cann't move the form. If I use 32 bitmap image the code work just fine. What i'm missing here?
This is the code
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
protected
{ Private declarations }
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
BlendFunction: TBlendFunction;
BitmapPos: TPoint;
BitmapSize: TSize;
exStyle: DWORD;
Bitmap: TBitmap;
begin
// Enable window layering
exStyle := GetWindowLongA(Handle, GWL_EXSTYLE);
if (exStyle and WS_EX_LAYERED = 0) then
SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);
Bitmap := TBitmap.Create;
try
//Bitmap.LoadFromFile('splash.bmp'); //if I use a image the code works fine
Bitmap.PixelFormat := pf32bit;
Bitmap.SetSize(Width, Height);
Bitmap.Canvas.Brush.Color:=clRed;
Bitmap.Canvas.FillRect(Rect(0,0, Bitmap.Width, Bitmap.Height));
// Position bitmap on form
BitmapPos := Point(0, 0);
BitmapSize.cx := Bitmap.Width;
BitmapSize.cy := Bitmap.Height;
// Setup alpha blending parameters
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
UpdateLayeredWindow(Handle, 0, nil, #BitmapSize, Bitmap.Canvas.Handle,
#BitmapPos, 0, #BlendFunction, ULW_ALPHA);
Show;
finally
Bitmap.Free;
end;
end;
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
Message.Result := HTCAPTION;
end;
end.
Try with:
BlendFunction.SourceConstantAlpha := 150; // 255 is fully opaque.
BlendFunction.AlphaFormat := 0;
Because your bitmap data has no source alpha. AlphaFormat for a TBitmap is by default afIgnored. 'AC_SRC_ALPHA' is only used with images having color values premultiplied with alpha. The images you are loading from the disk probably has proper alpha channel.
I can't really guess what's the relation with 'WM_NC_HITTEST' but wrong inputs yields wrong results :).

Resources