Related
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.
I'm trying to figure out how I can make a custom control in a way where user can scroll in all directions, but with a fixed row and column. A grid is not suitable for what I'm trying to do, because it scrolls column by column. I need horizontal scrolling to be smooth, pixel by pixel. I have no use for columns, only visual grid lines. Vertical scrolling should scroll not only the area on the right, but also the fixed region on the left. Same with horizontal scrolling: the header row should move along with the horizontal scrollbar.
This is just a rough draft of the final control I'm working on.
Note how the scrollbars do not cover the full control, only the larger region. The fixed column/row should also be able to move along with their corresponding scrollbar.
How should I implement the scrollbars to make this possible?
PS - This is to replace a much more thorough question which was deleted for being a mis-leading request. So sorry if I'm lacking details which you might need to know.
First, I thought you could do with this component (sample image) which is capable of holding controls in cells, but from your comment I understand that you want to draw everything yourself. So I wrote a 'THeaderGrid' component:
procedure TForm1.FormCreate(Sender: TObject);
begin
with THeaderGrid.Create(Self) do
begin
Align := alClient;
OnDrawCell := DrawCell;
OnDrawColHeader := DrawCell;
OnDrawRowHeader := DrawCell;
Parent := Self;
end;
end;
procedure TForm1.DrawCell(Sender: TObject; ACanvas: TCanvas; ACol,
ARow: Integer; R: TRect);
begin
ACanvas.TextOut(R.Left + 2, R.Top + 2, Format('(%d,%d)', [ACol, ARow]));
end;
The component is build up out of three TPaintScroller controls (a TPaintBox on a TScrollBox). Actually, for both headers, TScrollBox is a little bit heavyweighted, but it was kind of handy to use the same control as for the data region with the cells.
There are three OnDraw events, one for both headers and one for the cells, but you could all set them to the same handler, alike the example above. Distinguish each by the column or row index being -1.
unit HeaderGrid;
interface
uses
Classes, Controls, Windows, Messages, Graphics, Forms, ExtCtrls, StdCtrls;
type
TPaintEvent = procedure(ACanvas: TCanvas) of object;
TPaintScroller = class(TScrollingWinControl)
private
FOnPaint: TPaintEvent;
FOnScroll: TNotifyEvent;
FPainter: TPaintBox;
function GetPaintHeight: Integer;
function GetPaintWidth: Integer;
function GetScrollBars: TScrollStyle;
procedure SetPaintHeight(Value: Integer);
procedure SetPaintWidth(Value: Integer);
procedure SetScrollBars(Value: TScrollStyle);
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMHScroll(var Message: TWMScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMScroll); message WM_VSCROLL;
protected
procedure CreateParams(var Params: TCreateParams); override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
procedure DoPaint(Sender: TObject); virtual;
procedure DoScroll; virtual;
procedure PaintWindow(DC: HDC); override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
published
property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
property PaintHeight: Integer read GetPaintHeight write SetPaintHeight;
property PaintWidth: Integer read GetPaintWidth write SetPaintWidth;
property ScrollBars: TScrollStyle read GetScrollBars write SetScrollBars
default ssBoth;
end;
TDrawCellEvent = procedure(Sender: TObject; ACanvas: TCanvas; ACol,
ARow: Integer; R: TRect) of object;
THeaderGrid = class(TCustomControl)
private
FCellScroller: TPaintScroller;
FColCount: Integer;
FColHeader: TPaintScroller;
FColWidth: Integer;
FOnDrawCell: TDrawCellEvent;
FOnDrawColHeader: TDrawCellEvent;
FOnDrawRowHeader: TDrawCellEvent;
FRowCount: Integer;
FRowHeader: TPaintScroller;
FRowHeight: Integer;
procedure CellsScrolled(Sender: TObject);
function GetColHeaderHeight: Integer;
function GetRowHeaderWidth: Integer;
procedure PaintCells(ACanvas: TCanvas);
procedure PaintColHeader(ACanvas: TCanvas);
procedure PaintRowHeader(ACanvas: TCanvas);
procedure SetColCount(Value: Integer);
procedure SetColHeaderHeight(Value: Integer);
procedure SetColWidth(Value: Integer);
procedure SetRowCount(Value: Integer);
procedure SetRowHeaderWidth(Value: Integer);
procedure SetRowHeight(Value: Integer);
procedure UpdateSize;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure DoDrawCell(ACanvas: TCanvas; ACol, ARow: Integer;
R: TRect); virtual;
procedure DoDrawColHeader(ACanvas: TCanvas; ACol: Integer;
R: TRect); virtual;
procedure DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
R: TRect); virtual;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
procedure MouseWheelHandler(var Message: TMessage); override;
published
property ColCount: Integer read FColCount write SetColCount default 5;
property ColHeaderHeight: Integer read GetColHeaderHeight
write SetColHeaderHeight default 24;
property ColWidth: Integer read FColWidth write SetColWidth default 64;
property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
property OnDrawColHeader: TDrawCellEvent read FOnDrawColHeader
write FOnDrawColHeader;
property OnDrawRowHeader: TDrawCellEvent read FOnDrawRowHeader
write FOnDrawRowHeader;
property RowCount: Integer read FRowCount write SetRowCount default 5;
property RowHeaderWidth: Integer read GetRowHeaderWidth
write SetRowHeaderWidth default 64;
property RowHeight: Integer read FRowHeight write SetRowHeight default 24;
published
property Color;
property Font;
property ParentColor default False;
property TabStop default True;
end;
implementation
{ TPaintScroller }
constructor TPaintScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
HorzScrollBar.Tracking := True;
VertScrollBar.Tracking := True;
Width := 100;
Height := 100;
FPainter := TPaintBox.Create(Self);
FPainter.SetBounds(0, 0, 100, 100);
FPainter.OnPaint := DoPaint;
FPainter.Parent := Self;
end;
procedure TPaintScroller.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
function TPaintScroller.DoMouseWheel(Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
VertScrollBar.Position := VertScrollBar.Position - WheelDelta;
DoScroll;
Result := True;
end;
procedure TPaintScroller.DoPaint(Sender: TObject);
begin
if Assigned(FOnPaint) then
FOnPaint(FPainter.Canvas);
end;
procedure TPaintScroller.DoScroll;
begin
if Assigned(FOnScroll) then
FOnScroll(Self);
end;
function TPaintScroller.GetPaintHeight: Integer;
begin
Result := FPainter.Height;
end;
function TPaintScroller.GetPaintWidth: Integer;
begin
Result := FPainter.Width;
end;
function TPaintScroller.GetScrollBars: TScrollStyle;
begin
if HorzScrollBar.Visible and VertScrollBar.Visible then
Result := ssBoth
else if not HorzScrollBar.Visible and VertScrollBar.Visible then
Result := ssVertical
else if HorzScrollBar.Visible and not VertScrollBar.Visible then
Result := ssHorizontal
else
Result := ssNone;
end;
procedure TPaintScroller.PaintWindow(DC: HDC);
begin
with FPainter do
ExcludeClipRect(DC, 0, 0, Width + Left, Height + Top);
FillRect(DC, ClientRect, Brush.Handle);
end;
procedure TPaintScroller.Resize;
begin
DoScroll;
inherited Resize;
end;
procedure TPaintScroller.SetPaintHeight(Value: Integer);
begin
FPainter.Height := Value;
end;
procedure TPaintScroller.SetPaintWidth(Value: Integer);
begin
FPainter.Width := Value;
end;
procedure TPaintScroller.SetScrollBars(Value: TScrollStyle);
begin
HorzScrollBar.Visible := (Value = ssBoth) or (Value = ssHorizontal);
VertScrollBar.Visible := (Value = ssBoth) or (Value = ssVertical);
end;
procedure TPaintScroller.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TPaintScroller.WMHScroll(var Message: TWMScroll);
begin
inherited;
DoScroll;
end;
procedure TPaintScroller.WMVScroll(var Message: TWMScroll);
begin
inherited;
DoScroll;
end;
{ THeaderGrid }
procedure THeaderGrid.CellsScrolled(Sender: TObject);
begin
FColHeader.FPainter.Left := -FCellScroller.HorzScrollBar.Position;
FRowHeader.FPainter.Top := -FCellScroller.VertScrollBar.Position;
end;
constructor THeaderGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
ParentColor := False;
TabStop := True;
FCellScroller := TPaintScroller.Create(Self);
FCellScroller.Anchors := [akLeft, akTop, akRight, akBottom];
FCellScroller.OnPaint := PaintCells;
FCellScroller.OnScroll := CellsScrolled;
FCellScroller.AutoScroll := True;
FCellScroller.Parent := Self;
FColHeader := TPaintScroller.Create(Self);
FColHeader.Anchors := [akLeft, akTop, akRight];
FColHeader.OnPaint := PaintColHeader;
FColHeader.ScrollBars := ssNone;
FColHeader.Parent := Self;
FRowHeader := TPaintScroller.Create(Self);
FRowHeader.Anchors := [akLeft, akTop, akBottom];
FRowHeader.OnPaint := PaintRowHeader;
FRowHeader.ScrollBars := ssNone;
FRowHeader.Parent := Self;
Width := 320;
Height := 120;
ColCount := 5;
RowCount := 5;
ColWidth := 64;
RowHeight := 24;
ColHeaderHeight := 24;
RowHeaderWidth := 64;
end;
procedure THeaderGrid.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure THeaderGrid.DoDrawCell(ACanvas: TCanvas; ACol, ARow: Integer;
R: TRect);
begin
if Assigned(FOnDrawCell) then
FOnDrawCell(Self, ACanvas, ACol, ARow, R);
end;
procedure THeaderGrid.DoDrawColHeader(ACanvas: TCanvas; ACol: Integer;
R: TRect);
begin
if Assigned(FOnDrawColHeader) then
FOnDrawColHeader(Self, ACanvas, ACol, -1, R);
end;
procedure THeaderGrid.DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
R: TRect);
begin
if Assigned(FOnDrawRowHeader) then
FOnDrawRowHeader(Self, ACanvas, -1, ARow, R);
end;
function THeaderGrid.GetColHeaderHeight: Integer;
begin
Result := FColHeader.Height;
end;
function THeaderGrid.GetRowHeaderWidth: Integer;
begin
Result := FRowHeader.Width;
end;
procedure THeaderGrid.MouseWheelHandler(var Message: TMessage);
begin
with Message do
Result := FCellScroller.Perform(CM_MOUSEWHEEL, WParam, LParam);
if Message.Result = 0 then
inherited MouseWheelHandler(Message);
end;
procedure THeaderGrid.Paint;
var
R: TRect;
begin
Canvas.Brush.Color := Color;
R := Rect(0, 0, RowHeaderWidth, ColHeaderHeight);
if IntersectRect(R, R, Canvas.ClipRect) then
Canvas.FillRect(R);
Canvas.Brush.Color := clBlack;
R := Rect(0, ColHeaderHeight, Width, ColHeaderHeight + 1);
if IntersectRect(R, R, Canvas.ClipRect) then
Canvas.FillRect(R);
R := Rect(RowHeaderWidth, 0, RowHeaderWidth + 1, Height);
if IntersectRect(R, R, Canvas.ClipRect) then
Canvas.FillRect(R);
end;
procedure THeaderGrid.PaintCells(ACanvas: TCanvas);
var
Col: Integer;
Row: Integer;
R: TRect;
Dummy: TRect;
begin
ACanvas.Brush.Color := Color;
ACanvas.Font := Font;
ACanvas.FillRect(ACanvas.ClipRect);
for Row := 0 to FRowCount - 1 do
begin
R := Bounds(0, Row * FRowHeight, FColWidth, FRowHeight);
for Col := 0 to FColCount - 1 do
begin
if IntersectRect(Dummy, R, ACanvas.ClipRect) then
begin
DoDrawCell(ACanvas, Col, Row, R);
if ACanvas.Pen.Style <> psSolid then
ACanvas.Pen.Style := psSolid;
if ACanvas.Pen.Color <> clSilver then
ACanvas.Pen.Color := clSilver;
ACanvas.MoveTo(R.Left, R.Bottom - 1);
ACanvas.LineTo(R.Right - 1, R.Bottom - 1);
ACanvas.LineTo(R.Right - 1, R.Top - 1);
end;
OffsetRect(R, FColWidth, 0);
end;
end;
end;
procedure THeaderGrid.PaintColHeader(ACanvas: TCanvas);
var
Col: Integer;
R: TRect;
Dummy: TRect;
begin
ACanvas.Brush.Color := Color;
ACanvas.Font := Font;
ACanvas.FillRect(ACanvas.ClipRect);
R := Rect(0, 0, FColWidth, ColHeaderHeight);
for Col := 0 to FColCount - 1 do
begin
if IntersectRect(Dummy, R, ACanvas.ClipRect) then
DoDrawColHeader(ACanvas, Col, R);
OffsetRect(R, FColWidth, 0);
end;
end;
procedure THeaderGrid.PaintRowHeader(ACanvas: TCanvas);
var
Row: Integer;
R: TRect;
Dummy: TRect;
begin
ACanvas.Brush.Color := Color;
ACanvas.Font := Font;
ACanvas.FillRect(ACanvas.ClipRect);
R := Rect(0, 0, RowHeaderWidth, FRowHeight);
for Row := 0 to FRowCount - 1 do
begin
if IntersectRect(Dummy, R, ACanvas.ClipRect) then
begin
DoDrawRowHeader(ACanvas, Row, R);
if ACanvas.Pen.Style <> psSolid then
ACanvas.Pen.Style := psSolid;
if ACanvas.Pen.Color <> clSilver then
ACanvas.Pen.Color := clSilver;
ACanvas.MoveTo(R.Left, R.Bottom - 1);
ACanvas.LineTo(R.Right - 1, R.Bottom - 1);
end;
OffsetRect(R, 0, FRowHeight);
end;
end;
procedure THeaderGrid.SetColCount(Value: Integer);
begin
if FColCount <> Value then
begin
FColCount := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.SetColHeaderHeight(Value: Integer);
begin
if Value >= 0 then
begin
FColHeader.Height := Value;
FRowHeader.BoundsRect := Rect(0, Value + 1, RowHeaderWidth, Height);
FCellScroller.BoundsRect := Rect(RowHeaderWidth + 1, Value + 1, Width,
Height);
end;
end;
procedure THeaderGrid.SetColWidth(Value: Integer);
begin
if FColWidth <> Value then
begin
FColWidth := Value;
FCellScroller.HorzScrollBar.Increment := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.SetRowCount(Value: Integer);
begin
if FRowCount <> Value then
begin
FRowCount := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.SetRowHeaderWidth(Value: Integer);
begin
if Value >= 0 then
begin
FRowHeader.Width := Value;
FColHeader.BoundsRect := Rect(Value + 1, 0, Width, ColHeaderHeight);
FCellScroller.BoundsRect := Rect(Value + 1, ColHeaderHeight + 1, Width,
Height);
end;
end;
procedure THeaderGrid.SetRowHeight(Value: Integer);
begin
if FRowHeight <> Value then
begin
FRowHeight := Value;
FCellScroller.VertScrollBar.Increment := Value;
UpdateSize;
end;
end;
procedure THeaderGrid.UpdateSize;
begin
FColHeader.PaintWidth := FColCount * FColWidth;
FRowHeader.PaintHeight := FRowCount * FRowHeight;
FCellScroller.PaintWidth := FColCount * FColWidth;
FCellScroller.PaintHeight := FRowCount * FRowHeight;
end;
procedure THeaderGrid.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
end.
The easiest way is to make a control without scrollbars and then put scrollbars over it with fine control of their size and position.
With Delphi 3-5 you could then encapsulate it as your new control using Custom Containers Pack, and drop onto new forms just like u do with regular grid.
Since D5 CCP is no more available but limited analogue is given as VCL TFrame.
OR you can create those scrollbars in runtime - you need to search for Windows Handle creating routine, (trace TControl.Handle getter method), that might be ReCreateWnd or such, and as GDI handle created - create your scroll-bars over it.
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
I'm creating an instance of my custom DragObject on StartDrag:
procedure TForm1.GridStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
DragObject := TMyDragControlObject.Create(Sender as TcxGridSite);
end;
Lately on another grid on DragOver:
procedure TForm1.SecondGridDragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := False;
if Source is TMyDragControlObject then
with TMyDragControlObject(Source) do
// using TcxGrid
if (Control is TcxGridSite) or (Control is TcxGrid) then begin
Accept := True
// checking the record value on grid
// the label of drag cursor will be different
// getting the record value works fine!
if RecordOnGrid.Value > 5 then
DragOverPaint(FImageList, 'You can drop here!');
else begin
Accept := false;
DragOverPaint(FImageList, 'You can''t drop here!');
end
end;
end;
My DragOverPaint procedure:
procedure TForm1.DragOverPaint(ImageList: TImageList; AValue: string);
var ABmp: TBitmap;
begin
if not Assigned(ImageList) then Exit;
ABmp := TBitmap.Create();
try
with ABmp.Canvas do begin
ABmp.Width := TextWidth(AValue);
ABmp.Height := TextHeight(AValue);
TextOut(0, 0, AValue);
end;
ImageList.BeginUpdate;
ImageList.Clear;
ImageList.Width := ABmp.Width;
ImageList.Height := ABmp.Height;
ImageList.AddMasked(ABmp, clNone);
ImageList.EndUpdate;
finally
ABmp.Free();
end;
Repaint;
end;
I want it to repaint DragImageList depending on the grid record value, but the image list doesn't refresh when it's already painted.
Once the ImageList has started dragging, you cannot change the drag image by changing the ImageList because Windows creates another temporarily blended ImageList specially for the dragging. So you have to end, change and start the ImageList dragging again (this is not equal to ending and starting the complete VCL dragging operation, just the WinAPI ImageList). The result/downside is a slight quiver at the transition of the images.
The moment of changing the images is when Accepted changes (in this specific case). It is possible to deal with this in OnDragOver, but since you create an own DragObject already, you can also override the therefor designed methods of TDragObject:
type
TControlAccess = class(TControl);
TMyDragControlObject = class(TDragControlObjectEx)
private
FDragImages: TDragImageList;
FPrevAccepted: Boolean;
protected
function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
function GetDragImages: TDragImageList; override;
public
destructor Destroy; override;
end;
{ TMyDragControlObject }
destructor TMyDragControlObject.Destroy;
begin
FDragImages.Free;
inherited Destroy;
end;
function TMyDragControlObject.GetDragCursor(Accepted: Boolean; X,
Y: Integer): TCursor;
begin
if FPrevAccepted <> Accepted then
with FDragImages do
begin
EndDrag;
SetDragImage(Ord(Accepted), 0, 0);
BeginDrag(GetDesktopWindow, X, Y);
end;
FPrevAccepted := Accepted;
Result := inherited GetDragCursor(Accepted, X, Y);
end;
function TMyDragControlObject.GetDragImages: TDragImageList;
const
SNoDrop = 'You can''t drop here!!';
SDrop = 'You can drop here.';
Margin = 20;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Canvas.Font.Assign(TControlAccess(Control).Font);
Bmp.Width := Bmp.Canvas.TextWidth(SNoDrop) + Margin;
Bmp.Height := Bmp.Canvas.TextHeight(SNoDrop);
Bmp.Canvas.TextOut(Margin, 0, SNoDrop);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.Add(Bmp, nil);
Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
Bmp.Canvas.TextOut(Margin, 0, SDrop);
FDragImages.Add(Bmp, nil);
FDragImages.SetDragImage(0, 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Grid1.ControlStyle := Grid1.ControlStyle + [csDisplayDragImage];
Grid2.ControlStyle := Grid2.ControlStyle + [csDisplayDragImage];
end;
procedure TForm1.Grid1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
DragObject := TMyDragControlObject.Create(Sender as TStringGrid);
end;
procedure TForm1.Grid2DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := False;
if IsDragObject(Source) then
with TMyDragControlObject(Source) do
if Control is TGrid then
{ Just some condition for testing }
if Y > Control.Height div 2 then
Accept := True;
end;
As NGLN pointed out, the reason for the change not taking effect is that Windows creates a temporary image list while dragging. As a slightly different solution, you can directly change the image in this temporary list.
The below is the modified DragOverPaint accordingly. Note that you should still make use of some kind of a flag for not repopulating the list with every mouse move as in NGLN's answer.
procedure TForm1.DragOverPaint(ImageList: TImageList; AValue: string);
var
ABmp: TBitmap;
ImgList: HIMAGELIST; // <- will get the temporary image list
begin
if not Assigned(ImageList) then Exit;
ABmp := TBitmap.Create();
try
with ABmp.Canvas do begin
ABmp.Width := TextWidth(AValue);
ABmp.Height := TextHeight(AValue);
TextOut(0, 0, AValue);
end;
// ImageList.BeginUpdate; // do not fiddle with the image list,
// ImageList.Clear; // it's not used while dragging
// ImageList.Width := ABmp.Width;
// ImageList.Height := ABmp.Height;
// ImageList.AddMasked(ABmp, clNone);
// ImageList.EndUpdate;
// get the temporary image list
ImgList := ImageList_GetDragImage(nil, nil);
// set the dimensions for images and empty the list
ImageList_SetIconSize(ImgList, ABmp.Width, ABmp.Height);
// add the text as the first image
ImageList_AddMasked(ImgList, ABmp.Handle, ColorToRGB(clWhite));
finally
ABmp.Free();
end;
// Repaint; // <- No need to repaint the form
end;
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