I'm attempting to switch from using Toolbar2000 to the regular toolbar because there doesn't seem to be a Delphi XE2 version and it looks like it uses some Assembly and I just don't really want to deal with it if I don't have to. (and I really like the fade-in effect with the Delphi Toolbar)
But, what I don't like is that the background of the button gets the regular blueish button treatment. I know how to change the color, but can I just not make the color change and not have a border painted around the button?
I've implemented the 'OnAdvancedCustomDrawButton' but the flags available don't seem to work right and I'm not sure how they interact with the gradient color and the hot track color and I wind up having some weird flashing or weird black backgrounds.
Here's how I'm creating the Toolbar
ToolBar1 := TToolBar.Create(Self);
ToolBar1.DoubleBuffered := true;
ToolBar1.OnAdvancedCustomDrawButton := Toolbar1CustomDrawButton;
ToolBar1.Transparent := false;
ToolBar1.Parent := Self;
ToolBar1.GradientEndColor := $7ca0c2; //RGB(194, 160, 124);
ToolBar1.GradientStartColor := $edeeed; //RGB(237, 238, 124);
ToolBar1.Indent := 5;
ToolBar1.Images := Normal;
ToolBar1.DrawingStyle := dsGradient;
ToolBar1.HotImages := Over;
ToolBar1.AutoSize := True;
ToolBar1.Visible := False;
and here's how I'm creating the buttons (in a loop):
ToolButton := TToolButton.Create(ToolBar1);
ToolButton.Parent := ToolBar1;
ToolButton.ImageIndex := ToolButtonImages[Index].ImageIndex;
ToolButton.OnClick := ToolButtonClick;
and here's my AdvancedCustomDrawButton function
procedure TMyForm.Toolbar1CustomDrawButton(Sender: TToolBar; Button: TToolButton;
State: TCustomDrawState; Stage: TCustomDrawStage;
var Flags: TTBCustomDrawFlags; var DefaultDraw: Boolean);
begin
Flags := [tbNoEdges, tbNoOffset];
DefaultDraw := True;
end;
Set drawing style of the toolbar to dsNormal and set Flags to [tbNoEdges] in custom draw handler.
update:
While the above works for 2K and XP, Vista and 7 seem to not to draw the border when button background is not drawn. Unfortunately achieving this with the VCL supplied TTBCustomDrawFlags is impossible, so we cannot get rid of the borders in a custom drawing handler.
If the toolbar is on the form itself we can put a handler for WM_NOTIFY since notification messages are sent to the parent window:
type
TForm1 = class(TForm)
..
private
procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
..
..
procedure TForm1.WMNotify(var Msg: TWMNotify);
begin
inherited;
if (Msg.NMHdr.code = NM_CUSTOMDRAW) and
Assigned(Toolbar1) and (Toolbar1.HandleAllocated) and
(Msg.NMHdr.hwndFrom = ToolBar1.Handle) then
case PNMTBCustomDraw(Msg.NMHdr).nmcd.dwDrawStage of
CDDS_PREPAINT: Msg.Result := Msg.Result or CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: Msg.Result := TBCDRF_NOEDGES or TBCDRF_NOBACKGROUND;
// NOEDGES for 2K, XP, // NOBACKGROUND for Vista 7
end;
end;
If the toolbar is parented in another window, like a panel, then we need to subclass the toolbar:
type
TForm1 = class(TForm)
..
private
FSaveToolbarWndProc: TWndMethod;
procedure ToolbarWndProc(var Msg: TMessage);
..
..
uses
commctrl;
procedure TForm1.FormCreate(Sender: TObject);
begin
..
FSaveToolbarWndProc := ToolBar1.WindowProc;
ToolBar1.WindowProc := ToolbarWndProc;
end;
procedure TForm1.ToolbarWndProc(var Msg: TMessage);
begin
FSaveToolbarWndProc(Msg);
if (Msg.Msg = CN_NOTIFY) and
(TWMNotify(Msg).NMHdr.hwndFrom = ToolBar1.Handle) and
(TWMNotify(Msg).NMHdr.code = NM_CUSTOMDRAW) then begin
case PNMTBCustomDraw(TWmNotify(Msg).NMHdr)^.nmcd.dwDrawStage of
CDDS_PREPAINT: Msg.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: Msg.Result := TBCDRF_NOEDGES or TBCDRF_NOBACKGROUND;
end;
end;
end;
(Note that drawing style still needs to be dsNormal.)
With this solution you don't need to put a handler for custom drawing. But if you need/want to anyway, you might need to 'or' the Msg.Result with the one VCL's window procedure returns, i.e the 'case' would look like:
CDDS_PREPAINT: Msg.Result := Msg.Result or CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: Msg.Result :=
Msg.Result or TBCDRF_NOEDGES or TBCDRF_NOBACKGROUND;
same goes for when we handle WM_NOTIFY on the form.
There may be other ways to achieve the same, custom drawing is a broad topic. If you want to delve into it, I suggest you to start from the links below for the problem at hand:
About Custom Draw
NM_CUSTOMDRAW (toolbar) notification code
NMCUSTOMDRAW structure
NMTBCUSTOMDRAW structure
Related
Need a component derived from TMemo (not TSyn components)
I need a line to the left(inside or outside) of a TMemo whose thickness(optional) and color can be controlled just for the purposes of indication. It need not be functional as a gutter but looks like one especially like that of a SynMemo as shown in the image. The problem with SynMemo is that it doesn't support variable width fonts like Tahoma but the TMemo does.
I tried making a few composite components with CustomContainersPack by combining a TShape with TMemo, even superimposing a TMemo on top of TSynMemo but didn't succeed as the paint while dragging made it look disassembled and CCPack is not that robust for my IDE.
KMemo, JvMemo and many other Torry.net components were installed and checked for any hidden support for achieving the same but none worked.
Grouping of components together is also not a solution for me since many mouse events are tied to the Memo and calls to FindVCLWindow will return changing components under the mouse. Furthermore many components will be required so grouping with TPanel will up the memory usage.
You can use the WM_Paint message and a hack to do this without creating a new component,
Otherwise create a descendant of TMemo and apply the same changes below
TMemo = class(Vcl.StdCtrls.TMemo)
private
FSidecolor: TColor;
FSideColorWidth: Integer;
FAskForAttention: Boolean;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetSideColorWidth(const Value: Integer);
procedure SetSideColor(const Value: TColor);
procedure SetAskForAttention(const Value: Boolean);
published
property SideColor: TColor read FSideColor write SetSideColor default clRed;
property SideColorWidth: Integer read FSideColorWidth write SetSideColorWidth default 2;
property AskForAttension: Boolean read FAskForAttention write SetAskForAttention;
end;
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
begin
FAskForAttention := Value;
Invalidate;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
FSideColor := Value;
Invalidate;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
begin
FSideColorWidth := Value;
Invalidate;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
DC: HDC;
Pen: HPen;
R,G,B: Byte;
begin
inherited;
if FAskForAttention then
begin
DC := GetWindowDC(Handle);
try
B := Byte(FSidecolor);
G := Byte(FSidecolor shr 8);
R := Byte(FSidecolor shr 16);
Pen := CreatePen(PS_SOLID, FSideColorWidth, RGB(R,G,B));
SelectObject(DC, Pen);
SetBkColor(DC, RGB(R,G,B));
Rectangle(DC, 1, 1, FSideColorWidth, Height - 1);
DeleteObject(Pen);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
And you can use it like this
procedure TForm15.Button1Click(Sender: TObject);
begin
memo1.SideColor := ColorBox1.Selected;
memo1.SideColorWidth := 2;
memo1.AskForAttension := True;
end;
and you get this result
Limitations:
As this is merely another hack to draw a simple rectangle on the side, do not expect it to be perfect on all situations. I did notice the following when testing:
If the border is too thick you get the following effect
When on mouse move the line sometimes disappear and don't get painted (I think it is because of drawing focus rect).
Note: I see the guys in comments suggested to create a custom component with panel and memo put together, If you want to try this, take a look at my answer to
Creating a new components by combining two controls (TEdit and TTrackBar) in Delphi VCL
It is basically the same Ideas.
Edit:
Ok I took into consideration what is mentioned in comments and adapted my answer,
I also changed the way I'm getting the canvas of the component. The new implementation becomes this
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
var
FormatRect: TRect;
begin
if FAskForAttention <> Value then
begin
FAskForAttention := Value;
if not FAskForAttention then
begin
Perform(EM_SETRECT, 0, nil);
end
else
begin
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
Invalidate;
end;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
if FSideColor <> Value then
begin
FSideColor := Value;
Invalidate;
end;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
var
FormatRect: TRect;
begin
if FSideColorWidth <> Value then
begin
FSideColorWidth := Value;
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
Canvas: TControlCanvas;
CRect: TRect;
begin
inherited;
if FAskForAttention then
begin
Canvas := TControlCanvas.Create;
try
Canvas.Control := Self;
Canvas.Font.Assign(Self.Font);
CRect := GetClientRect;
if IsRightToLeft then
CRect.Left := CRect.Right - FSideColorWidth
else
CRect.Width := FSideColorWidth;
Canvas.Brush.Color := FSidecolor;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(CRect);
finally
Canvas.Free;
end;
end;
end;
There is no limitations for the size and it does not overlap the scrollbars.
Final result:
References I used to write this answer:
MSDN Painting and Drawing Functions
MSDN Using the WM_PAINT Message
Creating Colored Pens and Brushes example
Vcl.Controls TWinControl WM_Paint message implementation
EM_SETRECT message
How can I get a TEdit's canvas in Delphi? (Kobik's answer)
Instead of writing a custom control, put a panel or a shape beside the standard memo and give it any colour you like.
If this is too tedious to repeat many times, then put the memo and the shape on a frame and put that in the repository. Set the anchors to make sure they resize correctly. You don't even need to write code for that and you have an instant "imitation custom control".
Much better and simpler than writing, installing and testing a custom control, IMO.
Now if you want to put text or numbers or icons in the gutter, then it would pay out to write a custom control. Use EM_SETRECT to set the internal formatting rectangle, and custom draw the gutter in the overridden Paint method. Do not forget to call inherited.
Is there a Windows API for setting up a custom cursor for the form's title bar, system menu icon and minimize, maximize and close buttons?
I'm having a function for loading and setting cursors for a given control:
type
TFrm_Main = class(TForm)
....
private
procedure SetCursor_For(AControl: TControl; ACursor_FileName: string;
Const ACurIndex: Integer);
...
end;
const
crOpenCursor = 1;
crRotateCursor = 2;
crCursor_Water = 3;
var
Frm_Main: TFrm_Main;
...
procedure TFrm_Main.SetCursor_For(AControl: TControl; ACursor_FileName:
string; const ACurIndex: Integer);
begin
Screen.Cursors[ACurIndex] := Loadcursorfromfile(PWideChar(ACursor_FileName));
AControl.Cursor := ACurIndex;
end;
And I'm using it this way for the form:
SetCursor_For(Frm_Main, 'Cursors\Cursor_Rotate.ani', crRotateCursor);
But I'm missing a way to setup cursor for particular form parts like form title bar, system menu icon and minimize, maximize and close buttons. Is there a way to set cursor for these form parts?
Handle the WM_SETCURSOR message and test the message parameter's HitTest field for one of the following hit test code values, and set the cursor by using SetCursor function returning True to the message Result (Windows API macros TRUE and FALSE coincidentally match to the Delphi's Boolean type values, so you can only typecast there):
HTCAPTION - Title bar
HTSYSMENU - System menu icon
HTMINBUTTON - Minimize button
HTMAXBUTTON - Maximize button
HTCLOSE - Close button
For example:
type
TForm1 = class(TForm)
private
procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
end;
implementation
procedure TForm1.WMSetCursor(var Msg: TWMSetCursor);
begin
case Msg.HitTest of
HTCAPTION:
begin
Msg.Result := LRESULT(True);
Winapi.Windows.SetCursor(Screen.Cursors[crHandPoint]);
end;
HTSYSMENU:
begin
Msg.Result := LRESULT(True);
Winapi.Windows.SetCursor(Screen.Cursors[crHelp]);
end;
HTMINBUTTON:
begin
Msg.Result := LRESULT(True);
Winapi.Windows.SetCursor(Screen.Cursors[crUpArrow]);
end;
HTMAXBUTTON:
begin
Msg.Result := LRESULT(True);
Winapi.Windows.SetCursor(Screen.Cursors[crSizeAll]);
end;
HTCLOSE:
begin
Msg.Result := LRESULT(True);
Winapi.Windows.SetCursor(Screen.Cursors[crNo]);
end;
else
inherited;
end;
end;
I'm trying to stop a TMemo (and also TRichEdit) control from eating Escape keys.
If the user is focused in a TEdit, pressing Escape will trigger the form to do what the form does when the user presses escape. If the user is focused in a TMemo, pressing escape is eaten by the TMemo.
Of course i could do the hack:
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
if Key = #27 then
begin
//figure out how to send a key to the form
end;
end;
But that is not ideal (i have to handle the escape key, rather than letting the form handle it).
Of course i could do the hack:
Form1.KeyPreview := True;
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #27 then
begin
//Figure out how to invoke what the form was going to do when the user presses escape
end;
end;
But that is not ideal (i have to handle the escape key, rather than letting the form handle it).
So we'll answer the question rather than the problem
Instead we'll take this opportunity to learn something. How is it that a TMemo is even receiving a keyPress event associated with the escape key, when a TEdit doesn't:
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if Key = #27 then
begin
//never happens
end;
end;
The TEdit and TMemo are the same Windows EDIT common control.
Why does escape bypass the form's KeyPreview
If i turn on the form's KeyPreview, and the user presses Escape while focused in a TEdit box, and a button's Cancel property is set, the form closes and:
the Edit1.KeyPress event is not triggered
the Form1.KeyPress event is not triggered
If an Action is created, whose Shortcut is Esc, then no KeyPress event is raised, no matter what control the user is focused in.
tl;dr: Where is the TMemo.WantEscape property?
The behaviour you observe is controlled by the handling of the WM_GETDLGCODE message. For a memo that looks like this:
procedure TCustomMemo.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
if FWantTabs then Message.Result := Message.Result or DLGC_WANTTAB
else Message.Result := Message.Result and not DLGC_WANTTAB;
if not FWantReturns then
Message.Result := Message.Result and not DLGC_WANTALLKEYS;
end;
For an edit control the VCL does not implement special handling for WM_GETDLGCODE and the underlying Windows edit control handles it.
In a standard Win32 app the Windows dialog manager sends the WM_GETDLGCODE messages. But Delphi is not built on top of the dialog manager, and so the VCL is in charge of sending WM_GETDLGCODE. It does so in the CN_KEYDOWN handler. The code looks like this:
Mask := 0;
case CharCode of
VK_TAB:
Mask := DLGC_WANTTAB;
VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
Mask := DLGC_WANTARROWS;
VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
Mask := DLGC_WANTALLKEYS;
end;
if (Mask <> 0) and
(Perform(CM_WANTSPECIALKEY, CharCode, 0) = 0) and
(Perform(WM_GETDLGCODE, 0, 0) and Mask = 0) and
(GetParentForm(Self).Perform(CM_DIALOGKEY,
CharCode, KeyData) <> 0) then Exit;
Notice that VK_RETURN, VK_EXECUTE, VK_ESCAPE and VK_CANCEL are all lumped together. This means that a VCL control has to decide whether or not to process these keys itself, or let the form handle them in its CM_DIALOGKEY handler.
As you can see from TCustomMemo.WMGetDlgCode you can influence that choice with the WantReturns property. So, you can persuade the VCL to let the form handle ESC by simply setting WantReturns on the memo to False. But that also stops the ENTER key reaching memo and makes it rather tricky for the user of the memo to enter new lines. They have to do it with CTRL + ENTER.
In fact WantReturns should really have been named WantReturnsAndEscapesAndExecutesAndCtrlBreaks. The VCL designers could have implemented a WantEscapes property but it's just not there.
So you are left handling it yourself one way or another. Personally, I do so with my own derived memo control. It overrides the KeyDown method and does this:
procedure TMyMemo.KeyDown(var Key: Word; Shift: TShiftState);
var
Form: TCustomForm;
Message: TCMDialogKey;
begin
inherited;
if (Key=VK_ESCAPE) and (Shift*[ssShift..ssCtrl])=[]) then begin
Form := GetParentForm(Self);
if Assigned(Form) then begin
// we need to dispatch this key press to the form so that it can 'press'
// any buttons with Cancel=True
Message.Msg := CM_DIALOGKEY;
Message.CharCode := VK_ESCAPE;
Message.KeyData := 0;
Message.Result := 0;
Form.Dispatch(Message);
end;
end;
end;
Another way to achieve this is to handle CM_WANTSPECIALKEY and WM_GETDLGCODE. Here's a crude interposer that illustrates the technique:
type
TMemo = class(StdCtrls.TMemo)
protected
procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
end;
procedure TMemo.CMWantSpecialKey(var Msg: TCMWantSpecialKey);
begin
case Msg.CharCode of
VK_ESCAPE:
Msg.Result := 0;
VK_RETURN, VK_EXECUTE, VK_CANCEL:
Msg.Result := 1;
else
inherited;
end;
end;
procedure TMemo.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
inherited;
Msg.Result := Msg.Result and not DLGC_WANTALLKEYS;
end;
Is it possible to remove a border of TabSheet (~4px)? I am using PageControl as a switch-panel instead of frames, windows etc. I want everything will be straight.
unit Unit1;
interface
uses
...,
CommCtrl;
type
TPageControl = class(ComCtrls.TPageControl)
private
procedure TCMAdjustRect(var Msg: TMessage); message TCM_ADJUSTRECT;
end;
TForm1 = class(TForm)
...
end;
...
procedure TPageControl.TCMAdjustRect(var Msg: TMessage);
begin
inherited;
if Msg.WParam = 0 then
InflateRect(PRect(Msg.LParam)^, 4, 4)
else
InflateRect(PRect(Msg.LParam)^, -4, -4);
end;
...
end.
If you don't mind using third-party tools then the easiest solution would probably be to use TjvPageControl from JVCL. It has ClientBorderWidth property which you are looking for.
An alternative is to use a TTabSet with a TPageControl: In the onCreate event of the form, place this code to hide the tab.
procedure TMainForm.FormCreate(Sender: TObject);
var
I : Integer;
begin
for I := 0 to Pred(PageControl1.PageCount) do
PageControl1.Pages[I].TabVisible := False;
PageControl1.Style := tsFlatButtons;
PageControl1.ActivePageIndex := 0;
TabSet1.Style := tsModernPopout;
TabSet1.SelectedColor := clMoneyGreen;
TabSet1.UnselectedColor := clGradientActiveCaption;
TabSet1.SelectedColor := clGradientActiveCaption;
end;
procedure TMainForm.TabSet1Change(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
begin
PageControl1.ActivePageIndex := NewTab;
end;
nowadays, that is the answer. No need any code hacks Probably you use themes, if not, you should use that technology:
Project Options > Application> Appearance
Check on one of them as Default Style) than :
Tools > Bitmap Style Designer > Open Style
Navigate your vsf style file
(probably right here
"C:\Users\Public\Documents\Embarcadero\Studio[VERSION]\Styles
Now In Bitmap Style Designer.. navigate to:
Objects > Tabs > Frame > Bitmap
Click [...] three dot button of Bitmap In Inspector
Zoom to 800%
Pan/Scroll and Focus on to bitmap rectangle range.
Right Mouse Click to change Upper-Left, Left Mouse Click to change Lower-Right
region.
(so select inner rectangle to eliminate border bitmap
now you have borderless page controls)
I use the following code to capture when the minimise button of my program is pressed so that I can hide the form from the taskbar, and as such minimise to the system tray.
procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
form1.Hide;
show1.Checked :=false;
hide1.Checked :=true;
end;
if (Msg.CmdType = SC_CLOSE) then form1.Close;
end;
I have had to put the capture in for the close button too as this code was preventing the program closing via the close button. What I need help with is how to fix dragging the program window by the caption bar which has stopped working with this code.
If you override the processing of a Windows message you need to take care to either handle all possible cases, or to call the inherited code for all unhandled cases:
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
Hide;
show1.Checked := False;
hide1.Checked := True;
Msg.Result := 0;
exit;
end;
inherited;
end;