close button of a tabsheet not supporting vcl styles - delphi

I have used the code provided in this example How to implement a close button for a TTabsheet of a TPageControl to draw a close button to each tabsheet of a pagecontrol and I have replaced ThemeServices with Style Services inside the code and when applying styles the close button doesn`t show and react in no way. Could anyone point me to a different path o solving this issue. thank you! this is the code of the OnDrawTab event:
procedure TFormMain.PageControlCloseButtonDrawTab(Control: TCustomTabControl;
TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
CloseBtnSize: Integer;
PageControl: TPageControl;
TabCaption: TPoint;
CloseBtnRect: TRect;
CloseBtnDrawState: Cardinal;
CloseBtnDrawDetails: TThemedElementDetails;
begin
PageControl := Control as TPageControl;
if InRange(TabIndex, 0, Length(FCloseButtonsRect) - 1) then
begin
CloseBtnSize := 14;
TabCaption.Y := Rect.Top + 3;
if Active then
begin
CloseBtnRect.Top := Rect.Top + 4;
CloseBtnRect.Right := Rect.Right - 5;
TabCaption.X := Rect.Left + 6;
end
else
begin
CloseBtnRect.Top := Rect.Top + 3;
CloseBtnRect.Right := Rect.Right - 5;
TabCaption.X := Rect.Left + 3;
end;
CloseBtnRect.Bottom := CloseBtnRect.Top + CloseBtnSize;
CloseBtnRect.Left := CloseBtnRect.Right - CloseBtnSize;
FCloseButtonsRect[TabIndex] := CloseBtnRect;
PageControl.Canvas.FillRect(Rect);
PageControl.Canvas.TextOut(TabCaption.X, TabCaption.Y, PageControl.Pages[TabIndex].Caption);
if not UseThemes then
begin
if (FCloseButtonMouseDownIndex = TabIndex) and FCloseButtonShowPushed then
CloseBtnDrawState := DFCS_CAPTIONCLOSE + DFCS_PUSHED
else
CloseBtnDrawState := DFCS_CAPTIONCLOSE;
Winapi.Windows.DrawFrameControl(PageControl.Canvas.Handle,
FCloseButtonsRect[TabIndex], DFC_CAPTION, CloseBtnDrawState);
end
else
begin
Dec(FCloseButtonsRect[TabIndex].Left);
if (FCloseButtonMouseDownIndex = TabIndex) and FCloseButtonShowPushed then
CloseBtnDrawDetails := StyleServices.GetElementDetails(twCloseButtonPushed)
else
CloseBtnDrawDetails := StyleServices.GetElementDetails(twCloseButtonNormal);
StyleServices.DrawElement(PageControl.Canvas.Handle, CloseBtnDrawDetails,
FCloseButtonsRect[TabIndex]);
end;
end;
end;

If you are using the vcl styles, you must write a vcl style hook to draw a close button in the tab controls, take a look to the Vcl.Styles.ColorTabs unit (introduced in these articles Creating colorful tabsheets with the VCL Styles, Added border to TTabColorControlStyleHook) to have an idea of what you need to write a style hook like this. Additional to the code to draw the button in the tabs you must handle the WM_MOUSEMOVE and WM_LBUTTONUP messages (in the style hook) to change the state of the button (normal, hot) and detect a click in the close button.
If you have problems implementing the style hook let me know to post a full solution here.
UPDATE
I just wrote this simple style hook to add suport for a close button in the tabsheets.
uses
Vcl.Styles,
Vcl.Themes;
type
TTabControlStyleHookBtnClose = class(TTabControlStyleHook)
private
FHotIndex : Integer;
FWidthModified : Boolean;
procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE;
procedure WMLButtonUp(var Message: TWMMouse); message WM_LBUTTONUP;
function GetButtonCloseRect(Index: Integer):TRect;
strict protected
procedure DrawTab(Canvas: TCanvas; Index: Integer); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
public
constructor Create(AControl: TWinControl); override;
end;
constructor TTabControlStyleHookBtnClose.Create(AControl: TWinControl);
begin
inherited;
FHotIndex:=-1;
FWidthModified:=False;
end;
procedure TTabControlStyleHookBtnClose.DrawTab(Canvas: TCanvas; Index: Integer);
var
Details : TThemedElementDetails;
ButtonR : TRect;
FButtonState: TThemedWindow;
begin
inherited;
if (FHotIndex>=0) and (Index=FHotIndex) then
FButtonState := twSmallCloseButtonHot
else
if Index = TabIndex then
FButtonState := twSmallCloseButtonNormal
else
FButtonState := twSmallCloseButtonDisabled;
Details := StyleServices.GetElementDetails(FButtonState);
ButtonR:= GetButtonCloseRect(Index);
if ButtonR.Bottom - ButtonR.Top > 0 then
StyleServices.DrawElement(Canvas.Handle, Details, ButtonR);
end;
procedure TTabControlStyleHookBtnClose.WMLButtonUp(var Message: TWMMouse);
Var
LPoint : TPoint;
LIndex : Integer;
begin
LPoint:=Message.Pos;
for LIndex := 0 to TabCount-1 do
if PtInRect(GetButtonCloseRect(LIndex), LPoint) then
begin
if Control is TPageControl then
begin
TPageControl(Control).Pages[LIndex].Parent:=nil;
TPageControl(Control).Pages[LIndex].Free;
end;
break;
end;
end;
procedure TTabControlStyleHookBtnClose.WMMouseMove(var Message: TMessage);
Var
LPoint : TPoint;
LIndex : Integer;
LHotIndex : Integer;
begin
inherited;
LHotIndex:=-1;
LPoint:=TWMMouseMove(Message).Pos;
for LIndex := 0 to TabCount-1 do
if PtInRect(GetButtonCloseRect(LIndex), LPoint) then
begin
LHotIndex:=LIndex;
break;
end;
if (FHotIndex<>LHotIndex) then
begin
FHotIndex:=LHotIndex;
Invalidate;
end;
end;
function TTabControlStyleHookBtnClose.GetButtonCloseRect(Index: Integer): TRect;
var
FButtonState: TThemedWindow;
Details : TThemedElementDetails;
R, ButtonR : TRect;
begin
R := TabRect[Index];
if R.Left < 0 then Exit;
if TabPosition in [tpTop, tpBottom] then
begin
if Index = TabIndex then
InflateRect(R, 0, 2);
end
else
if Index = TabIndex then
Dec(R.Left, 2)
else
Dec(R.Right, 2);
Result := R;
FButtonState := twSmallCloseButtonNormal;
Details := StyleServices.GetElementDetails(FButtonState);
if not StyleServices.GetElementContentRect(0, Details, Result, ButtonR) then
ButtonR := Rect(0, 0, 0, 0);
Result.Left :=Result.Right - (ButtonR.Width) - 5;
Result.Width:=ButtonR.Width;
end;
procedure TTabControlStyleHookBtnClose.MouseEnter;
begin
inherited;
FHotIndex := -1;
end;
procedure TTabControlStyleHookBtnClose.MouseLeave;
begin
inherited;
if FHotIndex >= 0 then
begin
FHotIndex := -1;
Invalidate;
end;
end;
Register in this way
TStyleManager.Engine.RegisterStyleHook(TCustomTabControl, TTabControlStyleHookBtnClose);
TStyleManager.Engine.RegisterStyleHook(TTabControl, TTabControlStyleHookBtnClose);
And this is a demo

Ive been working on this example, and i got it working on the Metro UI on delphi XE6.
My workaround for getting the correct distance between the Tab name and the button was to modify this line
Result.Left := Result.Right - (ButtonR.Width);
//it was Result.Left := Result.Right - (ButtonR.Width) -5;
And setting a bigger TabWith on the PageController properties.
Also ,remind that the "Register" lines, goes on the Initialization class right before the end of the unit.
//...all the code of the unit
Initialization
TStyleManager.Engine.RegisterStyleHook(TCustomTabControl,
TTabControlStyleHookBtnClose);
TStyleManager.Engine.RegisterStyleHook(TTabControl,
TTabControlStyleHookBtnClose);
end.//final unit "end" =D

Related

Caption Buttons not respond to mouse clicks after Non - Client painting with DWM in Delphi

I am painting my Application's non-client area with the help of Desktop Window Manager, adding a new button for testing purposes.
After compiling, my custom button is clickable, but the default caption buttons (Minimize, Maximize and Close) do nothing when I hover over them or click on them.
The repainted Title Bar responds to dragging and double-clicks. The Form
maximizes when I double-click the Title Bar as default. And the Close button responds to the very corner of it near Form's Right Border.
I have written my painting procedure as described in this post.
The new codes I added:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, Buttons;
type
TForm1 = class(TForm)
ImageList1: TImageList;
SpeedButton1: TSpeedButton;
function GetSysIconRect: TRect;
procedure PaintWindow(DC: HDC);
procedure InvalidateTitleBar;
procedure FormCreate(Sender: TObject);
procedure WndProc(var Message: TMessage);
procedure FormPaint(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
protected
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
procedure CMTextChanged(var Message: TMessage);
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP;
private
{ Private declarations }
FWndFrameSize: Integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
DWMAPI, CommCtrl, Themes, UXTheme, StdCtrls;
{$R *.dfm}
{$IF not Declared(UnicodeString)}
type
UnicodeString = WideString;
{$IFEND}
procedure DrawGlassCaption(Form: TForm; const Text: UnicodeString;
Color: TColor; var R: TRect; HorzAlignment: TAlignment = taLeftJustify;
VertAlignment: TTextLayout = tlCenter; ShowAccel: Boolean = False); overload;
const
BasicFormat = DT_SINGLELINE or DT_END_ELLIPSIS;
HorzFormat: array[TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);
VertFormat: array[TTextLayout] of UINT = (DT_TOP, DT_VCENTER, DT_BOTTOM);
AccelFormat: array[Boolean] of UINT = (DT_NOPREFIX, 0);
var
DTTOpts: TDTTOpts;
Element: TThemedWindow;
IsVistaAndMaximized: Boolean;
NCM: TNonClientMetrics;
ThemeData: HTHEME;
procedure DoTextOut;
begin
with ThemeServices.GetElementDetails(Element) do
DrawThemeTextEx(ThemeData, Form.Canvas.Handle, Part, State, PWideChar(Text),
Length(Text), BasicFormat or AccelFormat[ShowAccel] or
HorzFormat[HorzAlignment] or VertFormat[VertAlignment], #R, DTTOpts);
end;
begin
if Color = clNone then Exit;
IsVistaAndMaximized := (Form.WindowState = wsMaximized) and
(Win32MajorVersion = 6) and (Win32MinorVersion = 0);
ThemeData := OpenThemeData(0, 'CompositedWindow::Window');
Assert(ThemeData <> 0, SysErrorMessage(GetLastError));
Try
NCM.cbSize := SizeOf(NCM);
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, #NCM, 0) then
if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfSmCaptionFont)
else
Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfCaptionFont);
ZeroMemory(#DTTOpts, SizeOf(DTTOpts));
DTTOpts.dwSize := SizeOf(DTTOpts);
DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
if Color <> clDefault then
DTTOpts.crText := ColorToRGB(Color)
else if IsVistaAndMaximized then
DTTOpts.dwFlags := DTTOpts.dwFlags and not DTT_TEXTCOLOR
else if Form.Active then
DTTOpts.crText := GetSysColor(COLOR_CAPTIONTEXT)
else
DTTOpts.crText := GetSysColor(COLOR_INACTIVECAPTIONTEXT);
if not IsVistaAndMaximized then
begin
DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
DTTOpts.iGlowSize := 15;
end;
if Form.WindowState = wsMaximized then
if Form.Active then
Element := twMaxCaptionActive
else
Element := twMaxCaptionInactive
else if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
if Form.Active then
Element := twSmallCaptionActive
else
Element := twSmallCaptionInactive
else
if Form.Active then
Element := twCaptionActive
else
Element := twCaptionInactive;
DoTextOut;
if IsVistaAndMaximized then DoTextOut;
Finally
CloseThemeData(ThemeData);
end;
end;
function GetDwmBorderIconsRect(Form: TForm): TRect;
begin
if DwmGetWindowAttribute(Form.Handle, DWMWA_CAPTION_BUTTON_BOUNDS, #Result, SizeOf(Result)) <> S_OK then SetRectEmpty(Result);
end;
procedure DrawGlassCaption(Form: TForm; var R: TRect;
HorzAlignment: TAlignment = taLeftJustify; VertAlignment: TTextLayout = tlCenter;
ShowAccel: Boolean = False); overload;
begin
DrawGlassCaption(Form, Form.Caption, clDefault, R,
HorzAlignment, VertAlignment, ShowAccel);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
R: TRect;
begin
if DwmCompositionEnabled then
begin
SetRectEmpty(R);
AdjustWindowRectEx(R, GetWindowLong(Handle, GWL_STYLE), False,
GetWindowLong(Handle, GWL_EXSTYLE));
FWndFrameSize := R.Right;
GlassFrame.Top := -R.Top;
GlassFrame.Enabled := True;
SetWindowPos(Handle, 0, Left, Top, Width, Height, SWP_FRAMECHANGED);
DoubleBuffered := True;
end;
end;
procedure TForm1.InvalidateTitleBar;
var
R: TRect;
begin
if not HandleAllocated then Exit;
R.Left := 0;
R.Top := 0;
R.Right := Width;
R.Bottom := GlassFrame.Top;
InvalidateRect(Handle, #R, False);
end;
procedure TForm1.CMTextChanged(var Message: TMessage);
begin
inherited;
InvalidateTitleBar;
end;
procedure TForm1.WMActivate(var Message: TWMActivate);
begin
inherited;
InvalidateTitleBar;
end;
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
ClientPos: TPoint;
IconRect: TRect;
begin
inherited;
if not GlassFrame.Enabled then Exit;
case Message.Result of
HTCLIENT:
HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
begin
Message.Result := HTCAPTION;
Exit;
end;
else
Exit;
end;
ClientPos := ScreenToClient(Point(Message.XPos, Message.YPos));
if ClientPos.Y > GlassFrame.Top then Exit;
if ControlAtPos(ClientPos, True) <> nil then Exit;
IconRect := GetSysIconRect;
if (ClientPos.X < IconRect.Right) and ((WindowState = wsMaximized) or
((ClientPos.Y >= IconRect.Top) and (ClientPos.Y < IconRect.Bottom))) then
Message.Result := HTSYSMENU
else if ClientPos.Y < FWndFrameSize then
Message.Result := HTTOP
else
Message.Result := HTCAPTION;
end;
procedure ShowSystemMenu(Form: TForm; const Message: TWMNCRButtonUp);
var
Cmd: WPARAM;
Menu: HMENU;
procedure UpdateItem(ID: UINT; Enable: Boolean; MakeDefaultIfEnabled: Boolean = False);
const
Flags: array[Boolean] of UINT = (MF_GRAYED, MF_ENABLED);
begin
EnableMenuItem(Menu, ID, MF_BYCOMMAND or Flags[Enable]);
if MakeDefaultIfEnabled and Enable then
SetMenuDefaultItem(Menu, ID, MF_BYCOMMAND);
end;
begin
Menu := GetSystemMenu(Form.Handle, False);
if Form.BorderStyle in [bsSingle, bsSizeable, bsToolWindow, bsSizeToolWin] then
begin
SetMenuDefaultItem(Menu, UINT(-1), 0);
UpdateItem(SC_RESTORE, Form.WindowState <> wsNormal, True);
UpdateItem(SC_MOVE, Form.WindowState <> wsMaximized);
UpdateItem(SC_SIZE, (Form.WindowState <> wsMaximized) and
(Form.BorderStyle in [bsSizeable, bsSizeToolWin]));
UpdateItem(SC_MINIMIZE, (biMinimize in Form.BorderIcons) and
(Form.BorderStyle in [bsSingle, bsSizeable]));
UpdateItem(SC_MAXIMIZE, (biMaximize in Form.BorderIcons) and
(Form.BorderStyle in [bsSingle, bsSizeable]) and
(Form.WindowState <> wsMaximized), True);
end;
if Message.HitTest = HTSYSMENU then
SetMenuDefaultItem(Menu, SC_CLOSE, MF_BYCOMMAND);
Cmd := WPARAM(TrackPopupMenu(Menu, TPM_RETURNCMD or
GetSystemMetrics(SM_MENUDROPALIGNMENT), Message.XCursor,
Message.YCursor, 0, Form.Handle, nil));
PostMessage(Form.Handle, WM_SYSCOMMAND, Cmd, 0)
end;
procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
const
SWP_STATECHANGED = $8000;
begin
if GlassFrame.Enabled then
if (Message.WindowPos.flags and SWP_STATECHANGED) = SWP_STATECHANGED then
Invalidate
else
InvalidateTitleBar;
inherited;
end;
procedure TForm1.WMNCRButtonUp(var Message: TWMNCRButtonUp);
begin
if not GlassFrame.Enabled or not (biSystemMenu in BorderIcons) then
inherited
else
case Message.HitTest of
HTCAPTION, HTSYSMENU: ShowSystemMenu(Self, Message);
else
inherited;
end;
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if GlassFrame.Enabled and HandleAllocated and DwmDefWindowProc(Handle,
Message.Msg, Message.WParam, Message.LParam, Message.Result) then
Exit;
inherited;
end;
procedure TForm1.PaintWindow(DC: HDC);
begin
with GetClientRect do
ExcludeClipRect(DC, 0, GlassFrame.Top, Right, Bottom);
inherited;
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
IconHandle: HICON;
R: TRect;
begin
if ImageList1.Count = 0 then
begin
ImageList1.Width := GetSystemMetrics(SM_CXSMICON);
ImageList1.Height := GetSystemMetrics(SM_CYSMICON);
{$IF NOT DECLARED(TColorDepth)}
ImageList1.Handle := ImageList_Create(ImageList1.Width,
ImageList1.Height, ILC_COLOR32 or ILC_MASK, 1, 1);
{$IFEND}
IconHandle := Icon.Handle;
if IconHandle = 0 then IconHandle := Application.Icon.Handle;
ImageList_AddIcon(ImageList1.Handle, IconHandle);
end;
R := GetSysIconRect;
ImageList1.Draw(Canvas, R.Left, R.Top, 0);
R.Left := R.Right + FWndFrameSize - 3;
if WindowState = wsMaximized then
R.Top := FWndFrameSize
else
R.Top := 0;
R.Right := GetDwmBorderIconsRect(Self).Left - FWndFrameSize - 1;
R.Bottom := GlassFrame.Top;
DrawGlassCaption(Self, R);
end;
function TForm1.GetSysIconRect: TRect;
begin
if not (biSystemMenu in BorderIcons) or not (BorderStyle in [bsSingle, bsSizeable]) then
SetRectEmpty(Result)
else
begin
Result.Left := 0;
Result.Right := GetSystemMetrics(SM_CXSMICON);
Result.Bottom := GetSystemMetrics(SM_CYSMICON);
if WindowState = wsMaximized then
Result.Top := GlassFrame.Top - Result.Bottom - 2
else
Result.Top := 6;
Inc(Result.Bottom, Result.Top);
end;
end;
procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
if not GlassFrame.Enabled then
inherited
else
with Message.CalcSize_Params.rgrc[0] do
begin
Inc(Left, FWndFrameSize);
Dec(Right, FWndFrameSize);
Dec(Bottom, FWndFrameSize);
end;
end;
end.
Please help me find what is causing the Caption Buttons to become unresponsive to mouse clicks.
The standard buttons do not work because your WM_NCHITTEST handler is returning HTCAPTION for them. You are lying to Windows, telling it that the mouse is not over the buttons even if it really is. If the inherited handler returns HTMINBUTTON, HTMAXBUTTON, or HTCLOSE, just Exit without modifying the Message.Result:
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
ClientPos: TPoint;
IconRect: TRect;
begin
inherited;
if not GlassFrame.Enabled then Exit;
case Message.Result of
HTCLIENT:
HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
begin
//Message.Result := HTCAPTION; // <-- here
Exit;
end;
else
Exit;
end;
...
end;

Writing a custom property inspector - How to handle inplace editor focus when validating values?

Overview
I am trying to write my own simple property inspector but I am facing a difficult and rather confusing problem. First though let me say that my component is not meant to work with or handle component properties, instead it will allow adding custom values to it. The full source code of my component is further down the question and it should look something like this once you have installed it in a package and run it from a new empty project:
Problem (brief)
The issue is regarding the use of inplace editors and validating the property values. The idea is, if a property value is not valid then show a message to the user notifying them that the value cannot be accepted, then focus back to the row and inplace editor that was originally focused on.
We can actually use Delphi's very own Object Inspector to illustrate the behavior I am looking for, for example try writing a string in the Name property that cannot be accepted then click away from the Object Inspector. A message is shown and upon closing it, it will focus back to the Name row.
Source Code
The question becomes too vague without any code but due to the nature of the component I am trying to write it's also quite large. I have stripped it down as much as possible for the purpose of the question and example. I am sure there will be some comments asking me why I didn't do this or do that instead but it's important to know that I am no Delphi expert and often I make wrong decisions and choices but I am always willing to learn so all comments are welcomed, especially if it aids in finding my solution.
unit MyInspector;
interface
uses
Winapi.Windows,
Winapi.Messages,
System.Classes,
System.SysUtils,
Vcl.Controls,
Vcl.Dialogs,
Vcl.StdCtrls,
Vcl.Graphics,
Vcl.Forms;
type
TMyInspectorItems = class(TObject)
private
FPropertyNames: TStringList;
FPropertyValues: TStringList;
procedure AddItem(APropName, APropValue: string);
procedure Clear;
public
constructor Create;
destructor Destroy; override;
end;
TOnMouseMoveEvent = procedure(Sender: TObject; X, Y: Integer) of object;
TOnSelectRowEvent = procedure(Sender: TObject; PropName, PropValue: string; RowIndex: Integer) of object;
TMyCustomInspector = class(TGraphicControl)
private
FInspectorItems: TMyInspectorItems;
FOnMouseMove: TOnMouseMoveEvent;
FOnSelectRow: TOnSelectRowEvent;
FRowCount: Integer;
FNamesFont: TFont;
FValuesFont: TFont;
FSelectedRow: Integer;
procedure SetNamesFont(const AValue: TFont);
procedure SetValuesFont(const AValue: TFont);
procedure CalculateInspectorHeight;
function GetMousePosition: TPoint;
function MousePositionToRowIndex: Integer;
function RowIndexToMousePosition(ARowIndex: Integer): Integer;
function GetRowHeight: Integer;
function GetValueRowWidth: Integer;
function RowExists(ARowIndex: Integer): Boolean;
function IsRowSelected: Boolean;
protected
procedure Loaded; override;
procedure Paint; override;
procedure WMKeyDown(var Message: TMessage); message WM_KEYDOWN;
procedure WMMouseDown(var Message: TMessage); message WM_LBUTTONDOWN;
procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE;
procedure WMMouseUp(var Message: TMessage); message WM_LBUTTONUP;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function RowCount: Integer;
property Items: TMyInspectorItems read FInspectorItems write FInspectorItems;
property OnMouseMove: TOnMouseMoveEvent read FOnMouseMove write FOnMouseMove;
property OnSelectRow: TOnSelectRowEvent read FOnSelectRow write FOnSelectRow;
published
property Align;
end;
TMyPropertyInspector = class(TScrollBox)
private
FInspector: TMyCustomInspector;
FInplaceStringEditor: TEdit;
FSelectedRowName: string;
FLastSelectedRowName: string;
FLastSelectedRow: Integer;
function SetPropertyValue(RevertToPreviousValueOnFail: Boolean): Boolean;
procedure InplaceStringEditorEnter(Sender: TObject);
procedure InplaceStringEditorExit(Sender: TObject);
procedure InplaceStringEditorKeyPress(Sender: TObject; var Key: Char);
procedure SelectRow(Sender: TObject; PropName, PropValue: string; RowIndex: Integer);
function ValidateStringValue(Value: string): Boolean;
protected
procedure Loaded; override;
procedure WMSize(var Message: TMessage); message WM_SIZE;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AddItem(APropName, APropValue: string);
function GetSelectedPropertyName: string;
function GetSelectedPropertyValue: string;
function RowCount: Integer;
end;
var
FCanSelect: Boolean;
implementation
{ TMyInspectorItems }
constructor TMyInspectorItems.Create;
begin
inherited Create;
FPropertyNames := TStringList.Create;
FPropertyValues := TStringList.Create;
end;
destructor TMyInspectorItems.Destroy;
begin
FPropertyNames.Free;
FPropertyValues.Free;
inherited Destroy;
end;
procedure TMyInspectorItems.AddItem(APropName, APropValue: string);
begin
FPropertyNames.Add(APropName);
FPropertyValues.Add(APropValue);
end;
procedure TMyInspectorItems.Clear;
begin
FPropertyNames.Clear;
FPropertyValues.Clear;
end;
{ TMyCustomInspector }
constructor TMyCustomInspector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FInspectorItems := TMyInspectorItems.Create;
FNamesFont := TFont.Create;
FNamesFont.Color := clWindowText;
FNamesFont.Name := 'Segoe UI';
FNamesFont.Size := 9;
FNamesFont.Style := [];
FValuesFont := TFont.Create;
FValuesFont.Color := clNavy;
FValuesFont.Name := 'Segoe UI';
FValuesFont.Size := 9;
FValuesFont.Style := [];
end;
destructor TMyCustomInspector.Destroy;
begin
FInspectorItems.Free;
FNamesFont.Free;
FValuesFont.Free;
inherited Destroy;
end;
procedure TMyCustomInspector.Loaded;
begin
inherited Loaded;
end;
procedure TMyCustomInspector.Paint;
procedure DrawBackground;
begin
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
end;
procedure DrawNamesBackground;
begin
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, 0, Self.Width div 2, Self.Height));
end;
procedure DrawNamesSelection;
begin
if (FRowCount > -1) and (RowExists(MousePositionToRowIndex)) then
begin
Canvas.Brush.Color := $00E0E0E0;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, RowIndexToMousePosition(FSelectedRow),
Self.Width div 2, RowIndexToMousePosition(FSelectedRow) + GetRowHeight));
end;
end;
procedure DrawNamesText;
var
I: Integer;
Y: Integer;
begin
FRowCount := FInspectorItems.FPropertyNames.Count;
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := FNamesFont.Color;
Canvas.Font.Name := FNamesFont.Name;
Canvas.Font.Size := FNamesFont.Size;
Y := 0;
for I := 0 to FInspectorItems.FPropertyNames.Count -1 do
begin
Canvas.TextOut(2, Y, FInspectorItems.FPropertyNames.Strings[I]);
Inc(Y, GetRowHeight);
end;
end;
procedure DrawValuesBackground;
begin
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(Self.Width div 2, 0, Self.Width, Self.Height));
end;
procedure DrawValuesSelection;
begin
if (FRowCount > -1) and (RowExists(MousePositionToRowIndex)) then
begin
Canvas.DrawFocusRect(Rect(Self.Width div 2, RowIndexToMousePosition(FSelectedRow),
Self.Width, RowIndexToMousePosition(FSelectedRow) + GetRowHeight));
end;
end;
procedure DrawValues;
var
I, Y: Integer;
begin
FRowCount := FInspectorItems.FPropertyValues.Count;
Y := 0;
for I := 0 to FInspectorItems.FPropertyValues.Count -1 do
begin
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := FValuesFont.Color;
Canvas.Font.Name := FValuesFont.Name;
Canvas.Font.Size := FValuesFont.Size;
Canvas.TextOut(Self.Width div 2 + 2, Y + 1, FInspectorItems.FPropertyValues.Strings[I]);
Inc(Y, GetRowHeight);
end;
end;
begin
DrawNamesBackground;
DrawNamesSelection;
DrawNamesText;
DrawValuesBackground;
DrawValuesSelection;
DrawValues;
end;
procedure TMyCustomInspector.WMKeyDown(var Message: TMessage);
begin
inherited;
case Message.WParam of
VK_DOWN:
begin
end;
end;
end;
procedure TMyCustomInspector.WMMouseDown(var Message: TMessage);
begin
inherited;
Parent.SetFocus;
FSelectedRow := MousePositionToRowIndex;
if FSelectedRow <> -1 then
begin
if Assigned(FOnSelectRow) then
begin
FOnSelectRow(Self, FInspectorItems.FPropertyNames.Strings[FSelectedRow],
FInspectorItems.FPropertyValues.Strings[FSelectedRow], FSelectedRow);
end;
end;
Invalidate;
end;
procedure TMyCustomInspector.WMMouseMove(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseMove) then
begin
FOnMouseMove(Self, GetMousePosition.X, GetMousePosition.Y);
end;
end;
procedure TMyCustomInspector.WMMouseUp(var Message: TMessage);
begin
inherited;
end;
procedure TMyCustomInspector.SetNamesFont(const AValue: TFont);
begin
FNamesFont.Assign(AValue);
Invalidate;
end;
procedure TMyCustomInspector.SetValuesFont(const AValue: TFont);
begin
FValuesFont.Assign(AValue);
Invalidate;
end;
procedure TMyCustomInspector.CalculateInspectorHeight;
var
I, Y: Integer;
begin
FRowCount := FInspectorItems.FPropertyNames.Count;
Y := GetRowHeight;
for I := 0 to FRowCount -1 do
begin
Inc(Y, GetRowHeight);
end;
if Self.Height <> Y then
Self.Height := Y;
end;
function TMyCustomInspector.GetMousePosition: TPoint;
var
Pt: TPoint;
begin
Pt := Mouse.CursorPos;
Pt := ScreenToClient(Pt);
Result := Pt;
end;
function TMyCustomInspector.MousePositionToRowIndex: Integer;
begin
Result := GetMousePosition.Y div GetRowHeight;
end;
function TMyCustomInspector.RowIndexToMousePosition(
ARowIndex: Integer): Integer;
begin
Result := ARowIndex * GetRowHeight;
end;
function TMyCustomInspector.GetRowHeight: Integer;
begin
Result := FNamesFont.Size * 2 + 1;
end;
function TMyCustomInspector.GetValueRowWidth: Integer;
begin
Result := Self.Width div 2;
end;
function TMyCustomInspector.RowCount: Integer;
begin
Result := FRowCount;
end;
function TMyCustomInspector.RowExists(ARowIndex: Integer): Boolean;
begin
Result := MousePositionToRowIndex < RowCount;
end;
function TMyCustomInspector.IsRowSelected: Boolean;
begin
Result := FSelectedRow <> -1;
end;
{ TMyPropertyInspector }
constructor TMyPropertyInspector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Self.DoubleBuffered := True;
Self.Height := 150;
Self.HorzScrollBar.Visible := False;
Self.TabStop := True; // needed to receive focus
Self.Width := 250;
FInspector := TMyCustomInspector.Create(Self);
FInspector.Parent := Self;
FInspector.Align := alTop;
FInspector.Height := 0;
FInspector.OnSelectRow := SelectRow;
FInplaceStringEditor := TEdit.Create(Self);
FInplaceStringEditor.Parent := Self;
FInplaceStringEditor.BorderStyle := bsNone;
FInplaceStringEditor.Color := clWindow;
FInplaceStringEditor.Height := 0;
FInplaceStringEditor.Left := 0;
FInplaceStringEditor.Name := 'MyPropInspectorInplaceStringEditor';
FInplaceStringEditor.Top := 0;
FInplaceStringEditor.Visible := False;
FInplaceStringEditor.Width := 0;
FInplaceStringEditor.Font.Assign(FInspector.FValuesFont);
FInplaceStringEditor.OnEnter := InplaceStringEditorEnter;
FInplaceStringEditor.OnExit := InplaceStringEditorExit;
FInplaceStringEditor.OnKeyPress := InplaceStringEditorKeyPress;
FCanSelect := True;
end;
destructor TMyPropertyInspector.Destroy;
begin
FInspector.Free;
FInplaceStringEditor.Free;
inherited Destroy;
end;
procedure TMyPropertyInspector.Loaded;
begin
inherited Loaded;
end;
procedure TMyPropertyInspector.WMSize(var Message: TMessage);
begin
FInspector.Width := Self.Width;
Invalidate;
end;
procedure TMyPropertyInspector.AddItem(APropName, APropValue: string);
begin
FInspector.CalculateInspectorHeight;
FInspector.Items.AddItem(APropName, APropValue);
FInspector.Invalidate;
Self.Invalidate;
end;
function TMyPropertyInspector.GetSelectedPropertyName: string;
begin
Result := '';
if FInspector.FSelectedRow <> -1 then
begin
Result := FInspector.FInspectorItems.FPropertyNames.Strings[FInspector.FSelectedRow];
end;
end;
function TMyPropertyInspector.GetSelectedPropertyValue: string;
begin
Result := '';
if FInspector.FSelectedRow <> -1 then
begin
Result := FInspector.FInspectorItems.FPropertyValues.Strings[FInspector.FSelectedRow];
end;
end;
function TMyPropertyInspector.RowCount: Integer;
begin
Result := FInspector.RowCount;
end;
procedure TMyPropertyInspector.InplaceStringEditorEnter(Sender: TObject);
begin
FCanSelect := False;
FLastSelectedRow := FInplaceStringEditor.Tag;
end;
procedure TMyPropertyInspector.InplaceStringEditorExit(Sender: TObject);
begin
if SetPropertyValue(True) then
begin
FCanSelect := True;
end;
end;
procedure TMyPropertyInspector.InplaceStringEditorKeyPress(Sender: TObject;
var Key: Char);
begin
if Key = Chr(VK_RETURN) then
begin
Key := #0;
FInplaceStringEditor.SelectAll;
end;
end;
procedure TMyPropertyInspector.SelectRow(Sender: TObject; PropName, PropValue: string; RowIndex: Integer);
begin
FSelectedRowName := PropName;
FLastSelectedRowName := PropName;
FInplaceStringEditor.Height := FInspector.GetRowHeight - 2;
FInplaceStringEditor.Left := Self.Width div 2;
FInplaceStringEditor.Tag := RowIndex;
FInplaceStringEditor.Text := GetSelectedPropertyValue;
FInplaceStringEditor.Top := FInspector.RowIndexToMousePosition(FInspector.FSelectedRow) + 1 - Self.VertScrollBar.Position;
FInplaceStringEditor.Visible := True;
FInplaceStringEditor.Width := FInspector.GetValueRowWidth - 3;
FInplaceStringEditor.SetFocus;
FInplaceStringEditor.SelectAll;
end;
function TMyPropertyInspector.SetPropertyValue(
RevertToPreviousValueOnFail: Boolean): Boolean;
var
S: string;
begin
Result := False;
S := FInplaceStringEditor.Text;
if ValidateStringValue(S) then
begin
Result := True;
end
else
begin
ShowMessage('"' + S + '"' + 'is not a valid value.');
Result := False;
end;
end;
function TMyPropertyInspector.ValidateStringValue(Value: string): Boolean;
begin
// a quick and dirty way of testing for a valid string value, here we just
// look for strings that are not zero length.
Result := Length(Value) > 0;
end;
end.
Problem (detailed)
The confusion I have all comes down to who receives focus first and how to handle and respond to it correctly. Because I am custom drawing my rows I determine where the mouse is when clicking on the inspector control and then I draw the selected row to show this. When handling the inplace editors however, especially the OnEnter and OnExit event I have been facing all kinds of funky problems where in some cases I have been stuck in a cycle of the validate error message repeatedly showing for example (because focus is switching from my inspector to the inplace editor and back and forth).
To populate my inspector at runtime you can do the following:
procedure TForm1.Button1Click(Sender: TObject);
begin
MyPropertyInspector1.AddItem('A', 'Some Text');
MyPropertyInspector1.AddItem('B', 'Hello World');
MyPropertyInspector1.AddItem('C', 'Blah Blah');
MyPropertyInspector1.AddItem('D', 'The Sky is Blue');
MyPropertyInspector1.AddItem('E', 'Another String');
end;
A little something you may try:
Click on a row
Delete the contents from the inplace editor
Select another row
The validate error message box appears (don't close it yet)
With the message box still visible, move your mouse over another row
Now press Enter to close the message box
You will notice the selected row has now moved to where the mouse was
What I need is after the validate message box has shown and closed, I need to set the focus back to the row that was been validated in the first place. It gets confusing because it seems (or so I think) that the inplace editors OnExit is been called after the WMMouseDown(var Message: TMessage); code of my inspector.
To put it as simple as I can if the question remains unclear, the behavior of the Delphi Object Inspector is what I am trying to implement into my component. You enter a value into the inplace editors, if it fails the validation then display a messagebox and then focus back to the row that was last selected. The inplace editor validation should occur as soon as focus is switched away from the inplace editor.
I just can't seem to figure out what is been called first and what is blocking events been fired, it becomes confusing because the way I draw my selected row is determined by where the mouse was when clicking on the inspector control.
This is your flow of events:
TMyCustomInspector.WMMouseDown is called
Therein, Parent.SetFocus is called
The focus is removed from the Edit control and TMyPropertyInspector.InplaceStringEditorExit is called
The message dialog is shown by SetPropertyValue
FSelectedRow is being reset
TMyPropertyInspector.SelectRow is called (via TMyCustomInspector.FOnSelectRow) which resets the focus to the replaced Edit control.
What you need to is to prevent FSelectedRow being reset in case of validation did not succeed. All needed ingredients are already there, just add this one condition:
if FCanSelect then
FSelectedRow := MousePositionToRowIndex;
A few remarks:
Make FCanSelect a protected or private field of TMyCustomInspector,
You need to check for limits in TMyCustomInspector.MousePositionToRowIndex in order to return -1.
Your problem is very interesting. From what I gather, you want a way to reset the focus to the invalid row, when the evaluation is false. Where I see you do this is in your SetPropertyValue function. I believe if you do the following, you will be able to reset the focus after the user clicks "OK" in the message:
function TMyPropertyInspector.SetPropertyValue(
RevertToPreviousValueOnFail: Boolean): Boolean;
var
S: string;
begin
Result := False;
S := FInplaceStringEditor.Text;
if ValidateStringValue(S) then
begin
Result := True;
end
else
begin
if (MessageDlg('"' + S + '"' + 'is not a valid value.', mtError, [mbOK], 0)) = mrOK then
begin
SelectRow(nil, FSelectedRowName, FInplaceStringEditor.Text, FInplaceStringEditor.Tag);
end;
Result := False;
end;
end;
Changing the ShowMessage to MessageDlg will allow for an action to occur when the button is pressed. Then calling your SelectRow function with (what I believe are) global variables representing the information about the last row will set that focus to the bad cell.

Make a TDBEdit show the characters remaining

The problem I'm wanting to solve is to display to the user the remaining characters left in a field as they are typing into a TDBEdit.
Currently I'm doing something along the lines of
lCharRemaining.Caption := Field.Size - length(dbedit.text);
i.e. updating a label in the OnChange event for the TDBEdit, which works perfectly fine. However I'm wanting to do this for a number of TDBEdits and tried to write a custom component that would display the length remaining within the edit box on the right. It however interferes with editing. I was perhaps thinking that I could display a hint while someone was typing indicating the remaining space in the field - any suggestions?
Here is the code for my component (if someone can suggest improvements).
unit DBEditWithLenghtCountdown;
interface
uses
SysUtils, Classes, Controls, StdCtrls, Mask, DBCtrls, messages, Graphics;
type
TDBEditWithLenghtCountdown = class(TDBEdit)
private
{ Private declarations }
FCanvas: TCanvas;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
{ Protected declarations }
property Canvas: TCanvas read FCanvas;
procedure WndProc(var Message: TMessage); override;
public
{ Public declarations }
function CharactersRemaining : integer;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
end;
procedure Register;
implementation
uses
db, Types;
procedure Register;
begin
RegisterComponents('Samples', [TDBEditWithLenghtCountdown]);
end;
{ TDBEditWithLenghtCountdown }
function TDBEditWithLenghtCountdown.CharactersRemaining: integer;
begin
result := -1;
if Assigned(Field)then
begin
result := Field.Size - Length(Text);
end;
end;
constructor TDBEditWithLenghtCountdown.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
end;
destructor TDBEditWithLenghtCountdown.Destroy;
begin
FCanvas.Free;
inherited;
end;
procedure TDBEditWithLenghtCountdown.WMPaint(var Message: TWMPaint);
var
R: TRect;
Remaining : string;
WidthOfText: Integer;
x: Integer;
begin
inherited;
if not focused then
exit;
Remaining := IntToStr(CharactersRemaining);
R := ClientRect;
Inc(R.Left, 1);
Inc(R.Top, 1);
Canvas.Brush.Assign(Self.Brush);
Canvas.Brush.Style := bsClear;
Canvas.Font.Assign(Self.Font);
Canvas.Font.Color := clRed;
WidthOfText := Canvas.TextWidth(Remaining);
x := R.right - WidthOfText - 4;
Canvas.TextOut(x,2, Remaining);
end;
procedure TDBEditWithLenghtCountdown.WndProc(var Message: TMessage);
begin
inherited WndProc(Message);
with Message do
case Msg of
CM_MOUSEENTER, CM_MOUSELEAVE, WM_LBUTTONUP, WM_LBUTTONDOWN,
WM_KEYDOWN, WM_KEYUP,
WM_SETFOCUS, WM_KILLFOCUS,
CM_FONTCHANGED, CM_TEXTCHANGED:
begin
Invalidate;
end;
end; // case
end;
end.
You can test how it would look like without any text interference by setting the edit margins to leave space for the tip text. A quick test:
type
TDBEditWithLenghtCountdown = class(TDBEdit)
..
protected
procedure CreateWnd; override;
property Canvas: TCanvas read FCanvas;
..
procedure TDBEditWithLenghtCountdown.CreateWnd;
var
MaxWidth, Margins: Integer;
begin
inherited;
MaxWidth := Canvas.TextWidth('WW');
Margins := Perform(EM_GETMARGINS, 0, 0);
Margins := MakeLong(HiWord(Margins), LoWord(Margins) + MaxWidth);
Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, Margins);
end;
Beyond this is personal opinion but I find this a bit confusing. What I would do is probably publish a status panel field on the derived edit, and output some text to it if it is assigned when the text of the edit control changes.
edit: Here's a somewhat extended version that should take care of the issue mentioned in the comment (if navigate left with a long text, edit text overwrites tip text), and also sets margins only if the control has focus. (Not full code duplicated from the question, only modified bits.)
type
TDBEditWithLenghtCountdown = class(TDBEdit)
private
FCanvas: TCanvas;
FTipWidth: Integer;
FDefMargins: Integer;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
..
procedure TDBEditWithLenghtCountdown.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
EndPaint: Boolean;
Rgn: HRGN;
R, TipR: TRect;
Remaining : string;
begin
if not Focused then
inherited
else begin
EndPaint := Message.Dc = 0;
if Message.DC = 0 then
Message.DC := BeginPaint(Handle, PaintStruct);
R := ClientRect;
TipR := R;
TipR.Left := TipR.Right - FTipWidth;
Remaining := IntToStr(CharactersRemaining);
Canvas.Handle := Message.DC;
SetBkColor(Canvas.Handle, ColorToRGB(Color));
Canvas.Font := Font;
Canvas.Font.Color := clRed;
Canvas.TextRect(TipR, Remaining, [tfSingleLine, tfCenter, tfVerticalCenter]);
R.Right := TipR.Left;
Rgn := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);
SelectClipRgn(Canvas.Handle, Rgn);
DeleteObject(Rgn);
inherited;
if EndPaint then
windows.EndPaint(Handle, PaintStruct);
end;
end;
procedure TDBEditWithLenghtCountdown.WndProc(var Message: TMessage);
const
TipMargin = 3;
begin
inherited WndProc(Message);
with Message do
case Msg of
CM_MOUSEENTER, CM_MOUSELEAVE, WM_LBUTTONUP, WM_LBUTTONDOWN,
WM_KEYDOWN, WM_KEYUP,
CM_TEXTCHANGED: Invalidate;
WM_CREATE: FDefMargins := Perform(EM_GETMARGINS, 0, 0);
CM_FONTCHANGED:
begin
Canvas.Handle := 0;
Canvas.Font := Font;
FTipWidth := Canvas.TextWidth('67') + 2 * TipMargin;
end;
WM_SETFOCUS:
Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN,
MakeLong(HiWord(FDefMargins), LoWord(FDefMargins) + FTipWidth));
WM_KILLFOCUS:
Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, FDefMargins);
end;
end;
Just as a base for you to start with, if do not want to derive every Edit-Component, here is a general approach for every Component derived from TCustomEdit.
Set the MaxLength of the Edit-Component to a Value > 0 and this Unit will paint you a thin red line below the text as a fill indicator.
The Unit has only to be present in your Project.
unit ControlInfoHandler;
interface
uses
Vcl.Forms;
implementation
uses
System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.StdCtrls;
type
TControlInfoHandler = class( TComponent )
private
FCurrent : TWinControl;
FCurrentLength : Integer;
protected
procedure ActiveControlChange( Sender : TObject );
procedure ApplicationIdle( Sender : TObject; var Done : Boolean );
procedure Notification( AComponent : TComponent; Operation : TOperation ); override;
end;
THackedEdit = class( TCustomEdit )
published
property MaxLength;
end;
var
LControlInfoHandler : TControlInfoHandler;
{ TControlInfoHandler }
procedure TControlInfoHandler.ActiveControlChange( Sender : TObject );
begin
FCurrent := Screen.ActiveControl;
FCurrentLength := 0;
if Assigned( FCurrent )
then
FCurrent.FreeNotification( Self );
end;
procedure TControlInfoHandler.ApplicationIdle( Sender : TObject; var Done : Boolean );
var
LEdit : THackedEdit;
LCanvas : TControlCanvas;
LWidth : Integer;
begin
if not Assigned( FCurrent ) or not ( FCurrent is TCustomEdit )
then
Exit;
LEdit := THackedEdit( FCurrent as TCustomEdit );
if ( LEdit.MaxLength > 0 )
then
begin
LCanvas := TControlCanvas.Create;
LCanvas.Control := LEdit;
LCanvas.Pen.Style := psSolid;
LCanvas.Pen.Width := 2;
LWidth := LEdit.Width - 6;
if FCurrentLength <> LEdit.GetTextLen
then
begin
LCanvas.Pen.Color := LEdit.Color;
LCanvas.MoveTo( 0, LEdit.Height - 4 );
LCanvas.LineTo( LWidth, LEdit.Height - 4 );
end;
LCanvas.Pen.Color := clRed;
LWidth := LWidth * LEdit.GetTextLen div LEdit.MaxLength;
LCanvas.MoveTo( 0, LEdit.Height - 4 );
LCanvas.LineTo( LWidth, LEdit.Height - 4 );
FCurrentLength := LEdit.GetTextLen;
end;
end;
procedure TControlInfoHandler.Notification( AComponent : TComponent; Operation : TOperation );
begin
inherited;
if ( FCurrent = AComponent ) and ( Operation = opRemove )
then
FCurrent := nil;
end;
initialization
LControlInfoHandler := TControlInfoHandler.Create( Application );
Screen.OnActiveControlChange := LControlInfoHandler.ActiveControlChange;
Application.OnIdle := LControlInfoHandler.ApplicationIdle;
end.

Is VclStyle Bug ? TProgressBar.Style := pbstMarQuee Does not work

Is VclStyle Bug ? T^T I tried to find BugFix list(http://edn.embarcadero.com/article/42090/) but I can't
File > New > VCL Application
TProgressBar put main form >TProgressBar.Style := pbstMarQuee
Project Option > Appearence > set Custom Style > set Default Style
Ctrl + F9
ProgressBar does not work
Sorry. My english is bad :(
This is a feature not implemented in the TProgressBarStyleHook. Unfortunally Windows does not send any message to the progress bar control to indicate if the position of the bar changes when is in marquee mode, so you must implement your self a mechanism to mimic the PBS_MARQUEE Style, this can be easily done creating a new style hook and using a TTimer inside of the style hook.
Check this basic implementation of the Style hook
uses
Vcl.Styles,
Vcl.Themes,
Winapi.CommCtrl;
{$R *.dfm}
type
TProgressBarStyleHookMarquee=class(TProgressBarStyleHook)
private
Timer : TTimer;
FStep : Integer;
procedure TimerAction(Sender: TObject);
protected
procedure PaintBar(Canvas: TCanvas); override;
public
constructor Create(AControl: TWinControl); override;
destructor Destroy; override;
end;
constructor TProgressBarStyleHookMarquee.Create(AControl: TWinControl);
begin
inherited;
FStep:=0;
Timer := TTimer.Create(nil);
Timer.Interval := 100;//TProgressBar(Control).MarqueeInterval;
Timer.OnTimer := TimerAction;
Timer.Enabled := TProgressBar(Control).Style=pbstMarquee;
end;
destructor TProgressBarStyleHookMarquee.Destroy;
begin
Timer.Free;
inherited;
end;
procedure TProgressBarStyleHookMarquee.PaintBar(Canvas: TCanvas);
var
FillR, R: TRect;
W, Pos: Integer;
Details: TThemedElementDetails;
begin
if (TProgressBar(Control).Style=pbstMarquee) and StyleServices.Available then
begin
R := BarRect;
InflateRect(R, -1, -1);
if Orientation = pbHorizontal then
W := R.Width
else
W := R.Height;
Pos := Round(W * 0.1);
FillR := R;
if Orientation = pbHorizontal then
begin
FillR.Right := FillR.Left + Pos;
Details := StyleServices.GetElementDetails(tpChunk);
end
else
begin
FillR.Top := FillR.Bottom - Pos;
Details := StyleServices.GetElementDetails(tpChunkVert);
end;
FillR.SetLocation(FStep*FillR.Width, FillR.Top);
StyleServices.DrawElement(Canvas.Handle, Details, FillR);
Inc(FStep,1);
if FStep mod 10=0 then
FStep:=0;
end
else
inherited;
end;
procedure TProgressBarStyleHookMarquee.TimerAction(Sender: TObject);
var
Canvas: TCanvas;
begin
if StyleServices.Available and (TProgressBar(Control).Style=pbstMarquee) and Control.Visible then
begin
Canvas := TCanvas.Create;
try
Canvas.Handle := GetWindowDC(Control.Handle);
PaintFrame(Canvas);
PaintBar(Canvas);
finally
ReleaseDC(Handle, Canvas.Handle);
Canvas.Handle := 0;
Canvas.Free;
end;
end
else
Timer.Enabled := False;
end;
initialization
TStyleManager.Engine.RegisterStyleHook(TProgressBar, TProgressBarStyleHookMarquee);
end.
You can check a demo of this style hook here

Painting TPaintBox during Drag&Drop with DragImage

In my application (Delphi 2007) I want to drag items from a ListView to a PaintBox and highlight corresponding areas in the PaintBox's OnPaint handler. However I always get ugly artefacts. Do you have any advice how I can get rid of them?
Test project: Just create a new VCL application and replace the code in Unit1.pas with the following. Then start the app and drag list items over the rectangle in the PaintBox.
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
ComCtrls,
ImgList;
type
TForm1 = class(TForm)
private
PaintBox1: TPaintBox;
ListView1: TListView;
ImageList1: TImageList;
FRectIsHot: Boolean;
function GetSensitiveRect: TRect;
procedure PaintBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure PaintBox1Paint(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
TypInfo;
const
IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND,
IDI_ASTERISK, IDI_QUESTION, nil);
{ TForm1 }
constructor TForm1.Create(AOwner: TComponent);
var
Panel1: TPanel;
mt: TMsgDlgType;
Icon: TIcon;
li: TListItem;
begin
inherited Create(AOwner);
Width := 600;
Height := 400;
ImageList1 := TImageList.Create(Self);
ImageList1.Name := 'ImageList1';
ImageList1.Height := 32;
ImageList1.Width := 32;
ListView1 := TListView.Create(Self);
ListView1.Name := 'ListView1';
ListView1.Align := alLeft;
ListView1.DragMode := dmAutomatic;
ListView1.LargeImages := ImageList1;
Panel1 := TPanel.Create(Self);
Panel1.Name := 'Panel1';
Panel1.Caption := 'Drag list items here';
Panel1.Align := alClient;
PaintBox1 := TPaintBox.Create(Self);
PaintBox1.Name := 'PaintBox1';
PaintBox1.Align := alClient;
PaintBox1.ControlStyle := PaintBox1.ControlStyle + [csDisplayDragImage];
PaintBox1.OnDragOver := PaintBox1DragOver;
PaintBox1.OnPaint := PaintBox1Paint;
PaintBox1.Parent := Panel1;
ListView1.Parent := Self;
Panel1.Parent := Self;
Icon := TIcon.Create;
try
for mt := Low(TMsgDlgType) to High(TMsgDlgType) do
if Assigned(IconIDs[mt]) then
begin
li := ListView1.Items.Add;
li.Caption := GetEnumName(TypeInfo(TMsgDlgType), Ord(mt));
Icon.Handle := LoadIcon(0, IconIDs[mt]);
li.ImageIndex := ImageList1.AddIcon(Icon);
end;
finally
Icon.Free;
end;
end;
function TForm1.GetSensitiveRect: TRect;
begin
Result := PaintBox1.ClientRect;
InflateRect(Result, -PaintBox1.Width div 4, -PaintBox1.Height div 4);
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
r: TRect;
begin
r := GetSensitiveRect;
if FRectIsHot then
begin
PaintBox1.Canvas.Pen.Width := 5;
PaintBox1.Canvas.Brush.Style := bsSolid;
PaintBox1.Canvas.Brush.Color := clAqua;
end
else
begin
PaintBox1.Canvas.Pen.Width := 1;
PaintBox1.Canvas.Brush.Style := bsClear;
end;
PaintBox1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom);
end;
procedure TForm1.PaintBox1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
var
r: TRect;
MustRepaint: Boolean;
begin
MustRepaint := False;
if State = dsDragEnter then
begin
FRectIsHot := False;
MustRepaint := True;
end
else
begin
r := GetSensitiveRect;
Accept := PtInRect(r, Point(X, Y));
if Accept <> FRectIsHot then
begin
FRectIsHot := Accept;
MustRepaint := True;
end;
end;
if MustRepaint then
PaintBox1.Invalidate;
end;
end.
Edit: Here is a picture of the glitch:DragImage artefact http://img269.imageshack.us/img269/6535/15778780.png
I expect to see the complete blue rectangle with thick border. However beneath the drag image one can see the un-highlighted rectangle.
Edit 2: This site talks about "Painting Issues":
The ImageList SDK notes that when
drawing the drag image you can get
issues with updates or screen painting
unless you use the ImageList_DragLeave
API function to hide the drag image
whilst the painting occurs (which is
what the HideDragImage method in the
class does). Unfortunately, if you
don't own the control that's being
painted doing this isn't really an
option.
I don't have the problem mentioned in the last sentence. Nevertheless I wasn't able to find the right place and the right imagelist (it's not ImageList1 in my test project - probably ListView1.GetDragImages) to call ImageList_DragLeave.
The key is to hide the drag image before the paint box is redrawn, and to show it again after that. If you replace this code in your question:
procedure TForm1.PaintBox1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
var
r: TRect;
MustRepaint: Boolean;
begin
MustRepaint := False;
if State = dsDragEnter then
begin
FRectIsHot := False;
MustRepaint := True;
end
else
begin
r := GetSensitiveRect;
Accept := PtInRect(r, Point(X, Y));
if Accept <> FRectIsHot then
begin
FRectIsHot := Accept;
MustRepaint := True;
end;
end;
if MustRepaint then
PaintBox1.Invalidate;
end;
with this
procedure TForm1.PaintBox1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
var
r: TRect;
begin
if State = dsDragEnter then
begin
FRectIsHot := False;
PaintBox1.Invalidate;
end
else
begin
r := GetSensitiveRect;
Accept := PtInRect(r, Point(X, Y));
if Accept <> FRectIsHot then
begin
FRectIsHot := Accept;
ImageList_DragShowNolock(False);
try
PaintBox1.Refresh;
finally
ImageList_DragShowNolock(True);
end;
end;
end;
end;
it should work. Well, it does for me with Delphi 2007 on Windows XP 64 bit.
And kudos for the demonstration code in your question, excellent way to let us see the problem.
Tested on XP, Delphi 2010 - I get the artifacts, so it's XP related and not fixed in D2010
Edit:
Upon further investigation - if you drag an icon so that the mouse only just enters the box (but the icon doesn't) then the box is drawn correctly, it's only when the icon enters the paintbox that the artifacts occur.
I added code so that if state was dsDragMove then it would force a repaint and this worked, but suffered from flicker

Resources