Make owner-drawn TPageControl tabs look nicer, like without owner-draw - delphi

I use Delphi7, PageControl with owner-draw. I can't get so plain and nice look of tabs, as I see on not-owner-drawn PageControls. What's bad:
when using owner-draw, I can't draw on "entire" tab header area, small 1-2px frame around tab header is painted by OS.
1) Delphi not owner-draw, look is OK too (XPMan used):
2) Delphi owner-draw, you see not entire tab header can be colored (XPMan used):
I draw current tab with blue and others with white, here. Only example.
Code:
procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
c: TCanvas;
begin
c:= (Control as TPageControl).Canvas;
if Active then
c.Brush.Color:= clBlue
else
c.Brush.Color:= clWhite;
c.FillRect(Rect);
end;
2b) Delphi owner-draw in real app (XPMan used):
Why do i need to use owner-draw? Simple. To draw X button on tab headers, to paint upper-line with custom color, to paint icons from imagelists.
I'm looking for a way to paint ENTIRE rect of tab headers, not decreased rect which is given to PageControl owner-draw events. I tried to increase the rect given by owner-draw events, but this doesn't help, OS repaints this thin 1-2px frame around tab headers anyway.

The tabs of an owner drawn native "tab control" (TPageControl in VCL, although its ascendant is appropriately named TCustomTabControl - it is anyone's guess why the creative naming..), is expected to be painted by its parent control while processing WM_DRAWITEM messages, as documented here.
The VCL takes the burden from the parent by mutating the message to a CN_DRAWITEM message and sending it to the control itself. In this process the VCL has no further intervention. It just calls the OnDrawTab message handler if it is assigned by user code, passing appropriate parameters.
So, it's not the VCL that draws the borders around tabs, but the OS itself. Also, evidently, it doesn't do this during processing of WM_DRAWITEM messages but later in the painting process. You can verify this by putting an empty WM_DRAWITEM handler on the parent of a page control. Result is, whatever we paint in the event handler, it will later get borders by the OS.
What we might try is to try to prevent what the OS draws take effect, we have the device context (as Canvas.Handle) after all. Unfortunately this route also is a dead end because the VCL, after the event handler returns, restores the device context's state.
The only way, then, we have is to completely abandon handling an OnDrawTab event, and acting upon CN_DRAWITEM message. Below sample code use an interposer class, but you can subclass the control any way you like. Make sure that OwnerDrawn is set.
type
TPageControl = class(comctrls.TPageControl)
protected
procedure CNDrawitem(var Message: TWMDrawItem); message CN_DRAWITEM;
end;
TForm1 = class(TForm)
..
..
procedure TPageControl.CNDrawitem(var Message: TWMDrawItem);
var
Color: TColor;
Rect: TRect;
Rgn: HRGN;
begin
Color := 0;
// draw in different colors so we see where we've drawn
case Message.DrawItemStruct.itemID of
0: Color := $D0C0BF;
1: Color := $D0C0DF;
2: Color := $D0C0FF;
end;
SetDCBrushColor(Message.DrawItemStruct.hDC, Color);
// we don't want to get clipped in the passed rectangle
SelectClipRgn(Message.DrawItemStruct.hDC, 0);
// magic numbers corresponding to where the OS draw the borders
Rect := Message.DrawItemStruct.rcItem;
if Bool(Message.DrawItemStruct.itemState and ODS_SELECTED) then begin
Inc(Rect.Left, 2);
// Inc(Rect.Top, 1);
Dec(Rect.Right, 2);
Dec(Rect.Bottom, 3);
end else begin
Dec(Rect.Left, 2);
Dec(Rect.Top, 2);
Inc(Rect.Right, 2);
Inc(Rect.Bottom);
end;
FillRect(Message.DrawItemStruct.hDC, Rect,
GetStockObject(DC_BRUSH));
// just some indication for the active tab
SetROP2(Message.DrawItemStruct.hDC, R2_NOTXORPEN);
if Bool(Message.DrawItemStruct.itemState and ODS_SELECTED) then
Ellipse(Message.DrawItemStruct.hDC, Rect.Left + 4, Rect.Top + 4,
Rect.Left + 12, Rect.Top + 12);
// we want to clip the DC so that the borders to be drawn are out of region
Rgn := CreateRectRgn(0, 0, 0, 0);
SelectClipRgn(Message.DrawItemStruct.hDC, Rgn);
DeleteObject(Rgn);
Message.Result := 1;
inherited;
end;
Here is how the above looks here:

From what I can tell, you are simply looking to have themed painting of your application. In Delphi 7, all you need to do to achieve that is to add an application manifest that specifies the use of comctl32 version 6. The simple way to do so is to add a TXPManifest component to one of your forms or data modules, or just to reference the XPMan unit in your project.
Since you want the system to paint your page control, you must not do any owner drawing.

Related

Delphi TImage32 - how to make the component invisible if no picture is loaded?

If you place a normal TImage component on a form or panel over other components >> it is invisible at runtime as long no picture is loaded. So other things under it are visible.
But TImage32 is painting a gray box by default.
How do I make the it invisible while leaving the setting: .Visible:=True; if no picture is loaded?
(I still need events working on the component, like OnClick...)
Yes, this is a duplicate question, BUT the solution-link from the previous topic is dead. :(
While I still have access to the newsgroup posts, I don't know how the topic ID relates to the topic title (which is all I have). However, based an a search in the newsgroup I found several places where TImage32Ex was mentioned. I guess that this component (which is not part of the core library) was part of the solution in some way.
So, while the extension pack where this component comes from is no longer maintained, let's dig deeper in what it did.
First, I must say that TImage32 will always paint (copy) the content of its buffer to the display. This means whatever graphic is behind this component will get overwritten by default.
The trick TImage32Ex does is to get the parents content and draws it into the buffer.
With adaptions the code looks like this
var
P: TPoint;
SaveIndex: Integer;
begin
SaveIndex := SaveDC(Buffer.Handle);
try
GetViewportOrgEx(Buffer.Handle, P);
SetViewportOrgEx(Buffer.Handle, P.X - Left, P.Y - Top, nil);
IntersectClipRect(Buffer.Handle, 0, 0, Parent.ClientWidth, Parent.ClientHeight);
Parent.Perform(WM_ERASEBKGND, Buffer.Handle, 0);
Parent.Perform(WM_PAINT, Buffer.Handle, 0);
finally
RestoreDC(Buffer.Handle, SaveIndex);
end;
end;
The above code draws (WM_PAINT) the parent's content onto the buffer.
For example if you want to make the TPaintBox32 instance called PaintBox32 to be transparent just add the following code to the 'PaintBuffer' handler:
procedure TForm3.PaintBox32PaintBuffer(Sender: TObject);
var
P: TPoint;
SaveIndex: Integer;
begin
SaveIndex := SaveDC(PaintBox32.Buffer.Handle);
try
GetViewportOrgEx(PaintBox32.Buffer.Handle, P);
SetViewportOrgEx(PaintBox32.Buffer.Handle, P.X - PaintBox32.Left, P.Y - PaintBox32.Top, nil);
IntersectClipRect(PaintBox32.Buffer.Handle, 0, 0, PaintBox32.Parent.ClientWidth, PaintBox32.Parent.ClientHeight);
PaintBox32.Parent.Perform(WM_ERASEBKGND, PaintBox32.Buffer.Handle, 0);
PaintBox32.Parent.Perform(WM_PAINT, PaintBox32.Buffer.Handle, 0);
finally
RestoreDC(PaintBox32.Buffer.Handle, SaveIndex);
end;
end;
Note: While this works basically, it might not capture the parent's sub controls properly. This is especially true for TWinControl descendants. While there are solutions around to cover this scenario as well, it's far more complicated to cover this in every detail (e.g. the blinking cursor of an underlying TEdit instance)
I use a timage to mask a progress bar and give it a shape.
What I do is load a png with parts that are transparent and then place it over my progress bar.
I think this should achieve your goal. Place a transparent png in your timage.
Cheers,
E.

Is there a way to turn off the Caption on a TDBRadioGroup

I have a TDBRadioGroup that I've added to my form.
I'd really like to have the caption to the left of it instead of on top (the form's a little busy and tall, and I'm trying to squeeze it in).
I can add my own label to the left of the Radio Group. But the control insists on reserving space of a Caption that does not exists. Is there a way I can turn it off completely?
The best we've come up with so far is sticking it on a TPanel and then hiding the top couple lines off-panel.
A TGroupBox (and it's descendant TDBGroupBox) are basically wrappers around the Windows GroupBox. The control is designed to sport a user-defined label across the upper-left corner, and doesn't have any style setting to remove it.
So, short of creating your own control to host a series of TRadioButton controls yourself and display them, there's no built-in way to disable the space reserved for the caption. You can suppress the text, of course, by setting the Caption := '', but the padding for the text descenders is not removed simply because the caption isn't displayed.
You can override the paint procedure for TRadioGroup so that the frame is drawn closer to the top of your item list. You could create a new component of type TNoCaptionRadioGroup. You might still have to use the panel trick that you have tried, but by lowering the top of the frame you can grab the space consumed by the non-existent caption. Something like this:
tNoCaptionRadioBox = class(TRadioGroup)
protected
procedure paint; override;
end;
procedure tNoCaptionRadioBox.paint;
var
H: Integer;
R: TRect;
begin
with Canvas do
begin
Font := Self.Font;
H := TextHeight('0');
R := Rect(0, H, Width, Height);
if Ctl3D then
begin
Inc(R.Left);
Inc(R.Top);
Brush.Color := clBtnHighlight;
FrameRect(R);
OffsetRect(R, -1, -1);
Brush.Color := clBtnShadow;
end else
Brush.Color := clWindowFrame;
FrameRect(R);
end;
end;
This is taken from the code for painting a TCustomGroupBox. I have removed the code for drawing the caption and have changed the top of the frame to the full height of the Font. Your actual captioned radio buttons will still be drawn where Windows wants them to be and with the default spacing.
Remember to register the new component by running the package installation tool.
procedure Register;
begin
RegisterComponents('myComponents', [tNoCaptionRadioBox]);
end;

How do I display opaque text on a translucent window?

Can you give me the names of the functions needed for this purpose? I'm using Delphi XE 5. I want to get this effect:
Window: half transparent
Font: fully visible.
I will use "System" font (zero problems with AA)
What do I look on MSDN? What functions (name) do I need to use?
This is basically the same idea as in Marcus' answer, but with some enhancements. You might have to adjust this to your needs, but the principle is the following:
Create form1 with the following properties:
AlphaBlend := True;
AlphaBlendValue := 128;
BorderStyle := bsNone;
Create form2 with the controls as desired and the following properties:
Color := clFuchsia; // or whatever color is not used
TransparentColor := true;
TransparentColorValue := Color;
Declare a Boolean field in form1 named AllowMove.
In TForm1.FormShow call the following code:
begin
form2.BorderStyle := bsNone;
form2.SetBounds(0, 0, ClientWidth, ClientHeight);
form2.Show;
AllowMove := true;
end;
Declare a Boolean field in form1 named AllowMove and a message handler for WM_MOVE:
procedure WMMOVE(var Message: TMessage); message WM_MOVE;
procedure TForm1.WMMOVE(var Message: TMessage);
begin
inherited;
if AllowMove then begin
Form2.Left := Message.LParamLo;
Form2.Top := Message.LParamHi;
end;
Message.Result := 0;
end;
The only way that I know to get that kind of effect is to render the window contents to an in-memory bitmap, then apply the desired alpha values to the non-font pixels, and then use UpdateLayeredWindow() to display the bitmap on a window. You cannot achieve that affect with a TForm as it relies on SetLayeredWindowAttributes() instead.
Create a 32bit bitmap and draw the desired background on it with alpha values, using a separate array to keep track of the current pixel values in the spots you are going to draw text on, then draw the actual text and use the array to detect which pixels were changed so you can clear the alpha values from just those pixels. Then display the bitmap.
You can get something close by layering two forms over each other. Set the bottom form's color to blue, enable AlphaBlend, and set AlphaBlend to something like 100. That just provides the blue background.
On second form, set TransparentColor to clBtnFace, and put your label there. Set the label font's quality to fqAntialiased.
Set both form's BorderStyle to bsNone.
Lay the second form over the first form, and there you go.
This might be workable if you don't plan on letting the user move the forms, or you move them together.

Draw/overlay a rectangle box on top of application and capture mouse XY

I have a CAD application I am trying to build a plugin for and I need to be able to select lines and arcs. I cannot directly do this from the application. In my code I want to start drawing a windowing rectangle just free hand with the mouse. Through API I can determine what lines/arcs were enclosed in the rectangle that was just drawn.
The question is, how can I just draw a rectangle from my mouse on top of another application? A left click to start the upper left corner, drag to resize, and then releasing the left click to end the rectangle? There's not really an forms involved either, so I don't know if I can use a picturebox/TCanvas or what. To me, this is like a windowing screen capture where you draw a rectangle over the part of the screen you want to save.
I used to XOR draw a rectangle as proposed by fduenas and it works quite well, but this does not work smoothly on Windows Vista and 7. Also the rectangle may get partially erased if you draw over changing areas (and pieces of the rectangle will remain if you erase it afterwards).
Instead I now use a rectangular window with a rectangular hole in it. All you have to do is reposition the window. You can create and show it in MouseDown, reposition it in MouseMove and destroy it in MouseUp.
Set BorderStyle of TDragRectangleForm to bsNone.
unit FrmDragRectangle;
// TDragRectangleForm is a rectangular window with a rectangular hole.
// Only its dotted border is visible.
interface
uses
Windows, Forms, Graphics, Classes;
type
TDragRectangleForm = class( TForm )
procedure FormResize( Sender : TObject );
public
procedure Show;
end;
implementation
{$R *.dfm}
procedure TDragRectangleForm.Show;
begin
// Show the window without stealing the focus from another window:
ShowWindow( Handle , SW_SHOWNOACTIVATE );
Visible := True;
end;
procedure TDragRectangleForm.FormResize( Sender : TObject );
const
nBorderWidth = 1;
var
hrgnRect1 , hrgnRect2 : HRGN;
begin
// Make a rectangular hole in the window:
hrgnRect1 := CreateRectRgn( 0 , 0 , Width , Height );
hrgnRect2 := CreateRectRgn( nBorderWidth , nBorderWidth , Width - nBorderWidth , Height - nBorderWidth );
CombineRgn( hrgnRect1 , hrgnRect1 , hrgnRect2 , RGN_DIFF );
SetWindowRgn( Handle , hrgnRect1 , True );
DeleteObject( hrgnRect2 );
Canvas.Pen.Style := psDot;
Canvas.Pen.Color := clWhite;
Canvas.Brush.Color := clBlack;
Canvas.Rectangle( 0 , 0 , Width , Height );
end;
end.
Regarding your last question in the comment section about "How you can draw a rectangle on the screen?":
You have to get the handle of the current Desktop with something like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
fCanvas := TCanvas.Create;
fCanvas.Handle := GetWindowDC(0); //or CreateDC('DISPLAY', nil, nil, nil);
end;
NOTE: fCanvas is declared as a field of TForm1, Example:
Type
Tform1=Class(tForm)
...
...
protected
fCanvas: TCanvas
End;
Remember you have to free the fCanvas when destroying the TForm1
procedure TForm1.FormDestroy(Sender: TObject);
begin
fCanvas.Free;
end;
A complete example could be checked here:
Its done in an old version of Delphi but it should work
http://www.delphitricks.com/source-code/graphic/draw_directly_to_the_desktop.html
Also in DelphiForFun is a practical example of how to Draw a rectangle over the screen
http://www.delphiforfun.org/Programs/Delphi_Techniques/Canvas_Drawing.htm
Also in DelphiForfun are examples of how you can create your own drawing program for what you want to achieve.
Check:
1) Computational geometry: http://www.delphiforfun.org/Programs/Library/geometry1.htm (excellent example of canvas drawing with the mouse)
2) Graph searching: http://www.delphiforfun.org/Programs/Library/Graphs1.htm
BTW just to clarify, you say you're developing a plugin, so:
a) is the CAD application a 3rt party one? if it so then maybe your CAD program has already an API interface to manage plugins that interact with the ViewPort so there should be a way you can get the canvas reference of the Map viewer and also method to do the drawing of shapes.
b) Do you develope the CAD application? then if you want to add this as a plugin then you should design your API structure so when registering the plugin you can also add a way that plugin can access to the canvas of the ViewPort
JEDI VCL has some Plugin System components (TJvPlugin and TJvPluginManager) to help you build a plugin framework for your application with very easy steps.

