I'm trying to emulate Outlook 2013 left pane tree view menu for my application. I'm using CustomDraw because I only want to change some simple font and background properties.
Here's what I want:
However, I always get the default selected drawing for both selected and hot tracked nodes. I don't have Windows 7 or XP to see if this is the normal behavior or if it's something related with my OS (Windows 8).
Here's what I'm getting:
Here's my code:
procedure TMainForm.TreeView1CustomDrawItem(Sender: TCustomTreeView;
Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
if Node.Level = 1 then
Sender.Canvas.Font.Size := Sender.Canvas.Font.Size + 2;
if cdsHot in State then
Sender.Canvas.Brush.Color := $00F7E6CD
else if (cdsSelected in State) or (cdsFocused in State) or
(cdsChecked in State) then
Sender.Canvas.Brush.Color := $00F2F2F2
else
Sender.Canvas.Brush.Color := $00DEDEDE;
DefaultDraw := true;
end;
How can I draw a different colored background for selected and hot items?
Try the following :
type
TTreeView = class(Vcl.ComCtrls.TTreeView)
protected
procedure CreateWnd; override;
end;
uses uxtheme;
procedure TTreeView.CreateWnd;
begin
inherited;
SetWindowTheme(Handle, nil , nil);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
TreeView1.Font.Name := 'Segoe UI';
TreeView1.HotTrack := True;
TreeView1.Font.Size := TreeView1.Font.Size + 1;
TreeView1.Color := $00DEDEDE;
end;
procedure TForm1.TreeView1CustomDrawItem(Sender: TCustomTreeView;
Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
if cdsFocused in State then begin
Sender.Canvas.Brush.Color := $00F2F2F2;
Sender.Canvas.Font.Color := clblack;
Sender.Canvas.Font.Style := Sender.Canvas.Font.Style + [fsBold];
end else if cdsHot in State then
Sender.Canvas.Brush.Color := $00F7E6CD
else
Sender.Canvas.Brush.Color := $00DEDEDE;
end;
Explanation:
The Microsoft documentation on this is incredibly fuzzy, what I can say with certainty is that whenever an action (Selection, Hot tracking , De-Selection etc...) is performed on an Item (Node), a specific message is sent, this message includes the state of the Node via the parameters flag which at the very end internally decides how the Item should be updated visually based on the current Windows Theme.
This is the probable cause as to why disabling themes for the TreeView component removes the default selection rectangle & theme coloring. The documentation for the Control state flags supports this theory in partial.
Related
I need to mark a TBitBtn (not TButton), that the button action requires elevation. I set ElevationRequired to True, but I do not get the shield icon.
To reproduce, place a TButton and a TBitBtn on a form:
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.ElevationRequired := True;
BitBtn1.ElevationRequired := True;
end;
Button1 is displayed with shield icon, BitBtn1 is not.
This is not possible.
A VCL TBitBtn is an owner-drawn Win32 BUTTON control. You can see that here:
procedure TBitBtn.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style := Style or BS_OWNERDRAW;
end;
Hence, a TBitBtn is not drawn by Windows but manually by the Pascal code in Vcl.Buttons.pas. Specifically, TBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct) does the painting.
And here you can see that there is no mentioning of ElevationRequired.
Hence, TBitBtn doesn't support this.
In general, don't use TBitBtn; use TButton to get the native Win32 button.
As ElevationRequired is not implemented for TBitBtn (see Andreas' answer). I ended up drawing the shield icon via this procedure (Vista+):
procedure MarkElevationRequired(ABitBtn: TBitBtn);
var
Icon: TIcon;
begin
Assert(Assigned(ABitBtn));
//---
try
Icon := TIcon.Create;
try
Icon.Handle := GetSystemIcon(SIID_SHIELD, TSystemIconSize.Small); //see WinApi.ShellApi
ABitBtn.Glyph.Assign(Icon);
finally
Icon.Free;
end;
except
//CreateSystemIcon throws an exception for <WinVista
end;
end;
with
/// Get system icon for SIID, see https://learn.microsoft.com/de-de/windows/win32/api/shellapi/ne-shellapi-shstockiconid
/// Works for Win Vista or better
/// see https://community.idera.com/developer-tools/b/blog/posts/using-windows-stock-icons-in-delphi
function GetSystemIcon(Id: integer; Size: TSystemIconSize = TSystemIconSize.Large;
Overlay: Boolean = False; Selected: Boolean = False): HICON;
var
Flags: Cardinal;
SSII: TSHStockIconInfo;
ResCode: HResult;
begin
if not TOSVersion.Check(6, 0) then
raise Exception.Create('SHGetStockIconInfo is only available in Win Vista or better.');
case Size of
TSystemIconSize.Large: Flags := SHGSI_ICON or SHGSI_LARGEICON;
TSystemIconSize.Small: Flags := SHGSI_ICON or SHGSI_SMALLICON;
TSystemIconSize.ShellSize: Flags := SHGSI_ICON or SHGSI_SHELLICONSIZE;
end;
if Selected then
Flags := Flags OR SHGSI_SELECTED;
if Overlay then
Flags := Flags OR SHGSI_LINKOVERLAY;
SSII.cbSize := SizeOf(SSII);
ResCode := SHGetStockIconInfo(Id, Flags, SSII);
if ResCode <> S_OK then
begin
if ResCode = E_INVALIDARG then
raise Exception.Create(
'The stock icon identifier [' + IntToStr(id) + '] is invalid')
else
raise Exception.Create(
'Error calling GetSystemIcon: ' + IntToStr(ResCode));
end
else
Result := SSII.hIcon;
end;
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.
I wrote a program that can identify outdated software in a Windows System and update them by interacting with the user.
It has a Software Updater Program which displays a System Tray Icon and show Balloon Tips about Available / Downloading Updates and Software installed in the System.
The problem is It can't show multiple Balloon Tips when each task is processing by it. Such as, when an update is available for a Software, it should remember user showing a balloon like An update for Software Name is available. and when user choose to download and minimize it to system tray again, the balloon tip should again show something like Updates are downloading...Click to view the Progress of Downloads.
However I like to know how can I do this by using only one System Tray Icon?
Can I use the NIM_MODIFY Flag again and again to change the Balloon Tip according to the current state of the Program?
I searched about this and I found some examples, but for Visual Studio and C++.
That's how I tried to show Multiple Tips when the Program is running:
unit MainForm-1;
...
const
NIF_INFO = $10;
NIF_MESSAGE = 1;
NIF_ICON = 2;
NOTIFYICON_VERSION = 3;
NIF_TIP = 4;
NIM_SETVERSION = $00000004;
NIM_SETFOCUS = $00000003;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
NIN_BALLOONSHOW = WM_USER + 2;
NIN_BALLOONHIDE = WM_USER + 3;
NIN_BALLOONTIMEOUT = WM_USER + 4;
NIN_BALLOONUSERCLICK = WM_USER + 5;
NIN_SELECT = WM_USER + 0;
NINF_KEY = $1;
NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
TRAY_CALLBACK = WM_USER + $7258;
PNewNotifyIconData = ^TNewNotifyIconData;
TDUMMYUNIONNAME = record
case Integer of
0: (uTimeout: UINT);
1: (uVersion: UINT);
end;
TNewNotifyIconData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array [0..127] of Char;
dwState: DWORD; /
dwStateMask: DWORD;
szInfo: array [0..255] of Char;
DUMMYUNIONNAME: TDUMMYUNIONNAME;
szInfoTitle: array [0..63] of Char;
dwInfoFlags: DWORD;
end;
type
MainForm-1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
IconData: TNewNotifyIconData;
procedure SysTrayIconMessageHandler(var Msg: TMessage); message TRAY_CALLBACK;
procedure AddSysTrayIcon;
procedure ShowBalloonTips;
procedure DeleteSysTrayIcon;
public
end;
var
MainForm-1: TForm;
implementation
uses
ShellAPI...,.....,;
procedure MainForm-1.SysTrayIconMessageHandler(var Msg: TMessage);
begin
case Msg.lParam of
WM_MOUSEMOVE:;
WM_LBUTTONDOWN:;
WM_LBUTTONUP:;
WM_LBUTTONDBLCLK:;
WM_RBUTTONDOWN:;
WM_RBUTTONUP:;
WM_RBUTTONDBLCLK:;
NIN_BALLOONSHOW:;
NIN_BALLOONHIDE:;
NIN_BALLOONTIMEOUT:
NIN_BALLOONUSERCLICK:;
end;
end;
procedure MainForm-1.AddSysTrayIcon;
begin
IconData.cbSize := SizeOf(IconData);
IconData.Wnd := AllocateHWnd(SysTrayIconMessageHandler);
IconData.uID := 0;
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK;
IconData.hIcon := Application.Icon.Handle;
IconData.szTip := 'Software Updater is running';
if not Shell_NotifyIcon(NIM_ADD, #IconData) then
ShowMessage('System Tray Icon cannot be created.');
end;
procedure MainForm-1.DisplayBalloonTips;
var
TipInfo, TipTitle: string;
begin
IconData.cbSize := SizeOf(IconData);
IconData.uFlags := NIF_INFO;
if ssHelperState = UpdatesAvailable then TipInfo := 'Updates are available to the programs installed on your Computer' + ' Click to see details.';
if ssHelperState = UpdatesDownloading then TipInfo := 'Updates are downloading in the background. Click to view the details.';
strPLCopy(IconData.szInfo, TipInfo, SizeOf(IconData.szInfo) - 1);
IconData.DUMMYUNIONNAME.uTimeout := 2500;
if ssHelperState = UpdatesAvailable then TipTitle := 'Updates are Available...';
if ssHelperState = UpdatesDownloading then TipTitle := 'Downloading the Updates...';
strPLCopy(IconData.szInfoTitle, TipTitle, SizeOf(IconData.szInfoTitle) - 1);
IconData.dwInfoFlags := NIIF_INFO;
Shell_NotifyIcon(NIM_MODIFY, #IconData);
{Following code is for testing purpose.}
IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;
if not Shell_NotifyIcon(NIM_SETVERSION, #IconData) then
ShowMessage('Setting the Version is Failed.');
end;
procedure MainForm-1.DeleteSysTrayIcon;
begin
DeallocateHWnd(IconData.Wnd);
if not Shell_NotifyIcon(NIM_DELETE, #IconData) then
ShowMessage('Unable to delete System Tray Icon.');
end;
procedure MainForm-1.FormCreate(Sender: TObject);
begin
AddSysTrayIcon;
ShowBalloonTips;
end;
procedure MainForm-1.FormDestroy(Sender: TObject);
begin
DeleteSysTrayIcon;
end;
...
end.
But, this is failing and I keep getting the same Balloon Tip (First One) again and again when the Program is running.......
I don't know how to use NIN_BALLOONSHOW and NIN_BALLOONHIDE Flags correctly. So, Thanks in Advance for Your Important Help.
Why are you declaring everything manually? Delphi 2009 already has declarations for the Shell_NotifyIcon() API. They are in the ShellAPI unit. It declares just about everything you are trying to use, except for the uVersion field (that was added in Delphi 2010). You are not using the guidItem and hBalloonIcon fields, so let's not worry about them here. The uTimeout field exists, and since it is wrapped in a union with uVersion, the data size does not change, so you can just use uTimeout when you want to use uVersion (or you can define your own union and type-cast the field, but that is overkill). You certainly do not need to redeclare the entire API.
You are reusing the same IconData variable each time you call Shell_NotifyIcon(), which is fine, but you are not clearing the szTip and szInfoTitle fields if your helper state is not UpdatesAvailable or UpdatesDownloading, so the tray icon keeps displaying the last tip/balloon you have set. You need to clear those fields when you don't need tips/balloons anymore.
NIN_BALLOONSHOW and NIN_BALLOONHIDE are not flags. They are notifications that are sent to your tray icon's registered HWND. To receive the notifications, you need to fill in the Wnd and uCallbackMessage fields and enable the NIF_MESSAGE flag.
Also, you need to handle the WM_TASKBARCREATED message. If Explorer gets restarted for any reason (crashes, or is killed by the user), the Taskbar gets re-created, so you have to re-add your tray icon again.
Also, make sure your message handler passes any unhandled window messages to DefWindowProc(), or you can lock up the system, or at least your app.
And lastly, Delphi 2009 is a Unicode version of Delphi, but there are some sections of your code that are not handling Unicode correctly. Specifically, when populating szTip and szInfoTitle using StrPLCopy(), you need to use Length() instead of SizeOf(). The copy is expressed in number of characters, not number of bytes.
With that said, try something more like this:
unit MainForm1;
interface
uses
..., ShellAPI;
type
eHelperState = (Idle, UpdatesAvailable, UpdatesDownloading);
MainForm = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
TaskbarCreatedMsg: UINT;
IconData: NOTIFYICONDATA;
IconAdded: Boolean;
ssHelperState: eHelperState;
procedure SysTrayIconMessageHandler(var Message: TMessage);
procedure AddSysTrayIcon;
procedure ShowBalloonTips;
procedure DeleteSysTrayIcon;
procedures SetHelperState(NewState: eHelperState);
...
end;
var
MainForm: TForm;
implementation
const
TRAY_CALLBACK = WM_USER + $7258;
{$IF RTLVersion < 21}
NOTIFYICON_VERSION_4 = 4;
{$IFEND}
procedure MainForm.FormCreate(Sender: TObject);
begin
TaskbarCreatedMsg := RegisterWindowMessage('TaskbarCreated');
IconData.cbSize := SizeOf(IconData);
IconData.Wnd := AllocateHWnd(SysTrayIconMessageHandler);
IconData.uID := 1;
AddSysTrayIcon;
end;
procedure MainForm.FormDestroy(Sender: TObject);
begin
DeleteSysTrayIcon;
DeallocateHWnd(IconData.Wnd);
end;
procedure MainForm.AddSysTrayIcon;
begin
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK;
IconData.hIcon := Application.Icon.Handle;
StrLCopy(IconData.szTip, 'Software Updater is running', Length(IconData.szTip));
IconAdded := Shell_NotifyIcon(NIM_ADD, #IconData);
if not IconAdded then
begin
ShowMessage('Unable to add System Tray Icon.');
Exit;
end;
if CheckWin32Version(5, 0) then
begin
IconData.{$IF RTLVersion >= 21}uVersion{$ELSE}uTimeout{$IFEND} := NOTIFYICON_VERSION_4;
if not Shell_NotifyIcon(NIM_SETVERSION, #IconData) then
ShowMessage('Unable to set version for System Tray Icon.');
end;
end;
procedure MainForm.DisplayBalloonTips;
var
Tip, InfoText, InfoTitle: string;
begin
if not IconAdded then Exit;
case ssHelperState of
UpdatesAvailable: begin
Tip := 'Updates are Available. Click to see details.';
InfoText := 'Updates are available to the programs installed on your Computer. Click to see details.';
InfoTitle := 'Updates are Available';
end;
UpdatesDownloading: begin
Tip := 'Downloading Updates. Click to see details.';
InfoText := 'Updates are downloading in the background. Click to see details.';
InfoTitle := 'Downloading Updates';
end;
else
Tip := 'Software Updater is running';
end;
IconData.uFlags := NIF_TIP or NIF_INFO;
StrPLCopy(IconData.szTip, Tip, Length(IconData.szTip));
StrPLCopy(IconData.szInfo, InfoText, Length(IconData.szInfo));
StrPLCopy(IconData.szInfoTitle, InfoTitle, Length(IconData.szInfoTitle));
IconData.uTimeout := 2500;
IconData.dwInfoFlags := NIIF_INFO;
if not Shell_NotifyIcon(NIM_MODIFY, #IconData) then
ShowMessage('Unable to update System Tray Icon.')
end;
procedure MainForm.DeleteSysTrayIcon;
begin
if IconAdded then
begin
IconAdded := False;
if not Shell_NotifyIcon(NIM_DELETE, #IconData) then
ShowMessage('Unable to delete System Tray Icon.');
end;
end;
procedures MainForm.SetHelperState(NewState: eHelperState);
begin
if ssHelperState <> NewState then
begin
ssHelperState := NewState;
DisplayBalloonTips;
end;
end;
procedure MainForm.SysTrayIconMessageHandler(var Message: TMessage);
begin
if Message.Msg = TRAY_CALLBACK then
begin
case LOWORD(Message.LParam) of
WM_MOUSEMOVE: begin
//...
end;
WM_LBUTTONDBLCLK,
NIN_BALLOONUSERCLICK: begin
// display status window...
end;
WM_CONTEXTMENU,
NIN_KEYSELECT,
NIN_SELECT: begin
// display popup menu at coordinates specified by Msg.WParam...
end;
NIN_BALLOONSHOW:;
NIN_BALLOONHIDE:;
NIN_BALLOONTIMEOUT:;
end;
end
else if (Message.Msg = TaskbarCreatedMsg) and (TaskbarCreatedMsg <> 0) then
begin
IconAdded := False;
AddSysTrayIcon;
DisplayBalloonTips;
end
else begin
Message.Result := DefWindowProc(IconData.Wnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
...
end.
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
Is there a feature in the Listview control to shift items up and down?
Not having worked with TListView very much (I mostly use database grids), I took your question as a chance to learn something. The following code is the result, it is more visually oriented that David's answer. It has some limitations: it will only move the first selected item, and while it moves the item, the display for vsIcon and vsSmallIcon is strange after the move.
procedure TForm1.btnDownClick(Sender: TObject);
var
Index: integer;
temp : TListItem;
begin
// use a button that cannot get focus, such as TSpeedButton
if ListView1.Focused then
if ListView1.SelCount>0 then
begin
Index := ListView1.Selected.Index;
if Index<ListView1.Items.Count then
begin
temp := ListView1.Items.Insert(Index+2);
temp.Assign(ListView1.Items.Item[Index]);
ListView1.Items.Delete(Index);
// fix display so moved item is selected/focused
ListView1.Selected := temp;
ListView1.ItemFocused := temp;
end;
end;
end;
procedure TForm1.btnUpClick(Sender: TObject);
var
Index: integer;
temp : TListItem;
begin
// use a button that cannot get focus, such as TSpeedButton
if ListView1.Focused then
if ListView1.SelCount>0 then
begin
Index := ListView1.Selected.Index;
if Index>0 then
begin
temp := ListView1.Items.Insert(Index-1);
temp.Assign(ListView1.Items.Item[Index+1]);
ListView1.Items.Delete(Index+1);
// fix display so moved item is selected/focused
ListView1.Selected := temp;
ListView1.ItemFocused := temp;
end;
end;
end;
You have two options:
Delete them and then re-insert them at the new location.
Use a virtual list view and move them in your data structure.
My routine for doing the first of these options is like this:
procedure TBatchTaskList.MoveTasks(const Source: array of TListItem; Target: TListItem);
var
i, InsertIndex: Integer;
begin
Assert(IsMainThread);
BeginUpdate;
Try
//work out where to move them
if Assigned(Target) then begin
InsertIndex := FListItems.IndexOf(Target);
end else begin
InsertIndex := FListItems.Count;
end;
//create new items for each moved task
for i := 0 to high(Source) do begin
SetListItemValues(
FListItems.Insert(InsertIndex+i),
TBatchTask(Source[i].Data)
);
Source[i].Data := nil;//handover ownership to the new item
end;
//set selection and focus item to give feedback about the move
for i := 0 to high(Source) do begin
FListItems[InsertIndex+i].Selected := Source[i].Selected;
end;
FBatchList.ItemFocused := FListItems[InsertIndex];
//delete the duplicate source tasks
for i := 0 to high(Source) do begin
Source[i].Delete;
end;
Finally
EndUpdate;
End;
end;
The method SetListItemValues is used to populate the columns of the list view.
This is a perfect example of why virtual controls are so great.