How to adjust a TrackBar thumb size?

I can't adjust a TTrackBar thumb size to a higher size. See the image:
I got a small thumb on the left, and I can't make it bigger (but not the TrackBar itself).
Desired thumb size is shown on an image with a red area.
Maybe I can use WINAPI somehow?
C++ apps have bigger thumb often.
This is what I'm actually hopping for:
It would seem like this cannot be done with the standard trackbar control. Indeed, I cannot see any trackbar style or trackbar message related to this. There is only the TBM_SETTHUMBLENGTH, which you also can access from VCL's TTrackBar.ThumbLength, but this also affects the height of the background sunken rectangle.
A corollory is that I doubt the observation that "C++ apps have bigger thumb often".
Of course, you can always make your own trackbar-like control.
Or do you only want to shrink the sunken rectangle? Then just set ShowSelRange to False in the Object Inspector. But if themes are on, you still cannot make the thumb bigger than about 24.
If you are on an old version of Delphi with no TrackBar.ShowSelRange, you need to remove the window style TBS_ENABLESELRANGE manually. You can do this at any time using SetWindowLong, or you can do it in CreateParams of a subclassed trackbar control. The simplest way might be to use an 'interposer class':
type
TTrackBar = class(ComCtrls.TTrackBar)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
...
implementation
{ TTrackBar }
procedure TTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;
To get the appearance in the Notepad++ screenshot, you should also set TickMarks to tmBoth and TickStyle to tsNone.
This doesn't answer your question, though, which was about making the thumb larger. This will make the sunken rectangle smaller... From your screenshots, however, I would guess this is what you want.
Trackbar is one of the native controls that support custom draw. Basically, when themes are enabled, you can control various aspects of drawing the control, or you can tell the OS that you're overtaking drawing parts yourself. See more about custom draw here.
We don't have to overtake any drawing to play with the sizes of some parts a little bit. It is the VCL that draws the channel (the recessed tracking background), and the ticks. For ticks, there are already properties we can use. For the channel, we can deflate the rectangle a bit, and the VCL will take over from there. The thumb is drawn by the default window procedure, but it doesn't matter, the OS will draw the thumb to the modified rectangle.
The below example (for a horizontal trackbar) intercepts WM_NOTIFY notification sent to the form to carry out these modifications. This will only work if the trackbar is placed directly on the form. If this is not the case, you can derive a new control that descends from TTrackBar to handle CN_NOTIFY, or subclass the control, or its parent for WM_NOTIFY. All that matters is to handle the notification before the actual drawing is performed.
This is how the example looks:
type
TForm1 = class(TForm)
Button1: TButton;
TrackBar1: TTrackBar;
procedure FormCreate(Sender: TObject);
protected
procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
end;
...
uses
themes, commctrl, xpman;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
if ThemeServices.ThemesEnabled and
(TrackBar1.Orientation = trHorizontal) then begin
TrackBar1.TickMarks := tmBoth;
TrackBar1.TickStyle := tsNone;
TrackBar1.ThumbLength := 38;
end;
end;
procedure TForm1.WMNotify(var Msg: TWMNotify);
begin
if ThemeServices.ThemesEnabled and
(TrackBar1.Orientation = trHorizontal) then begin
if (Msg.IDCtrl = Longint(TrackBar1.Handle)) and
(Msg.NMHdr.code = NM_CUSTOMDRAW) and
(PNMCustomDraw(Msg.NMHdr).dwDrawStage = CDDS_ITEMPREPAINT) then begin
case PNMCustomDraw(Msg.NMHdr).dwItemSpec of
TBCD_THUMB: InflateRect(PNMCustomDraw(Msg.NMHdr).rc, -4, 0);
TBCD_CHANNEL:
with PNMCustomDraw(Msg.NMHdr).rc do begin
Top := Bottom div 2 + 2;
Bottom := Top + 5;
Inc(Left, 4);
Dec(Right, 4);
end;
end;
end;
end;
inherited;
end;

Resources